Agda 2.8.0.2 → 2.9.0
raw patch · 484 files changed
+54569/−33236 lines, 484 filesdep +blaze-markupdep +ghc-bignumdep +ghc-primdep −STMonadTransdep −binarydep −ghc-compactdep ~aesondep ~ansi-terminaldep ~asyncPVP ok
version bump matches the API change (PVP)
Dependencies added: blaze-markup, ghc-bignum, ghc-prim, infinite-list, primitive, zstd
Dependencies removed: STMonadTrans, binary, ghc-compact, th-lift-instances, zlib
Dependency ranges changed: aeson, ansi-terminal, async, base, bytestring, containers, deepseq, directory, dlist, equivalence, filelock, filepath, generic-data, hashable, haskeline, monad-control, murmur-hash, nonempty-containers, pqueue, process, regex-tdfa, split, stm, template-haskell, text, time, unordered-containers, vector, vector-hashtables
API changes (from Hackage documentation)
- Agda.Benchmarking: InverseScopeLookup :: Phase
- Agda.Compiler.JS.Pretty: instance Agda.Compiler.JS.Pretty.Pretty Agda.Compiler.JS.Syntax.Comment
- Agda.Compiler.JS.Substitution: object :: [([MemberId], Exp)] -> Exp
- Agda.Compiler.JS.Substitution: union :: Exp -> Exp -> Exp
- Agda.Compiler.JS.Substitution: vine :: [MemberId] -> Exp -> Exp
- Agda.Compiler.JS.Syntax: Comment :: String -> Comment
- Agda.Compiler.JS.Syntax: Const :: String -> Exp
- Agda.Compiler.JS.Syntax: instance Agda.Compiler.JS.Syntax.Globals Agda.Compiler.JS.Syntax.Comment
- Agda.Compiler.JS.Syntax: instance Agda.Compiler.JS.Syntax.Uses Agda.Compiler.JS.Syntax.Comment
- Agda.Compiler.JS.Syntax: instance GHC.Base.Monoid Agda.Compiler.JS.Syntax.Comment
- Agda.Compiler.JS.Syntax: instance GHC.Base.Semigroup Agda.Compiler.JS.Syntax.Comment
- Agda.Compiler.JS.Syntax: instance GHC.Classes.Eq Agda.Compiler.JS.Syntax.Comment
- Agda.Compiler.JS.Syntax: instance GHC.Classes.Ord Agda.Compiler.JS.Syntax.Comment
- Agda.Compiler.JS.Syntax: instance GHC.Show.Show Agda.Compiler.JS.Syntax.Comment
- Agda.Compiler.JS.Syntax: newtype Comment
- Agda.Compiler.MAlonzo.Primitives: importsForPrim :: BuiltinThings -> [Definition] -> [ModuleName]
- Agda.Compiler.MAlonzo.Primitives: xForPrim :: Map SomeBuiltin a -> BuiltinThings -> [Definition] -> [a]
- Agda.Interaction.BasicOps: getConstraints' :: (ProblemConstraint -> TCM ProblemConstraint) -> (ProblemConstraint -> Bool) -> TCM [OutputForm Expr Expr]
- Agda.Interaction.BasicOps: showGoals :: Goals -> TCM String
- Agda.Interaction.EmacsCommand: A :: a -> Lisp a
- Agda.Interaction.EmacsCommand: Cons :: Lisp a -> Lisp a -> Lisp a
- Agda.Interaction.EmacsCommand: L :: [Lisp a] -> Lisp a
- Agda.Interaction.EmacsCommand: Q :: Lisp a -> Lisp a
- Agda.Interaction.EmacsCommand: clearWarning :: Lisp String
- Agda.Interaction.EmacsCommand: data Lisp a
- Agda.Interaction.EmacsCommand: display_info' :: Bool -> String -> String -> Lisp String
- Agda.Interaction.EmacsCommand: instance Agda.Syntax.Common.Pretty.Pretty a => Agda.Syntax.Common.Pretty.Pretty (Agda.Interaction.EmacsCommand.Lisp a)
- Agda.Interaction.EmacsCommand: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.Interaction.EmacsCommand.Lisp a)
- Agda.Interaction.EmacsCommand: putResponse :: Lisp String -> IO ()
- Agda.Interaction.EmacsCommand: response :: Lisp String -> String
- Agda.Interaction.EmacsTop: showGoals :: Goals -> TCM String
- Agda.Interaction.Highlighting.Precise: IncompletePattern :: OtherAspect
- Agda.Interaction.Highlighting.Precise: instance Control.DeepSeq.NFData Agda.Syntax.Common.Aspect.Aspect
- Agda.Interaction.Highlighting.Precise: instance Control.DeepSeq.NFData Agda.Syntax.Common.Aspect.Aspects
- Agda.Interaction.Highlighting.Precise: instance Control.DeepSeq.NFData Agda.Syntax.Common.Aspect.DefinitionSite
- Agda.Interaction.Highlighting.Precise: instance Control.DeepSeq.NFData Agda.Syntax.Common.Aspect.OtherAspect
- Agda.Interaction.Highlighting.Range: Range :: !Int -> !Int -> Range
- Agda.Interaction.Highlighting.Range: Ranges :: [Range] -> Ranges
- Agda.Interaction.Highlighting.Range: [from] :: Range -> !Int
- Agda.Interaction.Highlighting.Range: [to] :: Range -> !Int
- Agda.Interaction.Highlighting.Range: data Range
- Agda.Interaction.Highlighting.Range: empty :: Null a => a
- Agda.Interaction.Highlighting.Range: instance Agda.Utils.Null.Null Agda.Interaction.Highlighting.Range.Range
- Agda.Interaction.Highlighting.Range: instance Control.DeepSeq.NFData Agda.Interaction.Highlighting.Range.Range
- Agda.Interaction.Highlighting.Range: instance Control.DeepSeq.NFData Agda.Interaction.Highlighting.Range.Ranges
- Agda.Interaction.Highlighting.Range: instance GHC.Classes.Eq Agda.Interaction.Highlighting.Range.Range
- Agda.Interaction.Highlighting.Range: instance GHC.Classes.Eq Agda.Interaction.Highlighting.Range.Ranges
- Agda.Interaction.Highlighting.Range: instance GHC.Classes.Ord Agda.Interaction.Highlighting.Range.Range
- Agda.Interaction.Highlighting.Range: instance GHC.Show.Show Agda.Interaction.Highlighting.Range.Range
- Agda.Interaction.Highlighting.Range: instance GHC.Show.Show Agda.Interaction.Highlighting.Range.Ranges
- Agda.Interaction.Highlighting.Range: minus :: Ranges -> Ranges -> Ranges
- Agda.Interaction.Highlighting.Range: newtype Ranges
- Agda.Interaction.Highlighting.Range: overlapping :: Range -> Range -> Bool
- Agda.Interaction.Highlighting.Range: overlappings :: Ranges -> Ranges -> Bool
- Agda.Interaction.Highlighting.Range: rangeInvariant :: Range -> Bool
- Agda.Interaction.Highlighting.Range: rangeToPositions :: Range -> [Int]
- Agda.Interaction.Highlighting.Range: rangesInvariant :: Ranges -> Bool
- Agda.Interaction.Highlighting.Range: rangesToPositions :: Ranges -> [Int]
- Agda.Interaction.Imports: scopeCheckImport :: TopLevelModuleName -> TCM (ModuleName, Map ModuleName Scope)
- Agda.Interaction.Options: standardOptions_ :: [OptDescr ()]
- Agda.Interaction.Options: usage :: [OptDescr ()] -> String -> Help -> String
- Agda.Interaction.Options.Errors: CosplitCatchall_ :: SplitError_
- Agda.Interaction.Options.Errors: GenericDocError_ :: ErrorName
- Agda.Interaction.Options.Errors: GenericError_ :: ErrorName
- Agda.Interaction.Options.Errors: IllegalDeclarationInDataDefinition_ :: ErrorName
- Agda.Interaction.Options.Errors: NoErasedMatches :: ErasedDatatypeReason
- Agda.Interaction.Options.Errors: NoK :: ErasedDatatypeReason
- Agda.Interaction.Options.Errors: RecursiveRecordNeedsInductivity_ :: ErrorName
- Agda.Interaction.Options.Errors: UnequalCohesion_ :: ErrorName
- Agda.Interaction.Options.Errors: UnequalFiniteness_ :: ErrorName
- Agda.Interaction.Options.Errors: UnequalHiding_ :: ErrorName
- Agda.Interaction.Options.Errors: UnequalLevel_ :: ErrorName
- Agda.Interaction.Options.Errors: UnequalPolarity_ :: ErrorName
- Agda.Interaction.Options.Errors: UnequalQuantity_ :: ErrorName
- Agda.Interaction.Options.Errors: UnequalRelevance_ :: ErrorName
- Agda.Interaction.Options.Errors: UnequalSorts_ :: ErrorName
- Agda.Interaction.Options.Errors: instance (GHC.Enum.Bounded a, GHC.Enum.Enum a) => GHC.Enum.Bounded (GHC.Maybe.Maybe a)
- Agda.Interaction.Options.Lenses: getIncludePaths :: LensIncludePaths a => a -> [FilePath]
- Agda.Interaction.Options.Lenses: mapIncludePaths :: LensIncludePaths a => ([FilePath] -> [FilePath]) -> a -> a
- Agda.Interaction.Options.Lenses: modifyIncludePaths :: MonadTCState m => ([FilePath] -> [FilePath]) -> m ()
- Agda.Interaction.Options.Lenses: putIncludePaths :: MonadTCState m => [FilePath] -> m ()
- Agda.Interaction.Options.Lenses: setIncludePaths :: LensIncludePaths a => [FilePath] -> a -> a
- Agda.Interaction.Options.Warnings: SafeFlagEta_ :: WarningName
- Agda.Interaction.Options.Warnings: warningName2String :: WarningName -> String
- Agda.Main: backendUsage :: Backend -> String
- Agda.Mimer.Mimer: MimerClauses :: QName -> [Clause] -> MimerResult
- Agda.Mimer.Mimer: instance Agda.Syntax.Common.Pretty.Pretty Agda.Mimer.Mimer.BaseComponents
- Agda.Mimer.Mimer: instance Agda.Syntax.Common.Pretty.Pretty Agda.Mimer.Mimer.Component
- Agda.Mimer.Mimer: instance Agda.Syntax.Common.Pretty.Pretty Agda.Mimer.Mimer.Costs
- Agda.Mimer.Mimer: instance Agda.Syntax.Common.Pretty.Pretty Agda.Mimer.Mimer.Goal
- Agda.Mimer.Mimer: instance Agda.Syntax.Common.Pretty.Pretty Agda.Mimer.Mimer.SearchBranch
- Agda.Mimer.Mimer: instance Agda.Syntax.Common.Pretty.Pretty Agda.Mimer.Mimer.SearchOptions
- Agda.Mimer.Mimer: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Mimer.Mimer.BaseComponents
- Agda.Mimer.Mimer: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Mimer.Mimer.Component
- Agda.Mimer.Mimer: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Mimer.Mimer.MimerResult
- Agda.Mimer.Mimer: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Mimer.Mimer.SearchOptions
- Agda.Mimer.Mimer: instance Control.DeepSeq.NFData Agda.Mimer.Mimer.BaseComponents
- Agda.Mimer.Mimer: instance Control.DeepSeq.NFData Agda.Mimer.Mimer.Component
- Agda.Mimer.Mimer: instance Control.DeepSeq.NFData Agda.Mimer.Mimer.Goal
- Agda.Mimer.Mimer: instance Control.DeepSeq.NFData Agda.Mimer.Mimer.MimerResult
- Agda.Mimer.Mimer: instance Control.DeepSeq.NFData Agda.Mimer.Mimer.MimerStats
- Agda.Mimer.Mimer: instance Control.DeepSeq.NFData Agda.Mimer.Mimer.SearchBranch
- Agda.Mimer.Mimer: instance Control.DeepSeq.NFData Agda.Mimer.Mimer.SearchStepResult
- Agda.Mimer.Mimer: instance GHC.Classes.Eq Agda.Mimer.Mimer.Component
- Agda.Mimer.Mimer: instance GHC.Classes.Eq Agda.Mimer.Mimer.Goal
- Agda.Mimer.Mimer: instance GHC.Classes.Eq Agda.Mimer.Mimer.MimerStats
- Agda.Mimer.Mimer: instance GHC.Classes.Eq Agda.Mimer.Mimer.SearchBranch
- Agda.Mimer.Mimer: instance GHC.Classes.Ord Agda.Mimer.Mimer.Component
- Agda.Mimer.Mimer: instance GHC.Classes.Ord Agda.Mimer.Mimer.SearchBranch
- Agda.Mimer.Mimer: instance GHC.Generics.Generic Agda.Mimer.Mimer.BaseComponents
- Agda.Mimer.Mimer: instance GHC.Generics.Generic Agda.Mimer.Mimer.Component
- Agda.Mimer.Mimer: instance GHC.Generics.Generic Agda.Mimer.Mimer.Goal
- Agda.Mimer.Mimer: instance GHC.Generics.Generic Agda.Mimer.Mimer.MimerResult
- Agda.Mimer.Mimer: instance GHC.Generics.Generic Agda.Mimer.Mimer.MimerStats
- Agda.Mimer.Mimer: instance GHC.Generics.Generic Agda.Mimer.Mimer.SearchBranch
- Agda.Mimer.Mimer: instance GHC.Generics.Generic Agda.Mimer.Mimer.SearchStepResult
- Agda.Mimer.Mimer: instance GHC.Show.Show Agda.Mimer.Mimer.MimerStats
- Agda.Syntax.Abstract: EtaPragma :: QName -> Pragma
- Agda.Syntax.Abstract: initCopyInfo :: ScopeCopyInfo
- Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.NameToExpr Agda.Syntax.Scope.Base.AbstractName
- Agda.Syntax.Abstract: type PatternSynDefn = ([WithHiding Name], Pattern' Void)
- Agda.Syntax.Abstract.Name: [nameBindingSite] :: Name -> Range
- Agda.Syntax.Abstract.Name: [nameId] :: Name -> !NameId
- Agda.Syntax.Abstract.Views: instance (Agda.Syntax.Abstract.Views.ExprLike qn, Agda.Syntax.Abstract.Views.ExprLike nm, Agda.Syntax.Abstract.Views.ExprLike p, Agda.Syntax.Abstract.Views.ExprLike e) => Agda.Syntax.Abstract.Views.ExprLike (Agda.Syntax.Common.RewriteEqn' qn nm p e)
- Agda.Syntax.Common: instance (Agda.Syntax.Position.HasRange a, Agda.Syntax.Position.HasRange b) => Agda.Syntax.Position.HasRange (Agda.Syntax.Common.ImportDirective' a b)
- Agda.Syntax.Common: instance (Agda.Syntax.Position.HasRange n, Agda.Syntax.Position.HasRange m) => GHC.Base.Monoid (Agda.Syntax.Common.ImportDirective' n m)
- Agda.Syntax.Common: instance (Agda.Syntax.Position.HasRange n, Agda.Syntax.Position.HasRange m) => GHC.Base.Semigroup (Agda.Syntax.Common.ImportDirective' n m)
- Agda.Syntax.Common: instance (Agda.Syntax.Position.HasRange qn, Agda.Syntax.Position.HasRange nm, Agda.Syntax.Position.HasRange p, Agda.Syntax.Position.HasRange e) => Agda.Syntax.Position.HasRange (Agda.Syntax.Common.RewriteEqn' qn nm p e)
- Agda.Syntax.Common.Aspect: IncompletePattern :: OtherAspect
- Agda.Syntax.Common.Pretty: (<>) :: Semigroup a => a -> a -> a
- Agda.Syntax.Common.Pretty: infixr 6 <>
- Agda.Syntax.Common.Pretty: instance Agda.Syntax.Common.Pretty.Pretty Agda.Syntax.Position.IntervalWithoutFile
- Agda.Syntax.Common.Pretty: instance Agda.Syntax.Common.Pretty.Pretty a => Agda.Syntax.Common.Pretty.Pretty (Agda.Syntax.Position.Interval' (Data.Strict.Maybe.Maybe a))
- Agda.Syntax.Common.Pretty: instance Agda.Syntax.Common.Pretty.Pretty a => Agda.Syntax.Common.Pretty.Pretty (Agda.Syntax.Position.Range' (Data.Strict.Maybe.Maybe a))
- Agda.Syntax.Common.Pretty: space :: Doc
- Agda.Syntax.Common.Pretty.ANSI: putDoc :: (MonadIO m, HasOptions m) => Doc -> m ()
- Agda.Syntax.Common.Pretty.ANSI: renderAnsiIO :: Doc -> IO ()
- Agda.Syntax.Concrete: dropTypeAndModality :: LamBinding -> [LamBinding]
- Agda.Syntax.Concrete: lamBindingsToTelescope :: Range -> [LamBinding] -> Telescope
- Agda.Syntax.Concrete.Definitions: SafeFlagEta :: Range -> DeclarationWarning'
- Agda.Syntax.Concrete.Definitions.Errors: SafeFlagEta :: Range -> DeclarationWarning'
- Agda.Syntax.Concrete.Definitions.Monad: getUniverseCheckFromSig :: Name -> Nice UniverseCheck
- Agda.Syntax.Concrete.Definitions.Types: InstanceBlock :: KindOfBlock
- Agda.Syntax.Concrete.Definitions.Types: interleavedDecl :: Name -> InterleavedDecl -> [(DeclNum, NiceDeclaration)]
- Agda.Syntax.Concrete.Name: isOpenMixfix :: Name -> Bool
- Agda.Syntax.Concrete.Operators.Parser.Monad: type PrecedenceKey = Either PrecedenceLevel PrecedenceLevel
- Agda.Syntax.Concrete.Pretty: instance Agda.Syntax.Common.Pretty.Pretty Agda.Syntax.Common.Fixity'
- Agda.Syntax.Concrete.Pretty: instance Agda.Syntax.Common.Pretty.Pretty Agda.Syntax.Common.NotationPart
- Agda.Syntax.Info: instance Agda.Syntax.Position.KillRange t => Agda.Syntax.Position.KillRange (Agda.Syntax.Info.DefInfo' t)
- Agda.Syntax.Internal: Dom :: ArgInfo -> Maybe NamedName -> Bool -> Maybe t -> e -> Dom' t e
- Agda.Syntax.Internal: IsData :: DataOrRecord' p
- Agda.Syntax.Internal: IsRecord :: p -> DataOrRecord' p
- Agda.Syntax.Internal: PiSort :: Dom' t t -> Sort' t -> Abs (Sort' t) -> Sort' t
- Agda.Syntax.Internal: Var :: {-# UNPACK #-} !Int -> Elims -> Term
- Agda.Syntax.Internal: [domInfo] :: Dom' t e -> ArgInfo
- Agda.Syntax.Internal: [domIsFinite] :: Dom' t e -> Bool
- Agda.Syntax.Internal: [domName] :: Dom' t e -> Maybe NamedName
- Agda.Syntax.Internal: [domTactic] :: Dom' t e -> Maybe t
- Agda.Syntax.Internal: data DataOrRecord' p
- Agda.Syntax.Internal: instance Agda.Syntax.Common.CopatternMatchingAllowed Agda.Syntax.Internal.DataOrRecord
- Agda.Syntax.Internal: instance Agda.Syntax.Common.PatternMatchingAllowed Agda.Syntax.Internal.DataOrRecord
- Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange Agda.Syntax.Internal.DataOrRecord
- Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange Agda.Syntax.Internal.Level
- Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange Agda.Syntax.Internal.PlusLevel
- Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange Agda.Syntax.Internal.Sort
- Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange a => Agda.Syntax.Position.KillRange (Agda.Syntax.Internal.Type' a)
- Agda.Syntax.Internal: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Syntax.Internal.DataOrRecord' a)
- Agda.Syntax.Internal: instance GHC.Classes.Eq p => GHC.Classes.Eq (Agda.Syntax.Internal.DataOrRecord' p)
- Agda.Syntax.Internal: instance GHC.Generics.Generic (Agda.Syntax.Internal.DataOrRecord' p)
- Agda.Syntax.Internal: instance GHC.Show.Show p => GHC.Show.Show (Agda.Syntax.Internal.DataOrRecord' p)
- Agda.Syntax.Internal: pattern IsRecord_ :: DataOrRecord_
- Agda.Syntax.Internal: replaceEmptyName :: ArgName -> Tele a -> Tele a
- Agda.Syntax.Internal: type DataOrRecord = DataOrRecord' PatternOrCopattern
- Agda.Syntax.Internal: type DataOrRecord_ = DataOrRecord' ()
- Agda.Syntax.Internal: type DummyTermKind = String
- Agda.Syntax.Internal.Blockers: instance (GHC.Base.Semigroup a, GHC.Base.Monoid a) => GHC.Base.Monoid (Agda.Syntax.Internal.Blockers.Blocked' t a)
- Agda.Syntax.Internal.Defs: ($dmgetDefs) :: forall m (f :: Type -> Type) b. (GetDefs a, MonadGetDefs m, Foldable f, GetDefs b, f b ~ a) => a -> m ()
- Agda.Syntax.Internal.Defs: GetDefsEnv :: (MetaId -> Maybe Term) -> (QName -> b) -> GetDefsEnv b
- Agda.Syntax.Internal.Defs: [embDef] :: GetDefsEnv b -> QName -> b
- Agda.Syntax.Internal.Defs: [lookupMeta] :: GetDefsEnv b -> MetaId -> Maybe Term
- Agda.Syntax.Internal.Defs: class Monad m => MonadGetDefs (m :: Type -> Type)
- Agda.Syntax.Internal.Defs: data GetDefsEnv b
- Agda.Syntax.Internal.Defs: doDef :: MonadGetDefs m => QName -> m ()
- Agda.Syntax.Internal.Defs: doMeta :: MonadGetDefs m => MetaId -> m ()
- Agda.Syntax.Internal.Defs: getDefs' :: (GetDefs a, Monoid b) => (MetaId -> Maybe Term) -> (QName -> b) -> a -> b
- Agda.Syntax.Internal.Defs: instance GHC.Base.Monoid b => Agda.Syntax.Internal.Defs.MonadGetDefs (Agda.Syntax.Internal.Defs.GetDefsM b)
- Agda.Syntax.Internal.Defs: type GetDefsM b = ReaderT GetDefsEnv b Writer b
- Agda.Syntax.Internal.Generic: instance Agda.Syntax.Internal.Generic.TermLike Agda.Syntax.Internal.Type
- Agda.Syntax.Internal.Generic: instance Agda.Syntax.Internal.Generic.TermLike a => Agda.Syntax.Internal.Generic.TermLike (Agda.Syntax.Internal.Dom a)
- 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 Agda.Syntax.Internal.Type
- Agda.Syntax.Internal.Names: PSyn :: PatternSynDefn -> PSyn
- 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 Agda.Syntax.Internal.Level
- Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.Syntax.Internal.Names.PSyn
- Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.Syntax.Internal.PlusLevel
- Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.Syntax.Internal.Sort
- 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.RewriteRule
- Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn a => Agda.Syntax.Internal.Names.NamesIn (Agda.Syntax.Internal.Type' a)
- Agda.Syntax.Internal.Names: newtype PSyn
- Agda.Syntax.Parser: [errSrcFile] :: ParseError -> !SrcFile
- Agda.Syntax.Parser.Helpers: takeOptionsPragmas :: [Declaration] -> Module
- Agda.Syntax.Parser.LexActions: identifier :: LexAction Token
- Agda.Syntax.Parser.Literate: literateExtsShortList :: List1 String
- Agda.Syntax.Parser.Monad: [errSrcFile] :: ParseError -> !SrcFile
- Agda.Syntax.Position: Pn :: !a -> !Word32 -> !Word32 -> !Word32 -> Position' a
- Agda.Syntax.Position: [posCol] :: Position' a -> !Word32
- Agda.Syntax.Position: [posLine] :: Position' a -> !Word32
- Agda.Syntax.Scope.Base: AbsModule :: ModuleName -> WhyInScope -> AbstractModule
- Agda.Syntax.Scope.Base: AbsName :: QName -> KindOfName -> WhyInScope -> NameMetadata -> AbstractName
- Agda.Syntax.Scope.Base: Applied :: QName -> WhyInScope -> WhyInScope
- Agda.Syntax.Scope.Base: AxiomName :: KindOfName
- Agda.Syntax.Scope.Base: CoConName :: KindOfName
- Agda.Syntax.Scope.Base: ConName :: KindOfName
- Agda.Syntax.Scope.Base: DataName :: KindOfName
- Agda.Syntax.Scope.Base: Defined :: WhyInScope
- Agda.Syntax.Scope.Base: DisallowedGeneralizeName :: KindOfName
- Agda.Syntax.Scope.Base: FldName :: KindOfName
- Agda.Syntax.Scope.Base: FunName :: KindOfName
- Agda.Syntax.Scope.Base: GeneralizeName :: KindOfName
- Agda.Syntax.Scope.Base: GeneralizedVarsMetadata :: Map QName Name -> NameMetadata
- Agda.Syntax.Scope.Base: MacroName :: KindOfName
- Agda.Syntax.Scope.Base: NoMetadata :: NameMetadata
- Agda.Syntax.Scope.Base: Opened :: QName -> WhyInScope -> WhyInScope
- Agda.Syntax.Scope.Base: OtherDefName :: KindOfName
- Agda.Syntax.Scope.Base: PatternSynName :: KindOfName
- Agda.Syntax.Scope.Base: PrimName :: KindOfName
- Agda.Syntax.Scope.Base: QuotableName :: KindOfName
- Agda.Syntax.Scope.Base: RecName :: KindOfName
- Agda.Syntax.Scope.Base: [_scopeRecords] :: ScopeInfo -> Map QName (QName, Maybe Induction)
- Agda.Syntax.Scope.Base: [amodLineage] :: AbstractModule -> WhyInScope
- Agda.Syntax.Scope.Base: [amodName] :: AbstractModule -> ModuleName
- Agda.Syntax.Scope.Base: [anameKind] :: AbstractName -> KindOfName
- Agda.Syntax.Scope.Base: [anameLineage] :: AbstractName -> WhyInScope
- Agda.Syntax.Scope.Base: [anameMetadata] :: AbstractName -> NameMetadata
- Agda.Syntax.Scope.Base: [anameName] :: AbstractName -> QName
- Agda.Syntax.Scope.Base: data AbstractModule
- Agda.Syntax.Scope.Base: data AbstractName
- Agda.Syntax.Scope.Base: data KindOfName
- Agda.Syntax.Scope.Base: data NameMetadata
- Agda.Syntax.Scope.Base: data WhyInScope
- Agda.Syntax.Scope.Base: everythingInScopeQualified :: ScopeInfo -> NameSpace
- Agda.Syntax.Scope.Base: instance Agda.Syntax.Common.LensFixity Agda.Syntax.Scope.Base.AbstractName
- Agda.Syntax.Scope.Base: instance Agda.Syntax.Common.Pretty.Pretty Agda.Syntax.Abstract.Name.Suffix
- Agda.Syntax.Scope.Base: instance Agda.Syntax.Common.Pretty.Pretty Agda.Syntax.Scope.Base.AbstractModule
- Agda.Syntax.Scope.Base: instance Agda.Syntax.Common.Pretty.Pretty Agda.Syntax.Scope.Base.AbstractName
- Agda.Syntax.Scope.Base: instance Agda.Syntax.Position.HasRange Agda.Syntax.Scope.Base.AbstractName
- Agda.Syntax.Scope.Base: instance Agda.Syntax.Position.SetRange Agda.Syntax.Scope.Base.AbstractName
- Agda.Syntax.Scope.Base: instance Agda.Syntax.Scope.Base.InScope Agda.Syntax.Scope.Base.AbstractModule
- Agda.Syntax.Scope.Base: instance Agda.Syntax.Scope.Base.InScope Agda.Syntax.Scope.Base.AbstractName
- Agda.Syntax.Scope.Base: instance Agda.Syntax.Scope.Base.SetBindingSite Agda.Syntax.Scope.Base.AbstractModule
- Agda.Syntax.Scope.Base: instance Agda.Syntax.Scope.Base.SetBindingSite Agda.Syntax.Scope.Base.AbstractName
- Agda.Syntax.Scope.Base: instance Control.DeepSeq.NFData Agda.Syntax.Scope.Base.AbstractModule
- Agda.Syntax.Scope.Base: instance Control.DeepSeq.NFData Agda.Syntax.Scope.Base.AbstractName
- Agda.Syntax.Scope.Base: instance Control.DeepSeq.NFData Agda.Syntax.Scope.Base.KindOfName
- Agda.Syntax.Scope.Base: instance Control.DeepSeq.NFData Agda.Syntax.Scope.Base.NameMetadata
- Agda.Syntax.Scope.Base: instance Control.DeepSeq.NFData Agda.Syntax.Scope.Base.WhyInScope
- Agda.Syntax.Scope.Base: instance GHC.Classes.Eq Agda.Syntax.Scope.Base.AbstractModule
- Agda.Syntax.Scope.Base: instance GHC.Classes.Eq Agda.Syntax.Scope.Base.AbstractName
- Agda.Syntax.Scope.Base: instance GHC.Classes.Eq Agda.Syntax.Scope.Base.KindOfName
- Agda.Syntax.Scope.Base: instance GHC.Classes.Ord Agda.Syntax.Scope.Base.AbstractModule
- Agda.Syntax.Scope.Base: instance GHC.Classes.Ord Agda.Syntax.Scope.Base.AbstractName
- Agda.Syntax.Scope.Base: instance GHC.Classes.Ord Agda.Syntax.Scope.Base.KindOfName
- Agda.Syntax.Scope.Base: instance GHC.Enum.Bounded Agda.Syntax.Scope.Base.KindOfName
- Agda.Syntax.Scope.Base: instance GHC.Enum.Enum Agda.Syntax.Scope.Base.KindOfName
- Agda.Syntax.Scope.Base: instance GHC.Generics.Generic Agda.Syntax.Scope.Base.AbstractModule
- Agda.Syntax.Scope.Base: instance GHC.Generics.Generic Agda.Syntax.Scope.Base.AbstractName
- Agda.Syntax.Scope.Base: instance GHC.Generics.Generic Agda.Syntax.Scope.Base.KindOfName
- Agda.Syntax.Scope.Base: instance GHC.Generics.Generic Agda.Syntax.Scope.Base.NameMetadata
- Agda.Syntax.Scope.Base: instance GHC.Generics.Generic Agda.Syntax.Scope.Base.WhyInScope
- Agda.Syntax.Scope.Base: instance GHC.Show.Show Agda.Syntax.Scope.Base.AbstractModule
- Agda.Syntax.Scope.Base: instance GHC.Show.Show Agda.Syntax.Scope.Base.AbstractName
- Agda.Syntax.Scope.Base: instance GHC.Show.Show Agda.Syntax.Scope.Base.KindOfName
- Agda.Syntax.Scope.Base: instance GHC.Show.Show Agda.Syntax.Scope.Base.NameMetadata
- Agda.Syntax.Scope.Base: instance GHC.Show.Show Agda.Syntax.Scope.Base.WhyInScope
- Agda.Syntax.Scope.Base: lensAmodName :: Lens' AbstractModule ModuleName
- Agda.Syntax.Scope.Base: lensAnameName :: Lens' AbstractName QName
- Agda.Syntax.Scope.Base: recomputeInverseScopeMaps :: ScopeInfo -> ScopeInfo
- Agda.Syntax.Scope.Base: scopeRecords :: Lens' ScopeInfo (Map QName (QName, Maybe Induction))
- Agda.Syntax.Scope.Flat: data FlatScope
- Agda.Syntax.Scope.Flat: flattenScope :: [[Name]] -> ScopeInfo -> FlatScope
- Agda.Syntax.Scope.Flat: getDefinedNames :: KindsOfNames -> FlatScope -> [List1 NewNotation]
- Agda.Syntax.Scope.Flat: instance Agda.Syntax.Common.Pretty.Pretty Agda.Syntax.Scope.Flat.FlatScope
- Agda.Syntax.Scope.Flat: localNames :: ExprKind -> Maybe QName -> FlatScope -> ScopeM ([QName], [NewNotation])
- Agda.Syntax.Scope.Monad: getCurrentModule :: ReadTCState m => m ModuleName
- Agda.Syntax.Scope.Monad: getRecordConstructor :: ReadTCState m => QName -> m (Maybe (QName, Maybe Induction))
- Agda.Syntax.Scope.Monad: instance Agda.Syntax.Concrete.Fixity.MonadFixityError Agda.Syntax.Scope.Monad.ScopeM
- Agda.Syntax.Scope.Monad: modifyCurrentNameSpace :: NameSpaceId -> (NameSpace -> NameSpace) -> ScopeM ()
- Agda.Syntax.Scope.Monad: modifyCurrentScopeM :: (Scope -> ScopeM (a, Scope)) -> ScopeM a
- Agda.Syntax.Scope.Monad: modifyNamedScopeM :: ModuleName -> (Scope -> ScopeM (a, Scope)) -> ScopeM a
- Agda.Syntax.Scope.Monad: setCurrentModule :: MonadTCState m => ModuleName -> m ()
- Agda.Syntax.Scope.Monad: setNamedScope :: ModuleName -> Scope -> ScopeM ()
- Agda.Syntax.Scope.Monad: setRecordConstructor :: QName -> (QName, Maybe Induction) -> ScopeM ()
- Agda.Syntax.Scope.Monad: type ScopeM = TCM
- Agda.Syntax.Scope.Monad: verifyImportDirective :: [ImportedName] -> HidingDirective -> RenamingDirective -> ScopeM ()
- Agda.Syntax.Scope.Monad: withCurrentModule :: (ReadTCState m, MonadTCState m) => ModuleName -> m a -> m a
- Agda.Syntax.Scope.Monad: withCurrentModule' :: (MonadTrans t, Monad (t ScopeM)) => ModuleName -> t ScopeM a -> t ScopeM a
- Agda.Syntax.Translation.AbstractToConcrete: instance (Agda.TypeChecking.Monad.Builtin.HasBuiltins m, Agda.TypeChecking.Monad.Signature.HasConstInfo m, Agda.TypeChecking.Monad.Context.MonadAddContext m, Agda.TypeChecking.Monad.Base.MonadReduce m) => Agda.TypeChecking.Monad.Pure.PureTCM (Agda.Syntax.Translation.AbstractToConcrete.AbsToConT m)
- Agda.Syntax.Translation.AbstractToConcrete: instance (GHC.Base.Monad m, GHC.Base.Semigroup (m Agda.Syntax.Common.Pretty.Doc)) => GHC.Base.Semigroup (Agda.Syntax.Translation.AbstractToConcrete.AbsToConT m Agda.Syntax.Common.Pretty.Doc)
- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Scope.Base.AbstractName
- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.AddGeneralizable Agda.Syntax.Scope.Base.AbstractName
- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.LivesInCurrentModule Agda.Syntax.Scope.Base.AbstractName
- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.Declarations
- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.LetDef
- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToQName a => Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (Agda.Syntax.Translation.ConcreteToAbstract.OldName a)
- Agda.Syntax.Translation.ConcreteToAbstract: instance GHC.Show.Show Agda.Syntax.Translation.ConcreteToAbstract.TerminationOrPositivity
- Agda.Syntax.Translation.InternalToAbstract: instance (Agda.TypeChecking.Free.Lazy.Free i, Agda.Syntax.Translation.InternalToAbstract.Reify i) => Agda.Syntax.Translation.InternalToAbstract.Reify (Agda.Syntax.Internal.Abs i)
- Agda.Termination.Monad: [terUseDotPatterns] :: TerEnv -> Bool
- Agda.Termination.Monad: instance (GHC.Base.Semigroup m, GHC.Base.Monoid m) => GHC.Base.Monoid (Agda.Termination.Monad.TerM m)
- Agda.Termination.Monad: newtype CallPath
- Agda.Termination.Monad: terGetUseDotPatterns :: TerM Bool
- Agda.Termination.Monad: terSetUseDotPatterns :: Bool -> TerM a -> TerM a
- Agda.Termination.TermCheck: instance Agda.Termination.TermCheck.StripAllProjections Agda.Syntax.Internal.Args
- Agda.Termination.TermCheck: instance Agda.Termination.TermCheck.StripAllProjections Agda.Syntax.Internal.Elims
- Agda.Termination.TermCheck: instance Agda.Termination.TermCheck.StripAllProjections Agda.Syntax.Internal.Term
- Agda.Termination.TermCheck: instance Agda.Termination.TermCheck.StripAllProjections a => Agda.Termination.TermCheck.StripAllProjections (Agda.Syntax.Common.Arg a)
- Agda.Termination.TermCheck: instance Agda.Termination.TermCheck.TermToPattern a b => Agda.Termination.TermCheck.TermToPattern (Agda.Syntax.Common.Arg a) (Agda.Syntax.Common.Arg b)
- Agda.Termination.TermCheck: instance Agda.Termination.TermCheck.TermToPattern a b => Agda.Termination.TermCheck.TermToPattern (Agda.Syntax.Common.Named c a) (Agda.Syntax.Common.Named c b)
- Agda.Termination.TermCheck: instance Agda.Termination.TermCheck.TermToPattern a b => Agda.Termination.TermCheck.TermToPattern [a] [b]
- Agda.Termination.Termination: endos :: [Call cinfo] -> [CallMatrixAug cinfo]
- Agda.Termination.Termination: idempotent :: (?cutoff :: CutOff) => CallMatrixAug cinfo -> Bool
- Agda.TypeChecking.CheckInternal: type MonadCheckInternal (m :: Type -> Type) = MonadConversion m
- Agda.TypeChecking.CompiledClause: Done :: [Arg ArgName] -> a -> CompiledClauses' a
- Agda.TypeChecking.CompiledClause: instance (GHC.Base.Semigroup c, GHC.Base.Monoid c) => GHC.Base.Monoid (Agda.TypeChecking.CompiledClause.WithArity c)
- Agda.TypeChecking.CompiledClause: instance (GHC.Base.Semigroup m, GHC.Base.Monoid m) => GHC.Base.Monoid (Agda.TypeChecking.CompiledClause.Case m)
- Agda.TypeChecking.CompiledClause: instance Agda.Syntax.Common.Pretty.Pretty Agda.TypeChecking.CompiledClause.CompiledClauses
- Agda.TypeChecking.Conversion: type MonadConversion (m :: Type -> Type) = (PureTCM m, MonadConstraint m, MonadMetaSolver m, MonadError TCErr m, MonadWarning m, MonadStatistics m, MonadFresh ProblemId m, MonadFresh Int m)
- Agda.TypeChecking.Conversion.Pure: FreshThings :: Int -> ProblemId -> NameId -> FreshThings
- Agda.TypeChecking.Conversion.Pure: PureConversionT :: ExceptT TCErr (StateT FreshThings m) a -> PureConversionT (m :: Type -> Type) a
- Agda.TypeChecking.Conversion.Pure: [freshInt] :: FreshThings -> Int
- Agda.TypeChecking.Conversion.Pure: [freshNameId] :: FreshThings -> NameId
- Agda.TypeChecking.Conversion.Pure: [freshProblemId] :: FreshThings -> ProblemId
- Agda.TypeChecking.Conversion.Pure: [unPureConversionT] :: PureConversionT (m :: Type -> Type) a -> ExceptT TCErr (StateT FreshThings m) a
- Agda.TypeChecking.Conversion.Pure: data FreshThings
- Agda.TypeChecking.Conversion.Pure: instance (Agda.TypeChecking.Monad.Builtin.HasBuiltins m, Agda.TypeChecking.Monad.Signature.HasConstInfo m, Agda.TypeChecking.Monad.Context.MonadAddContext m, Agda.TypeChecking.Monad.Base.MonadReduce m) => Agda.TypeChecking.Monad.Pure.PureTCM (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance (Data.String.IsString a, GHC.Base.Monad m) => Data.String.IsString (Agda.TypeChecking.Conversion.Pure.PureConversionT m a)
- Agda.TypeChecking.Conversion.Pure: instance (GHC.Base.Monad m, GHC.Base.Semigroup a) => GHC.Base.Semigroup (Agda.TypeChecking.Conversion.Pure.PureConversionT m a)
- Agda.TypeChecking.Conversion.Pure: instance Agda.Interaction.Options.HasOptions.HasOptions m => Agda.Interaction.Options.HasOptions.HasOptions (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance Agda.TypeChecking.Monad.Base.MonadReduce m => Agda.TypeChecking.Monad.Base.MonadReduce (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance Agda.TypeChecking.Monad.Base.MonadTCEnv m => Agda.TypeChecking.Monad.Base.MonadTCEnv (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance Agda.TypeChecking.Monad.Base.ReadTCState m => Agda.TypeChecking.Monad.Base.MonadStConcreteNames (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance Agda.TypeChecking.Monad.Base.ReadTCState m => Agda.TypeChecking.Monad.Base.ReadTCState (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance Agda.TypeChecking.Monad.Base.ReadTCState m => Agda.TypeChecking.Monad.Statistics.MonadStatistics (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance Agda.TypeChecking.Monad.Builtin.HasBuiltins m => Agda.TypeChecking.Monad.Builtin.HasBuiltins (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance Agda.TypeChecking.Monad.Context.MonadAddContext m => Agda.TypeChecking.Monad.Context.MonadAddContext (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance Agda.TypeChecking.Monad.Debug.MonadDebug m => Agda.TypeChecking.Monad.Debug.MonadDebug (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance Agda.TypeChecking.Monad.Pure.PureTCM m => Agda.TypeChecking.Monad.Constraints.MonadConstraint (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance Agda.TypeChecking.Monad.Pure.PureTCM m => Agda.TypeChecking.Monad.MetaVars.MonadInteractionPoints (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance Agda.TypeChecking.Monad.Pure.PureTCM m => Agda.TypeChecking.Monad.MetaVars.MonadMetaSolver (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance Agda.TypeChecking.Monad.Pure.PureTCM m => Agda.TypeChecking.Warnings.MonadWarning (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance Agda.TypeChecking.Monad.Signature.HasConstInfo m => Agda.TypeChecking.Monad.Signature.HasConstInfo (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance Control.Monad.Fail.MonadFail m => Control.Monad.Fail.MonadFail (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance Control.Monad.Trans.Class.MonadTrans Agda.TypeChecking.Conversion.Pure.PureConversionT
- Agda.TypeChecking.Conversion.Pure: instance GHC.Base.Functor m => GHC.Base.Functor (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance GHC.Base.Monad m => Agda.TypeChecking.Monad.Base.MonadBlock (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance GHC.Base.Monad m => Agda.TypeChecking.Monad.Base.MonadFresh Agda.Syntax.Common.NameId (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance GHC.Base.Monad m => Agda.TypeChecking.Monad.Base.MonadFresh Agda.Syntax.Common.ProblemId (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance GHC.Base.Monad m => Agda.TypeChecking.Monad.Base.MonadFresh GHC.Types.Int (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance GHC.Base.Monad m => Agda.Utils.Null.Null (Agda.TypeChecking.Conversion.Pure.PureConversionT m Agda.TypeChecking.Pretty.Doc)
- Agda.TypeChecking.Conversion.Pure: instance GHC.Base.Monad m => Control.Monad.Error.Class.MonadError Agda.TypeChecking.Monad.Base.TCErr (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance GHC.Base.Monad m => Control.Monad.State.Class.MonadState Agda.TypeChecking.Conversion.Pure.FreshThings (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance GHC.Base.Monad m => GHC.Base.Applicative (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: instance GHC.Base.Monad m => GHC.Base.Monad (Agda.TypeChecking.Conversion.Pure.PureConversionT m)
- Agda.TypeChecking.Conversion.Pure: newtype PureConversionT (m :: Type -> Type) a
- Agda.TypeChecking.Conversion.Pure: pureEqualTermB :: PureTCM m => Type -> Term -> Term -> m (Either Blocker Bool)
- Agda.TypeChecking.Conversion.Pure: pureEqualType :: (PureTCM m, MonadBlock m) => Type -> Type -> m Bool
- Agda.TypeChecking.Conversion.Pure: pureEqualTypeB :: PureTCM m => Type -> Type -> m (Either Blocker Bool)
- Agda.TypeChecking.Conversion.Pure: runPureConversionB :: PureTCM m => PureConversionT m a -> m (Either Blocker (Maybe a))
- Agda.TypeChecking.Coverage.Match: SplitPatVar :: PatVarName -> Int -> [Literal] -> SplitPatVar
- Agda.TypeChecking.Coverage.Match: [splitExcludedLits] :: SplitPatVar -> [Literal]
- Agda.TypeChecking.Coverage.Match: [splitPatVarIndex] :: SplitPatVar -> Int
- Agda.TypeChecking.Coverage.Match: [splitPatVarName] :: SplitPatVar -> PatVarName
- Agda.TypeChecking.Coverage.Match: applySplitPSubst :: TermSubst a => SplitPSubstitution -> a -> a
- Agda.TypeChecking.Coverage.Match: data SplitPatVar
- Agda.TypeChecking.Coverage.Match: fromSplitPattern :: NamedArg SplitPattern -> NamedArg DeBruijnPattern
- Agda.TypeChecking.Coverage.Match: fromSplitPatterns :: [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
- Agda.TypeChecking.Coverage.Match: instance Agda.Syntax.Common.Pretty.Pretty Agda.TypeChecking.Coverage.Match.SplitPatVar
- Agda.TypeChecking.Coverage.Match: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Coverage.Match.SplitPatVar
- Agda.TypeChecking.Coverage.Match: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Coverage.Match.SplitPattern
- Agda.TypeChecking.Coverage.Match: instance Agda.TypeChecking.Substitute.DeBruijn.DeBruijn Agda.TypeChecking.Coverage.Match.SplitPatVar
- Agda.TypeChecking.Coverage.Match: instance GHC.Show.Show Agda.TypeChecking.Coverage.Match.SplitPatVar
- Agda.TypeChecking.Coverage.Match: isTrivialPattern :: HasConstInfo m => Pattern' a -> m Bool
- Agda.TypeChecking.Coverage.Match: toSplitPSubst :: PatternSubstitution -> SplitPSubstitution
- Agda.TypeChecking.Coverage.Match: toSplitPatterns :: [NamedArg DeBruijnPattern] -> [NamedArg SplitPattern]
- Agda.TypeChecking.Coverage.Match: type SplitPattern = Pattern' SplitPatVar
- Agda.TypeChecking.Errors: instance Agda.TypeChecking.Errors.PrettyUnequal Agda.Syntax.Internal.Term
- Agda.TypeChecking.Errors: instance Agda.TypeChecking.Errors.PrettyUnequal Agda.Syntax.Internal.Type
- Agda.TypeChecking.Free: allFreeVars :: Free t => t -> VarSet
- Agda.TypeChecking.Free: allRelevantVars :: Free t => t -> VarSet
- Agda.TypeChecking.Free: allRelevantVarsIgnoring :: Free t => IgnoreSorts -> t -> VarSet
- Agda.TypeChecking.Free: class (Singleton MetaId a, Semigroup a, Monoid a, Semigroup c, Monoid c) => IsVarSet a c | c -> a
- Agda.TypeChecking.Free: data MetaSet
- Agda.TypeChecking.Free: flexRigOccurrenceIn :: Free a => Nat -> a -> Maybe FlexRig
- Agda.TypeChecking.Free: freeVars' :: (Free t, IsVarSet a c) => t -> FreeM a c
- Agda.TypeChecking.Free: freeVarsIgnore :: (IsVarSet a c, Singleton Variable c, Free t) => IgnoreSorts -> t -> c
- Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Lazy.IsVarSet () Agda.TypeChecking.Free.VarCounts
- Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Lazy.IsVarSet () Agda.TypeChecking.Free.VarSet
- Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Lazy.IsVarSet () Data.Semigroup.Internal.All
- Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Lazy.IsVarSet () Data.Semigroup.Internal.Any
- Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Lazy.IsVarSet () [GHC.Types.Int]
- Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Lazy.IsVarSet Agda.TypeChecking.Free.Lazy.MetaSet Agda.TypeChecking.Free.SingleFlexRig
- Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Lazy.IsVarSet Agda.TypeChecking.Free.Lazy.MetaSet Agda.TypeChecking.Free.SingleVarOcc
- Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Lazy.IsVarSet a c => Agda.TypeChecking.Free.Lazy.IsVarSet a (Agda.TypeChecking.Free.RelevantIn c)
- Agda.TypeChecking.Free: instance Agda.Utils.Singleton.Singleton Agda.TypeChecking.Free.Lazy.Variable Agda.TypeChecking.Free.VarCounts
- Agda.TypeChecking.Free: instance GHC.Base.Monoid Agda.TypeChecking.Free.SingleFlexRig
- Agda.TypeChecking.Free: instance GHC.Base.Monoid Agda.TypeChecking.Free.SingleVarOcc
- Agda.TypeChecking.Free: instance GHC.Base.Monoid Agda.TypeChecking.Free.VarCounts
- Agda.TypeChecking.Free: instance GHC.Base.Monoid c => GHC.Base.Monoid (Agda.TypeChecking.Free.RelevantIn c)
- Agda.TypeChecking.Free: instance GHC.Base.Semigroup Agda.TypeChecking.Free.SingleFlexRig
- Agda.TypeChecking.Free: instance GHC.Base.Semigroup Agda.TypeChecking.Free.SingleVarOcc
- Agda.TypeChecking.Free: instance GHC.Base.Semigroup Agda.TypeChecking.Free.VarCounts
- Agda.TypeChecking.Free: instance GHC.Base.Semigroup c => GHC.Base.Semigroup (Agda.TypeChecking.Free.RelevantIn c)
- Agda.TypeChecking.Free: relevantIn :: Free t => Nat -> t -> Bool
- Agda.TypeChecking.Free: runFree :: (IsVarSet a c, Free t) => SingleVar c -> IgnoreSorts -> t -> c
- Agda.TypeChecking.Free: withVarOcc :: IsVarSet a c => VarOcc' a -> c -> c
- Agda.TypeChecking.Free.Lazy: ($dmfreeVars') :: forall (f :: Type -> Type) b a c. (Free t, t ~ f b, Foldable f, Free b, IsVarSet a c) => t -> FreeM a c
- Agda.TypeChecking.Free.Lazy: FlexRigMap :: TheFlexRigMap -> FlexRigMap
- Agda.TypeChecking.Free.Lazy: Flexible :: a -> FlexRig' a
- Agda.TypeChecking.Free.Lazy: FreeEnv :: !b -> !FlexRig' a -> !Modality -> (Maybe Variable -> c) -> FreeEnv' a b c
- Agda.TypeChecking.Free.Lazy: IgnoreAll :: IgnoreSorts
- Agda.TypeChecking.Free.Lazy: IgnoreInAnnotations :: IgnoreSorts
- Agda.TypeChecking.Free.Lazy: IgnoreNot :: IgnoreSorts
- Agda.TypeChecking.Free.Lazy: MetaSet :: HashSet MetaId -> MetaSet
- Agda.TypeChecking.Free.Lazy: StronglyRigid :: FlexRig' a
- Agda.TypeChecking.Free.Lazy: Unguarded :: FlexRig' a
- Agda.TypeChecking.Free.Lazy: VarMap :: TheVarMap' a -> VarMap' a
- Agda.TypeChecking.Free.Lazy: VarOcc :: FlexRig' a -> Modality -> VarOcc' a
- Agda.TypeChecking.Free.Lazy: WeaklyRigid :: FlexRig' a
- Agda.TypeChecking.Free.Lazy: [feExtra] :: FreeEnv' a b c -> !b
- Agda.TypeChecking.Free.Lazy: [feFlexRig] :: FreeEnv' a b c -> !FlexRig' a
- Agda.TypeChecking.Free.Lazy: [feModality] :: FreeEnv' a b c -> !Modality
- Agda.TypeChecking.Free.Lazy: [feSingleton] :: FreeEnv' a b c -> Maybe Variable -> c
- Agda.TypeChecking.Free.Lazy: [theFlexRigMap] :: FlexRigMap -> TheFlexRigMap
- Agda.TypeChecking.Free.Lazy: [theMetaSet] :: MetaSet -> HashSet MetaId
- Agda.TypeChecking.Free.Lazy: [theVarMap] :: VarMap' a -> TheVarMap' a
- Agda.TypeChecking.Free.Lazy: [varFlexRig] :: VarOcc' a -> FlexRig' a
- Agda.TypeChecking.Free.Lazy: [varModality] :: VarOcc' a -> Modality
- Agda.TypeChecking.Free.Lazy: addFlexRig :: Semigroup a => FlexRig' a -> FlexRig' a -> FlexRig' a
- Agda.TypeChecking.Free.Lazy: class Free t
- Agda.TypeChecking.Free.Lazy: class (Singleton MetaId a, Semigroup a, Monoid a, Semigroup c, Monoid c) => IsVarSet a c | c -> a
- Agda.TypeChecking.Free.Lazy: class LensFlexRig o a | o -> a
- Agda.TypeChecking.Free.Lazy: composeFlexRig :: Semigroup a => FlexRig' a -> FlexRig' a -> FlexRig' a
- Agda.TypeChecking.Free.Lazy: composeVarOcc :: Semigroup a => VarOcc' a -> VarOcc' a -> VarOcc' a
- Agda.TypeChecking.Free.Lazy: data FlexRig' a
- Agda.TypeChecking.Free.Lazy: data FreeEnv' a b c
- Agda.TypeChecking.Free.Lazy: data IgnoreSorts
- Agda.TypeChecking.Free.Lazy: data VarOcc' a
- Agda.TypeChecking.Free.Lazy: feIgnoreSorts :: FreeEnv' a IgnoreSorts c -> IgnoreSorts
- Agda.TypeChecking.Free.Lazy: foldrMetaSet :: (MetaId -> a -> a) -> a -> MetaSet -> a
- Agda.TypeChecking.Free.Lazy: freeVars' :: (Free t, IsVarSet a c) => t -> FreeM a c
- Agda.TypeChecking.Free.Lazy: initFreeEnv :: Monoid c => b -> SingleVar c -> FreeEnv' a b c
- Agda.TypeChecking.Free.Lazy: insertMetaSet :: MetaId -> MetaSet -> MetaSet
- Agda.TypeChecking.Free.Lazy: instance (Agda.TypeChecking.Free.Lazy.Free t, Agda.TypeChecking.Free.Lazy.Free u) => Agda.TypeChecking.Free.Lazy.Free (t, u)
- Agda.TypeChecking.Free.Lazy: instance (Agda.TypeChecking.Free.Lazy.Free t, Agda.TypeChecking.Free.Lazy.Free u, Agda.TypeChecking.Free.Lazy.Free v) => Agda.TypeChecking.Free.Lazy.Free (t, u, v)
- Agda.TypeChecking.Free.Lazy: instance (Agda.Utils.Singleton.Singleton Agda.Syntax.Common.MetaId a, GHC.Base.Semigroup a, GHC.Base.Monoid a) => Agda.TypeChecking.Free.Lazy.IsVarSet a (Agda.TypeChecking.Free.Lazy.VarMap' a)
- Agda.TypeChecking.Free.Lazy: instance (GHC.Base.Functor m, GHC.Base.Applicative m, GHC.Base.Monad m, GHC.Base.Semigroup c, GHC.Base.Monoid c) => GHC.Base.Monoid (Agda.TypeChecking.Free.Lazy.FreeT a b m c)
- Agda.TypeChecking.Free.Lazy: instance (GHC.Base.Semigroup a, GHC.Base.Monoid a) => GHC.Base.Monoid (Agda.TypeChecking.Free.Lazy.VarOcc' a)
- Agda.TypeChecking.Free.Lazy: instance Agda.Syntax.Common.LensModality (Agda.TypeChecking.Free.Lazy.FreeEnv' a b c)
- Agda.TypeChecking.Free.Lazy: instance Agda.Syntax.Common.LensModality (Agda.TypeChecking.Free.Lazy.VarOcc' a)
- Agda.TypeChecking.Free.Lazy: instance Agda.Syntax.Common.LensQuantity (Agda.TypeChecking.Free.Lazy.FreeEnv' a b c)
- Agda.TypeChecking.Free.Lazy: instance Agda.Syntax.Common.LensQuantity (Agda.TypeChecking.Free.Lazy.VarOcc' a)
- Agda.TypeChecking.Free.Lazy: instance Agda.Syntax.Common.LensRelevance (Agda.TypeChecking.Free.Lazy.FreeEnv' a b c)
- Agda.TypeChecking.Free.Lazy: instance Agda.Syntax.Common.LensRelevance (Agda.TypeChecking.Free.Lazy.VarOcc' a)
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.Free Agda.Syntax.Internal.Clause
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.Free Agda.Syntax.Internal.EqualityView
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.Free Agda.Syntax.Internal.Level
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.Free Agda.Syntax.Internal.Sort
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.Free Agda.Syntax.Internal.Term
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.Free t => Agda.TypeChecking.Free.Lazy.Free (Agda.Syntax.Common.Arg t)
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.Free t => Agda.TypeChecking.Free.Lazy.Free (Agda.Syntax.Common.Named nm t)
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.Free t => Agda.TypeChecking.Free.Lazy.Free (Agda.Syntax.Common.Ranged t)
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.Free t => Agda.TypeChecking.Free.Lazy.Free (Agda.Syntax.Common.WithHiding t)
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.Free t => Agda.TypeChecking.Free.Lazy.Free (Agda.Syntax.Internal.Abs t)
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.Free t => Agda.TypeChecking.Free.Lazy.Free (Agda.Syntax.Internal.Dom t)
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.Free t => Agda.TypeChecking.Free.Lazy.Free (Agda.Syntax.Internal.Elim.Elim' t)
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.Free t => Agda.TypeChecking.Free.Lazy.Free (Agda.Syntax.Internal.PlusLevel' t)
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.Free t => Agda.TypeChecking.Free.Lazy.Free (Agda.Syntax.Internal.Tele t)
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.Free t => Agda.TypeChecking.Free.Lazy.Free (Agda.Syntax.Internal.Type' t)
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.Free t => Agda.TypeChecking.Free.Lazy.Free (Agda.Utils.List1.List1 t)
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.Free t => Agda.TypeChecking.Free.Lazy.Free (GHC.Maybe.Maybe t)
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.Free t => Agda.TypeChecking.Free.Lazy.Free [t]
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.IsVarSet () Agda.TypeChecking.Free.Lazy.FlexRigMap
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.LensFlexRig (Agda.TypeChecking.Free.Lazy.FlexRig' a) a
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.LensFlexRig (Agda.TypeChecking.Free.Lazy.FreeEnv' a b c) a
- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.LensFlexRig (Agda.TypeChecking.Free.Lazy.VarOcc' a) a
- Agda.TypeChecking.Free.Lazy: instance Agda.Utils.Null.Null Agda.TypeChecking.Free.Lazy.MetaSet
- Agda.TypeChecking.Free.Lazy: instance Agda.Utils.Singleton.Singleton (Agda.TypeChecking.Free.Lazy.Variable, Agda.TypeChecking.Free.Lazy.FlexRig' ()) Agda.TypeChecking.Free.Lazy.FlexRigMap
- Agda.TypeChecking.Free.Lazy: instance Agda.Utils.Singleton.Singleton Agda.Syntax.Common.MetaId ()
- Agda.TypeChecking.Free.Lazy: instance Agda.Utils.Singleton.Singleton Agda.Syntax.Common.MetaId Agda.TypeChecking.Free.Lazy.MetaSet
- Agda.TypeChecking.Free.Lazy: instance Agda.Utils.Singleton.Singleton Agda.TypeChecking.Free.Lazy.Variable (Agda.TypeChecking.Free.Lazy.VarMap' a)
- Agda.TypeChecking.Free.Lazy: instance Data.Foldable.Foldable Agda.TypeChecking.Free.Lazy.FlexRig'
- Agda.TypeChecking.Free.Lazy: instance GHC.Base.Functor Agda.TypeChecking.Free.Lazy.FlexRig'
- Agda.TypeChecking.Free.Lazy: instance GHC.Base.Monoid Agda.TypeChecking.Free.Lazy.FlexRigMap
- Agda.TypeChecking.Free.Lazy: instance GHC.Base.Monoid Agda.TypeChecking.Free.Lazy.MetaSet
- Agda.TypeChecking.Free.Lazy: instance GHC.Base.Semigroup Agda.TypeChecking.Free.Lazy.FlexRigMap
- Agda.TypeChecking.Free.Lazy: instance GHC.Base.Semigroup Agda.TypeChecking.Free.Lazy.MetaSet
- Agda.TypeChecking.Free.Lazy: instance GHC.Base.Semigroup a => GHC.Base.Monoid (Agda.TypeChecking.Free.Lazy.VarMap' a)
- Agda.TypeChecking.Free.Lazy: instance GHC.Base.Semigroup a => GHC.Base.Semigroup (Agda.TypeChecking.Free.Lazy.VarMap' a)
- Agda.TypeChecking.Free.Lazy: instance GHC.Base.Semigroup a => GHC.Base.Semigroup (Agda.TypeChecking.Free.Lazy.VarOcc' a)
- Agda.TypeChecking.Free.Lazy: instance GHC.Classes.Eq Agda.TypeChecking.Free.Lazy.IgnoreSorts
- Agda.TypeChecking.Free.Lazy: instance GHC.Classes.Eq Agda.TypeChecking.Free.Lazy.MetaSet
- Agda.TypeChecking.Free.Lazy: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.TypeChecking.Free.Lazy.FlexRig' a)
- Agda.TypeChecking.Free.Lazy: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.TypeChecking.Free.Lazy.VarMap' a)
- Agda.TypeChecking.Free.Lazy: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.TypeChecking.Free.Lazy.VarOcc' a)
- Agda.TypeChecking.Free.Lazy: instance GHC.Show.Show Agda.TypeChecking.Free.Lazy.FlexRigMap
- Agda.TypeChecking.Free.Lazy: instance GHC.Show.Show Agda.TypeChecking.Free.Lazy.IgnoreSorts
- Agda.TypeChecking.Free.Lazy: instance GHC.Show.Show Agda.TypeChecking.Free.Lazy.MetaSet
- Agda.TypeChecking.Free.Lazy: instance GHC.Show.Show a => GHC.Show.Show (Agda.TypeChecking.Free.Lazy.FlexRig' a)
- Agda.TypeChecking.Free.Lazy: instance GHC.Show.Show a => GHC.Show.Show (Agda.TypeChecking.Free.Lazy.VarMap' a)
- Agda.TypeChecking.Free.Lazy: instance GHC.Show.Show a => GHC.Show.Show (Agda.TypeChecking.Free.Lazy.VarOcc' a)
- Agda.TypeChecking.Free.Lazy: isFlexible :: LensFlexRig o a => o -> Bool
- Agda.TypeChecking.Free.Lazy: isStronglyRigid :: LensFlexRig o a => o -> Bool
- Agda.TypeChecking.Free.Lazy: isUnguarded :: LensFlexRig o a => o -> Bool
- Agda.TypeChecking.Free.Lazy: isWeaklyRigid :: LensFlexRig o a => o -> Bool
- Agda.TypeChecking.Free.Lazy: lensFlexRig :: LensFlexRig o a => Lens' o (FlexRig' a)
- Agda.TypeChecking.Free.Lazy: lookupVarMap :: Variable -> VarMap' a -> Maybe (VarOcc' a)
- Agda.TypeChecking.Free.Lazy: mapFlexRigMap :: (TheFlexRigMap -> TheFlexRigMap) -> FlexRigMap -> FlexRigMap
- Agda.TypeChecking.Free.Lazy: mapVarMap :: (TheVarMap' a -> TheVarMap' b) -> VarMap' a -> VarMap' b
- Agda.TypeChecking.Free.Lazy: metaSetToBlocker :: MetaSet -> Blocker
- Agda.TypeChecking.Free.Lazy: newtype FlexRigMap
- Agda.TypeChecking.Free.Lazy: newtype MetaSet
- Agda.TypeChecking.Free.Lazy: newtype VarMap' a
- Agda.TypeChecking.Free.Lazy: omegaFlexRig :: FlexRig' a
- Agda.TypeChecking.Free.Lazy: oneFlexRig :: FlexRig' a
- Agda.TypeChecking.Free.Lazy: oneVarOcc :: VarOcc' a
- Agda.TypeChecking.Free.Lazy: runFreeM :: IsVarSet a c => SingleVar c -> IgnoreSorts -> FreeM a c -> c
- Agda.TypeChecking.Free.Lazy: subVar :: Int -> Maybe Variable -> Maybe Variable
- Agda.TypeChecking.Free.Lazy: topVarOcc :: VarOcc' a
- Agda.TypeChecking.Free.Lazy: type FlexRig = FlexRig' MetaSet
- Agda.TypeChecking.Free.Lazy: type FreeEnv c = FreeEnv' MetaSet IgnoreSorts c
- Agda.TypeChecking.Free.Lazy: type FreeM a c = Reader FreeEnv' a IgnoreSorts c c
- Agda.TypeChecking.Free.Lazy: type FreeT a b (m :: Type -> Type) c = ReaderT FreeEnv' a b c m c
- Agda.TypeChecking.Free.Lazy: type SingleVar c = Variable -> c
- Agda.TypeChecking.Free.Lazy: type TheFlexRigMap = IntMap FlexRig' ()
- Agda.TypeChecking.Free.Lazy: type TheVarMap = TheVarMap' MetaSet
- Agda.TypeChecking.Free.Lazy: type TheVarMap' a = IntMap VarOcc' a
- Agda.TypeChecking.Free.Lazy: type VarMap = VarMap' MetaSet
- Agda.TypeChecking.Free.Lazy: type VarOcc = VarOcc' MetaSet
- Agda.TypeChecking.Free.Lazy: type Variable = Int
- Agda.TypeChecking.Free.Lazy: underBinder :: MonadReader (FreeEnv' a b c) m => m z -> m z
- Agda.TypeChecking.Free.Lazy: underBinder' :: MonadReader (FreeEnv' a b c) m => Nat -> m z -> m z
- Agda.TypeChecking.Free.Lazy: underConstructor :: (MonadReader r m, LensFlexRig r a, Semigroup a) => ConHead -> Elims -> m z -> m z
- Agda.TypeChecking.Free.Lazy: underFlexRig :: (MonadReader r m, LensFlexRig r a, Semigroup a, LensFlexRig o a) => o -> m z -> m z
- Agda.TypeChecking.Free.Lazy: underModality :: (MonadReader r m, LensModality r, LensModality o) => o -> m z -> m z
- Agda.TypeChecking.Free.Lazy: underQuantity :: (MonadReader r m, LensQuantity r, LensQuantity o) => o -> m a -> m a
- Agda.TypeChecking.Free.Lazy: underRelevance :: (MonadReader r m, LensRelevance r, LensRelevance o) => o -> m z -> m z
- Agda.TypeChecking.Free.Lazy: variable :: forall (m :: Type -> Type) a c b. (Monad m, IsVarSet a c) => Int -> FreeT a b m c
- Agda.TypeChecking.Free.Lazy: withVarOcc :: IsVarSet a c => VarOcc' a -> c -> c
- Agda.TypeChecking.Free.Lazy: zeroFlexRig :: Monoid a => FlexRig' a
- Agda.TypeChecking.Level: instance Agda.TypeChecking.Free.Lazy.Free t => Agda.TypeChecking.Free.Lazy.Free (Agda.TypeChecking.Level.SingleLevel' t)
- Agda.TypeChecking.MetaVars.Occurs: ($dmmetaOccurs) :: forall (f :: Type -> Type) a. (Occurs t, Foldable f, Occurs a, f a ~ t) => MetaId -> t -> TCM ()
- Agda.TypeChecking.MetaVars.Occurs: NoUnfold :: UnfoldStrategy
- Agda.TypeChecking.MetaVars.Occurs: OccursExtra :: UnfoldStrategy -> MetaId -> VarMap -> Term -> Nat -> OccursExtra
- Agda.TypeChecking.MetaVars.Occurs: YesUnfold :: UnfoldStrategy
- Agda.TypeChecking.MetaVars.Occurs: [occCxtSize] :: OccursExtra -> Nat
- Agda.TypeChecking.MetaVars.Occurs: [occMeta] :: OccursExtra -> MetaId
- Agda.TypeChecking.MetaVars.Occurs: [occRHS] :: OccursExtra -> Term
- Agda.TypeChecking.MetaVars.Occurs: [occUnfold] :: OccursExtra -> UnfoldStrategy
- Agda.TypeChecking.MetaVars.Occurs: [occVars] :: OccursExtra -> VarMap
- Agda.TypeChecking.MetaVars.Occurs: abort :: Blocker -> TypeError -> OccursM a
- Agda.TypeChecking.MetaVars.Occurs: allowedVars :: OccursM (Nat -> Bool)
- Agda.TypeChecking.MetaVars.Occurs: anyRigid :: (AnyRigid a, PureTCM tcm) => (Nat -> tcm Bool) -> a -> tcm Bool
- Agda.TypeChecking.MetaVars.Occurs: class AnyRigid a
- Agda.TypeChecking.MetaVars.Occurs: class Occurs t
- Agda.TypeChecking.MetaVars.Occurs: conArgs :: Elims -> OccursM a -> OccursM a
- Agda.TypeChecking.MetaVars.Occurs: data OccursExtra
- Agda.TypeChecking.MetaVars.Occurs: data UnfoldStrategy
- Agda.TypeChecking.MetaVars.Occurs: defArgs :: OccursM a -> OccursM a
- Agda.TypeChecking.MetaVars.Occurs: defNeedsChecking :: QName -> TCM Bool
- Agda.TypeChecking.MetaVars.Occurs: definitionCheck :: QName -> OccursM ()
- Agda.TypeChecking.MetaVars.Occurs: flexibly :: OccursM a -> OccursM a
- Agda.TypeChecking.MetaVars.Occurs: hasBadRigid :: forall (m :: Type -> Type). PureTCM m => (Nat -> Bool) -> Term -> ExceptT () m Bool
- Agda.TypeChecking.MetaVars.Occurs: initOccursCheck :: MetaVariable -> TCM ()
- Agda.TypeChecking.MetaVars.Occurs: instance Agda.TypeChecking.Free.Lazy.IsVarSet () Agda.TypeChecking.MetaVars.Occurs.AllowedVar
- Agda.TypeChecking.MetaVars.Occurs: instance Agda.TypeChecking.MetaVars.Occurs.Occurs (Agda.Syntax.Internal.Abs Agda.Syntax.Internal.Term)
- Agda.TypeChecking.MetaVars.Occurs: instance Agda.TypeChecking.MetaVars.Occurs.Occurs (Agda.Syntax.Internal.Abs Agda.Syntax.Internal.Type)
- Agda.TypeChecking.MetaVars.Occurs: isNeutral :: HasConstInfo m => Blocked t -> QName -> Elims -> m Bool
- Agda.TypeChecking.MetaVars.Occurs: killedType :: MonadReduce m => [(Dom (ArgName, Type), Bool)] -> Type -> m ([Arg Bool], Type)
- Agda.TypeChecking.MetaVars.Occurs: metaCheck :: MetaId -> OccursM MetaId
- Agda.TypeChecking.MetaVars.Occurs: metaOccurs :: Occurs t => MetaId -> t -> TCM ()
- Agda.TypeChecking.MetaVars.Occurs: metaOccurs2 :: (Occurs a, Occurs b) => MetaId -> a -> b -> TCM ()
- Agda.TypeChecking.MetaVars.Occurs: metaOccurs3 :: (Occurs a, Occurs b, Occurs c) => MetaId -> a -> b -> c -> TCM ()
- Agda.TypeChecking.MetaVars.Occurs: metaOccursQName :: MetaId -> QName -> TCM ()
- Agda.TypeChecking.MetaVars.Occurs: modifyOccursCheckDefs :: (Set QName -> Set QName) -> TCM ()
- Agda.TypeChecking.MetaVars.Occurs: occurs :: Occurs t => t -> OccursM t
- Agda.TypeChecking.MetaVars.Occurs: occurs_ :: (Occurs t, TypeOf t ~ ()) => t -> OccursM t
- Agda.TypeChecking.MetaVars.Occurs: patternViolation' :: MonadTCM m => Blocker -> Int -> String -> m a
- Agda.TypeChecking.MetaVars.Occurs: performKill :: MonadMetaSolver m => [Arg Bool] -> MetaId -> Type -> m ()
- Agda.TypeChecking.MetaVars.Occurs: reallyNotFreeIn :: MonadReduce m => VarSet -> Type -> m (VarSet, Type)
- Agda.TypeChecking.MetaVars.Occurs: strongly :: OccursM a -> OccursM a
- Agda.TypeChecking.MetaVars.Occurs: tallyDef :: QName -> TCM ()
- Agda.TypeChecking.MetaVars.Occurs: type AllowedVar = Modality -> All
- Agda.TypeChecking.MetaVars.Occurs: type OccursCtx = FreeEnv' () OccursExtra AllowedVar
- Agda.TypeChecking.MetaVars.Occurs: type OccursM = ReaderT OccursCtx TCM
- Agda.TypeChecking.MetaVars.Occurs: unfold :: (Instantiate t, Reduce t) => t -> OccursM t
- Agda.TypeChecking.MetaVars.Occurs: unfoldB :: (Instantiate t, Reduce t) => t -> OccursM (Blocked t)
- Agda.TypeChecking.MetaVars.Occurs: variableCheck :: VarMap -> Maybe Variable -> AllowedVar
- Agda.TypeChecking.MetaVars.Occurs: weakly :: OccursM a -> OccursM a
- Agda.TypeChecking.Monad.Base: CosplitCatchall :: SplitError
- Agda.TypeChecking.Monad.Base: GenericDocError :: Doc -> TypeError
- Agda.TypeChecking.Monad.Base: GenericError :: String -> TypeError
- Agda.TypeChecking.Monad.Base: Inferred :: !HasEta -> EtaEquality
- Agda.TypeChecking.Monad.Base: NLPType :: NLPSort -> NLPat -> NLPType
- Agda.TypeChecking.Monad.Base: NoErasedMatches :: ErasedDatatypeReason
- Agda.TypeChecking.Monad.Base: NoK :: ErasedDatatypeReason
- Agda.TypeChecking.Monad.Base: PBoundVar :: {-# UNPACK #-} !Int -> PElims -> NLPat
- Agda.TypeChecking.Monad.Base: PDef :: QName -> PElims -> NLPat
- Agda.TypeChecking.Monad.Base: PInf :: Univ -> Integer -> NLPSort
- Agda.TypeChecking.Monad.Base: PIntervalUniv :: NLPSort
- Agda.TypeChecking.Monad.Base: PLam :: ArgInfo -> Abs NLPat -> NLPat
- Agda.TypeChecking.Monad.Base: PLevelUniv :: NLPSort
- Agda.TypeChecking.Monad.Base: PLockUniv :: NLPSort
- Agda.TypeChecking.Monad.Base: PPi :: Dom NLPType -> Abs NLPType -> NLPat
- Agda.TypeChecking.Monad.Base: PSizeUniv :: NLPSort
- Agda.TypeChecking.Monad.Base: PSort :: NLPSort -> NLPat
- Agda.TypeChecking.Monad.Base: PTerm :: Term -> NLPat
- Agda.TypeChecking.Monad.Base: PUniv :: Univ -> NLPat -> NLPSort
- Agda.TypeChecking.Monad.Base: PVar :: !Int -> [Arg Int] -> NLPat
- Agda.TypeChecking.Monad.Base: ReduceM :: (ReduceEnv -> a) -> ReduceM a
- Agda.TypeChecking.Monad.Base: RewriteRule :: QName -> Telescope -> QName -> PElims -> Term -> Type -> Bool -> TopLevelModuleName -> RewriteRule
- Agda.TypeChecking.Monad.Base: SessionTCState :: !Benchmark -> [Backend] -> !FileDictWithBuiltins -> SessionTCState
- Agda.TypeChecking.Monad.Base: Specified :: !HasEta -> EtaEquality
- Agda.TypeChecking.Monad.Base: TCM :: (IORef TCState -> TCEnv -> m a) -> TCMT (m :: Type -> Type) a
- Agda.TypeChecking.Monad.Base: UnequalCohesion :: Comparison -> Term -> Term -> TypeError
- Agda.TypeChecking.Monad.Base: UnequalFiniteness :: Comparison -> Term -> Term -> TypeError
- Agda.TypeChecking.Monad.Base: UnequalHiding :: Term -> Term -> TypeError
- Agda.TypeChecking.Monad.Base: UnequalLevel :: Comparison -> Level -> Level -> TypeError
- Agda.TypeChecking.Monad.Base: UnequalPolarity :: Comparison -> Term -> Term -> TypeError
- Agda.TypeChecking.Monad.Base: UnequalQuantity :: Comparison -> Term -> Term -> TypeError
- Agda.TypeChecking.Monad.Base: UnequalRelevance :: Comparison -> Term -> Term -> TypeError
- Agda.TypeChecking.Monad.Base: UnequalSorts :: Sort -> Sort -> TypeError
- Agda.TypeChecking.Monad.Base: UnequalTerms :: Comparison -> Term -> Term -> CompareAs -> TypeError
- Agda.TypeChecking.Monad.Base: [_dataPathCons] :: DatatypeData -> [QName]
- Agda.TypeChecking.Monad.Base: [defCopatternLHS] :: Definition -> Bool
- Agda.TypeChecking.Monad.Base: [envAssignMetas] :: TCEnv -> Bool
- Agda.TypeChecking.Monad.Base: [envCallByNeed] :: TCEnv -> Bool
- Agda.TypeChecking.Monad.Base: [envCompareBlocked] :: TCEnv -> Bool
- Agda.TypeChecking.Monad.Base: [envConflComputingOverlap] :: TCEnv -> Bool
- Agda.TypeChecking.Monad.Base: [envCurrentlyElaborating] :: TCEnv -> Bool
- Agda.TypeChecking.Monad.Base: [envDisplayFormsEnabled] :: TCEnv -> Bool
- Agda.TypeChecking.Monad.Base: [envFoldLetBindings] :: TCEnv -> Bool
- Agda.TypeChecking.Monad.Base: [envHardCompileTimeMode] :: TCEnv -> Bool
- Agda.TypeChecking.Monad.Base: [envImportPath] :: TCEnv -> [TopLevelModuleName]
- Agda.TypeChecking.Monad.Base: [envInsideDotPattern] :: TCEnv -> Bool
- Agda.TypeChecking.Monad.Base: [envIsDebugPrinting] :: TCEnv -> Bool
- Agda.TypeChecking.Monad.Base: [envMakeCase] :: TCEnv -> Bool
- Agda.TypeChecking.Monad.Base: [envPrintDomainFreePi] :: TCEnv -> Bool
- Agda.TypeChecking.Monad.Base: [envPrintMetasBare] :: TCEnv -> Bool
- Agda.TypeChecking.Monad.Base: [envReconstructed] :: TCEnv -> Bool
- Agda.TypeChecking.Monad.Base: [envSolvingConstraints] :: TCEnv -> Bool
- Agda.TypeChecking.Monad.Base: [envSplitOnStrict] :: TCEnv -> Bool
- Agda.TypeChecking.Monad.Base: [envTermCheckReducing] :: TCEnv -> Bool
- Agda.TypeChecking.Monad.Base: [envWorkingOnTypes] :: TCEnv -> Bool
- Agda.TypeChecking.Monad.Base: [miPrimitive] :: ModuleInfo -> Bool
- Agda.TypeChecking.Monad.Base: [nlpTypeSort] :: NLPType -> NLPSort
- Agda.TypeChecking.Monad.Base: [nlpTypeUnEl] :: NLPType -> NLPat
- Agda.TypeChecking.Monad.Base: [rewContext] :: RewriteRule -> Telescope
- Agda.TypeChecking.Monad.Base: [rewFromClause] :: RewriteRule -> Bool
- Agda.TypeChecking.Monad.Base: [rewHead] :: RewriteRule -> QName
- Agda.TypeChecking.Monad.Base: [rewName] :: RewriteRule -> QName
- Agda.TypeChecking.Monad.Base: [rewPats] :: RewriteRule -> PElims
- Agda.TypeChecking.Monad.Base: [rewRHS] :: RewriteRule -> Term
- Agda.TypeChecking.Monad.Base: [rewTopModule] :: RewriteRule -> TopLevelModuleName
- Agda.TypeChecking.Monad.Base: [rewType] :: RewriteRule -> Type
- Agda.TypeChecking.Monad.Base: [stInteractionOutputCallback] :: PersistentTCState -> InteractionOutputCallback
- Agda.TypeChecking.Monad.Base: [stPostAreWeCaching] :: PostScopeState -> !Bool
- Agda.TypeChecking.Monad.Base: [stPostConsideringInstance] :: PostScopeState -> !Bool
- Agda.TypeChecking.Monad.Base: [stPostDirty] :: PostScopeState -> !Bool
- Agda.TypeChecking.Monad.Base: [stPostInstanceHack] :: PostScopeState -> !Bool
- Agda.TypeChecking.Monad.Base: [stPostInstantiateBlocking] :: PostScopeState -> !Bool
- Agda.TypeChecking.Monad.Base: [stPostPostponeInstanceSearch] :: PostScopeState -> !Bool
- Agda.TypeChecking.Monad.Base: [stPostShadowingNames] :: PostScopeState -> !ShadowingNames
- Agda.TypeChecking.Monad.Base: [stPostUsedNames] :: PostScopeState -> !UsedNames
- Agda.TypeChecking.Monad.Base: [stPreModuleToSourceId] :: PreScopeState -> !ModuleToSourceId
- Agda.TypeChecking.Monad.Base: [stSessionBenchmark] :: SessionTCState -> !Benchmark
- Agda.TypeChecking.Monad.Base: [unTCM] :: TCMT (m :: Type -> Type) a -> IORef TCState -> TCEnv -> m a
- Agda.TypeChecking.Monad.Base: data NLPSort
- Agda.TypeChecking.Monad.Base: data NLPType
- Agda.TypeChecking.Monad.Base: data NLPat
- Agda.TypeChecking.Monad.Base: data RewriteRule
- Agda.TypeChecking.Monad.Base: data SessionTCState
- Agda.TypeChecking.Monad.Base: dataPathCons :: Defn -> [QName]
- Agda.TypeChecking.Monad.Base: eImportPath :: Lens' TCEnv [TopLevelModuleName]
- Agda.TypeChecking.Monad.Base: genericDocError :: (HasCallStack, MonadTCError m) => Doc -> m a
- Agda.TypeChecking.Monad.Base: genericError :: (HasCallStack, MonadTCError m) => String -> m a
- Agda.TypeChecking.Monad.Base: initPersistentState :: AbsolutePath -> PersistentTCState
- Agda.TypeChecking.Monad.Base: instance (Agda.Utils.IO.CatchIO m, Control.Monad.IO.Class.MonadIO m) => Control.Monad.Error.Class.MonadError Agda.TypeChecking.Monad.Base.TCErr (Agda.TypeChecking.Monad.Base.TCMT m)
- Agda.TypeChecking.Monad.Base: instance (Agda.Utils.IO.CatchIO m, Control.Monad.IO.Class.MonadIO m) => Control.Monad.Fail.MonadFail (Agda.TypeChecking.Monad.Base.TCMT m)
- Agda.TypeChecking.Monad.Base: instance (Control.Monad.IO.Class.MonadIO m, GHC.Base.Semigroup a, GHC.Base.Monoid a) => GHC.Base.Monoid (Agda.TypeChecking.Monad.Base.TCMT m a)
- 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.KillRange Agda.TypeChecking.Monad.Base.NLPSort
- Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Position.KillRange Agda.TypeChecking.Monad.Base.NLPType
- Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Position.KillRange Agda.TypeChecking.Monad.Base.NLPat
- Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Position.KillRange Agda.TypeChecking.Monad.Base.RewriteRule
- Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Position.KillRange Agda.TypeChecking.Monad.Base.RewriteRuleMap
- Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Position.KillRange a => Agda.Syntax.Position.KillRange (Agda.TypeChecking.Monad.Base.Closure a)
- Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Free.Lazy.Free Agda.TypeChecking.Monad.Base.Candidate
- Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Free.Lazy.Free Agda.TypeChecking.Monad.Base.CompareAs
- Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Free.Lazy.Free Agda.TypeChecking.Monad.Base.Constraint
- Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Free.Lazy.Free Agda.TypeChecking.Monad.Base.DisplayForm
- Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Free.Lazy.Free Agda.TypeChecking.Monad.Base.DisplayTerm
- Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.NLPSort
- Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.NLPType
- Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.NLPat
- Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.RewriteRule
- Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.SessionTCState
- Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.NLPSort
- Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.NLPType
- Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.NLPat
- Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.RewriteRule
- Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.SessionTCState
- Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.NLPSort
- Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.NLPType
- Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.NLPat
- Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.RewriteRule
- Agda.TypeChecking.Monad.Base: lensBenchmark :: Lens' SessionTCState Benchmark
- Agda.TypeChecking.Monad.Base: lensSessionState :: Lens' TCState SessionTCState
- Agda.TypeChecking.Monad.Base: lensShadowingNames :: Lens' PostScopeState ShadowingNames
- Agda.TypeChecking.Monad.Base: lensUsedNames :: Lens' PostScopeState UsedNames
- Agda.TypeChecking.Monad.Base: pattern PProp :: NLPat -> NLPSort
- Agda.TypeChecking.Monad.Base: pattern PSSet :: NLPat -> NLPSort
- Agda.TypeChecking.Monad.Base: pattern PType :: NLPat -> NLPSort
- Agda.TypeChecking.Monad.Base: stBackends :: Lens' TCState [Backend]
- Agda.TypeChecking.Monad.Base: stBenchmark :: Lens' TCState Benchmark
- Agda.TypeChecking.Monad.Base: stBuiltinModuleIds :: Lens' TCState BuiltinModuleIds
- Agda.TypeChecking.Monad.Base: stFileDict :: Lens' TCState FileDictWithBuiltins
- Agda.TypeChecking.Monad.Base: stModuleToSource :: Lens' TCState ModuleToSource
- Agda.TypeChecking.Monad.Base: stModuleToSourceId :: Lens' TCState ModuleToSourceId
- Agda.TypeChecking.Monad.Base: stPrimitiveLibDir :: Lens' TCState PrimitiveLibDir
- Agda.TypeChecking.Monad.Base: stShadowingNames :: Lens' TCState ShadowingNames
- Agda.TypeChecking.Monad.Base: stUsedNames :: Lens' TCState UsedNames
- Agda.TypeChecking.Monad.Base: type PElims = [Elim' NLPat]
- Agda.TypeChecking.Monad.Base: type RewriteRuleMap = HashMap QName RewriteRules
- Agda.TypeChecking.Monad.Base: type ShadowingNames = Map Name Set1 RawName
- Agda.TypeChecking.Monad.Base: type Statistics = Map String Integer
- Agda.TypeChecking.Monad.Base: type UsedNames = Map RawName Set1 RawName
- Agda.TypeChecking.Monad.Base.Types: IsPrimitiveModule :: IsBuiltinModule
- Agda.TypeChecking.Monad.Context: withShadowingNameTCM :: Name -> TCM b -> TCM b
- Agda.TypeChecking.Monad.Imports: addImportCycleCheck :: TopLevelModuleName -> TCM a -> TCM a
- Agda.TypeChecking.Monad.Imports: getImportPath :: TCM [TopLevelModuleName]
- Agda.TypeChecking.Monad.Imports: withImportPath :: [TopLevelModuleName] -> TCM a -> TCM a
- Agda.TypeChecking.Monad.Signature: ($dmgetRewriteRulesFor) :: forall (n :: Type -> Type) (t :: (Type -> Type) -> Type -> Type). (HasConstInfo m, HasConstInfo n, MonadTrans t, m ~ t n) => QName -> m RewriteRules
- Agda.TypeChecking.Monad.Signature: defaultGetRewriteRulesFor :: (ReadTCState m, MonadTCEnv m) => QName -> m RewriteRules
- Agda.TypeChecking.Monad.Signature: getFilteredRewriteRulesFor :: (ReadTCState m, MonadTCEnv m) => Bool -> QName -> m RewriteRules
- Agda.TypeChecking.Monad.Signature: getRewriteRulesFor :: HasConstInfo m => QName -> m RewriteRules
- Agda.TypeChecking.Monad.Signature: instance Agda.TypeChecking.Monad.Signature.HasConstInfo (Agda.TypeChecking.Monad.Base.TCMT GHC.Types.IO)
- Agda.TypeChecking.Monad.Signature: setModuleCheckpoint :: ModuleName -> TCM ()
- Agda.TypeChecking.Monad.Signature: unionSignature :: Signature -> Signature -> Signature
- Agda.TypeChecking.Monad.Signature: unionSignatures :: [Signature] -> Signature
- Agda.TypeChecking.Monad.State: instance Control.Monad.IO.Class.MonadIO m => Agda.Utils.FileId.MonadFileId (Agda.TypeChecking.Monad.Base.TCMT m)
- Agda.TypeChecking.Monad.State: isPrimitiveModule :: ReadTCState m => FileId -> m Bool
- Agda.TypeChecking.Monad.State: modifyScope_ :: MonadTCState m => (ScopeInfo -> ScopeInfo) -> m ()
- Agda.TypeChecking.Monad.State: putTCPreservingSession :: TCState -> TCM ()
- Agda.TypeChecking.Monad.State: withScope_ :: ReadTCState m => ScopeInfo -> m a -> m a
- Agda.TypeChecking.Monad.Statistics: ($dmmodifyCounter) :: forall (n :: Type -> Type) (t :: (Type -> Type) -> Type -> Type). (MonadStatistics m, MonadStatistics n, MonadTrans t, t n ~ m) => String -> (Integer -> Integer) -> m ()
- Agda.TypeChecking.Monad.Statistics: modifyCounter :: MonadStatistics m => String -> (Integer -> Integer) -> m ()
- Agda.TypeChecking.Names: instance (Agda.TypeChecking.Monad.Builtin.HasBuiltins m, Agda.TypeChecking.Monad.Signature.HasConstInfo m, Agda.TypeChecking.Monad.Context.MonadAddContext m, Agda.TypeChecking.Monad.Base.MonadReduce m) => Agda.TypeChecking.Monad.Pure.PureTCM (Agda.TypeChecking.Names.NamesT m)
- Agda.TypeChecking.Positivity: ($dmoccurrences) :: forall (t :: Type -> Type) b. (ComputeOccurrences a, Foldable t, ComputeOccurrences b, t b ~ a) => a -> OccM OccurrencesBuilder
- Agda.TypeChecking.Positivity: ADef :: QName -> Item
- Agda.TypeChecking.Positivity: AnArg :: Nat -> [Occurrence] -> Item
- Agda.TypeChecking.Positivity: ArgNode :: !QName -> !Nat -> Node
- Agda.TypeChecking.Positivity: Concat :: [OccurrencesBuilder] -> OccurrencesBuilder
- Agda.TypeChecking.Positivity: Concat' :: [OccurrencesBuilder'] -> OccurrencesBuilder'
- Agda.TypeChecking.Positivity: DefNode :: !QName -> Node
- Agda.TypeChecking.Positivity: Edge :: !Occurrence -> a -> Edge a
- Agda.TypeChecking.Positivity: OccEnv :: [Maybe Item] -> Maybe QName -> OccEnv
- Agda.TypeChecking.Positivity: OccursAs :: Where -> OccurrencesBuilder -> OccurrencesBuilder
- Agda.TypeChecking.Positivity: OccursAs' :: Where -> OccurrencesBuilder' -> OccurrencesBuilder'
- Agda.TypeChecking.Positivity: OccursHere :: Item -> OccurrencesBuilder
- Agda.TypeChecking.Positivity: OccursHere' :: Item -> OccurrencesBuilder'
- Agda.TypeChecking.Positivity: OnlyVarsUpTo :: Nat -> OccurrencesBuilder -> OccurrencesBuilder
- Agda.TypeChecking.Positivity: [inf] :: OccEnv -> Maybe QName
- Agda.TypeChecking.Positivity: [vars] :: OccEnv -> [Maybe Item]
- Agda.TypeChecking.Positivity: buildOccurrenceGraph :: Set QName -> TCM (Graph Node (Edge OccursWhere))
- Agda.TypeChecking.Positivity: class ComputeOccurrences a
- Agda.TypeChecking.Positivity: computeEdges :: Set QName -> QName -> OccurrencesBuilder -> TCM [Edge Node (Edge OccursWhere)]
- Agda.TypeChecking.Positivity: computeOccurrences :: QName -> TCM (Map Item Integer)
- Agda.TypeChecking.Positivity: computeOccurrences' :: QName -> TCM OccurrencesBuilder
- Agda.TypeChecking.Positivity: data Edge a
- Agda.TypeChecking.Positivity: data Item
- Agda.TypeChecking.Positivity: data Node
- Agda.TypeChecking.Positivity: data OccEnv
- Agda.TypeChecking.Positivity: data OccurrencesBuilder
- Agda.TypeChecking.Positivity: data OccurrencesBuilder'
- Agda.TypeChecking.Positivity: flatten :: OccurrencesBuilder -> Map Item Integer
- Agda.TypeChecking.Positivity: getOccurrences :: (Show a, PrettyTCM a, ComputeOccurrences a) => [Maybe Item] -> a -> TCM OccurrencesBuilder
- Agda.TypeChecking.Positivity: instance (Agda.TypeChecking.Positivity.ComputeOccurrences a, Agda.TypeChecking.Positivity.ComputeOccurrences b) => Agda.TypeChecking.Positivity.ComputeOccurrences (a, b)
- Agda.TypeChecking.Positivity: instance (Agda.TypeChecking.Positivity.ComputeOccurrences x, Agda.TypeChecking.Positivity.ComputeOccurrences a) => Agda.TypeChecking.Positivity.ComputeOccurrences (Agda.TypeChecking.Telescope.Boundary' x a)
- Agda.TypeChecking.Positivity: instance (GHC.Base.Semigroup a, GHC.Base.Monoid a) => GHC.Base.Monoid (Agda.TypeChecking.Positivity.OccM a)
- Agda.TypeChecking.Positivity: instance Agda.Syntax.Common.Pretty.Pretty Agda.TypeChecking.Positivity.Item
- Agda.TypeChecking.Positivity: instance Agda.Syntax.Common.Pretty.Pretty Agda.TypeChecking.Positivity.Node
- Agda.TypeChecking.Positivity: instance Agda.Syntax.Position.HasRange Agda.TypeChecking.Positivity.Item
- Agda.TypeChecking.Positivity: instance Agda.TypeChecking.Positivity.ComputeOccurrences Agda.Syntax.Internal.Clause
- Agda.TypeChecking.Positivity: instance Agda.TypeChecking.Positivity.ComputeOccurrences Agda.Syntax.Internal.Level
- Agda.TypeChecking.Positivity: instance Agda.TypeChecking.Positivity.ComputeOccurrences Agda.Syntax.Internal.PlusLevel
- Agda.TypeChecking.Positivity: instance Agda.TypeChecking.Positivity.ComputeOccurrences Agda.Syntax.Internal.Term
- Agda.TypeChecking.Positivity: instance Agda.TypeChecking.Positivity.ComputeOccurrences Agda.Syntax.Internal.Type
- Agda.TypeChecking.Positivity: instance Agda.TypeChecking.Positivity.ComputeOccurrences GHC.Types.Int
- Agda.TypeChecking.Positivity: instance Agda.TypeChecking.Positivity.ComputeOccurrences a => Agda.TypeChecking.Positivity.ComputeOccurrences (Agda.Syntax.Common.Arg a)
- Agda.TypeChecking.Positivity: instance Agda.TypeChecking.Positivity.ComputeOccurrences a => Agda.TypeChecking.Positivity.ComputeOccurrences (Agda.Syntax.Internal.Abs a)
- Agda.TypeChecking.Positivity: instance Agda.TypeChecking.Positivity.ComputeOccurrences a => Agda.TypeChecking.Positivity.ComputeOccurrences (Agda.Syntax.Internal.Dom a)
- Agda.TypeChecking.Positivity: instance Agda.TypeChecking.Positivity.ComputeOccurrences a => Agda.TypeChecking.Positivity.ComputeOccurrences (Agda.Syntax.Internal.Elim.Elim' a)
- Agda.TypeChecking.Positivity: instance Agda.TypeChecking.Positivity.ComputeOccurrences a => Agda.TypeChecking.Positivity.ComputeOccurrences (Agda.Syntax.Internal.Tele a)
- Agda.TypeChecking.Positivity: instance Agda.TypeChecking.Positivity.ComputeOccurrences a => Agda.TypeChecking.Positivity.ComputeOccurrences (GHC.Maybe.Maybe a)
- Agda.TypeChecking.Positivity: instance Agda.TypeChecking.Positivity.ComputeOccurrences a => Agda.TypeChecking.Positivity.ComputeOccurrences [a]
- Agda.TypeChecking.Positivity: instance Agda.TypeChecking.Pretty.PrettyTCM (Data.Sequence.Internal.Seq Agda.TypeChecking.Positivity.Occurrence.OccursWhere)
- Agda.TypeChecking.Positivity: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Positivity.Node
- Agda.TypeChecking.Positivity: instance Agda.TypeChecking.Pretty.PrettyTCMWithNode (Agda.TypeChecking.Positivity.Edge Agda.TypeChecking.Positivity.Occurrence.OccursWhere)
- Agda.TypeChecking.Positivity: instance Agda.Utils.SemiRing.SemiRing (Agda.TypeChecking.Positivity.Edge (Data.Sequence.Internal.Seq Agda.TypeChecking.Positivity.Occurrence.OccursWhere))
- Agda.TypeChecking.Positivity: instance GHC.Base.Functor Agda.TypeChecking.Positivity.Edge
- Agda.TypeChecking.Positivity: instance GHC.Base.Monoid Agda.TypeChecking.Positivity.OccurrencesBuilder
- Agda.TypeChecking.Positivity: instance GHC.Base.Semigroup Agda.TypeChecking.Positivity.OccurrencesBuilder
- Agda.TypeChecking.Positivity: instance GHC.Classes.Eq Agda.TypeChecking.Positivity.Item
- Agda.TypeChecking.Positivity: instance GHC.Classes.Eq Agda.TypeChecking.Positivity.Node
- Agda.TypeChecking.Positivity: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.TypeChecking.Positivity.Edge a)
- Agda.TypeChecking.Positivity: instance GHC.Classes.Ord Agda.TypeChecking.Positivity.Item
- Agda.TypeChecking.Positivity: instance GHC.Classes.Ord Agda.TypeChecking.Positivity.Node
- Agda.TypeChecking.Positivity: instance GHC.Classes.Ord a => GHC.Classes.Ord (Agda.TypeChecking.Positivity.Edge a)
- Agda.TypeChecking.Positivity: instance GHC.Show.Show Agda.TypeChecking.Positivity.Item
- Agda.TypeChecking.Positivity: instance GHC.Show.Show a => GHC.Show.Show (Agda.TypeChecking.Positivity.Edge a)
- Agda.TypeChecking.Positivity: mergeEdges :: Edge a -> Edge a -> Edge a
- Agda.TypeChecking.Positivity: occurrences :: ComputeOccurrences a => a -> OccM OccurrencesBuilder
- Agda.TypeChecking.Positivity: preprocess :: OccurrencesBuilder -> OccurrencesBuilder'
- Agda.TypeChecking.Positivity: type Graph n e = Graph n e
- Agda.TypeChecking.Positivity: type OccM = ReaderT OccEnv ReduceM
- Agda.TypeChecking.Positivity: type Occurrences = Map Item [OccursWhere]
- Agda.TypeChecking.Positivity: withExtendedOccEnv :: Maybe Item -> OccM a -> OccM a
- Agda.TypeChecking.Positivity: withExtendedOccEnv' :: [Maybe Item] -> OccM a -> OccM a
- Agda.TypeChecking.Positivity.Occurrence: IsIndex :: Where
- Agda.TypeChecking.Positivity.Occurrence: boundToEverySome :: Map Occurrence [(Occurrence -> Bool, Occurrence -> Bool)]
- Agda.TypeChecking.Positivity.Occurrence: data Where
- Agda.TypeChecking.Positivity.Occurrence: instance Agda.Syntax.Common.Pretty.Pretty Agda.TypeChecking.Positivity.Occurrence.Where
- Agda.TypeChecking.Positivity.Occurrence: instance Agda.Utils.Null.Null Agda.TypeChecking.Positivity.Occurrence.OccursWhere
- Agda.TypeChecking.Positivity.Occurrence: instance Agda.Utils.Size.Sized Agda.TypeChecking.Positivity.Occurrence.OccursWhere
- Agda.TypeChecking.Positivity.Occurrence: instance Control.DeepSeq.NFData Agda.TypeChecking.Positivity.Occurrence.OccursWhere
- Agda.TypeChecking.Positivity.Occurrence: instance Control.DeepSeq.NFData Agda.TypeChecking.Positivity.Occurrence.Where
- Agda.TypeChecking.Positivity.Occurrence: instance GHC.Classes.Eq Agda.TypeChecking.Positivity.Occurrence.Where
- Agda.TypeChecking.Positivity.Occurrence: instance GHC.Classes.Ord Agda.TypeChecking.Positivity.Occurrence.OccursWhere
- Agda.TypeChecking.Positivity.Occurrence: instance GHC.Classes.Ord Agda.TypeChecking.Positivity.Occurrence.Where
- Agda.TypeChecking.Positivity.Occurrence: instance GHC.Generics.Generic Agda.TypeChecking.Positivity.Occurrence.OccursWhere
- Agda.TypeChecking.Positivity.Occurrence: instance GHC.Generics.Generic Agda.TypeChecking.Positivity.Occurrence.Where
- Agda.TypeChecking.Positivity.Occurrence: instance GHC.Show.Show Agda.TypeChecking.Positivity.Occurrence.Where
- Agda.TypeChecking.Positivity.Occurrence: productOfEdgesInBoundedWalk :: (SemiRing e, Ord n) => (e -> Occurrence) -> Graph n e -> n -> n -> Occurrence -> Maybe e
- Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM (Agda.Syntax.Internal.Elim.Elim' Agda.TypeChecking.Monad.Base.NLPat)
- Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM (Agda.Syntax.Internal.Type' Agda.TypeChecking.Monad.Base.NLPat)
- Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Syntax.Scope.Base.AbstractName
- Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Monad.Base.NLPSort
- Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Monad.Base.NLPType
- Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Monad.Base.NLPat
- Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Monad.Base.RewriteRule
- Agda.TypeChecking.Pretty.Warning: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Syntax.Internal.DataOrRecord_
- Agda.TypeChecking.Primitive.Cubical: pathTelescope :: (PureTCM m, MonadError TCErr m) => Telescope -> [Arg Term] -> [Arg Term] -> m Telescope
- Agda.TypeChecking.ProjectionLike: ButLone :: ProjEliminator
- Agda.TypeChecking.ProjectionLike: EvenLone :: ProjEliminator
- Agda.TypeChecking.ProjectionLike: NoPostfix :: ProjEliminator
- Agda.TypeChecking.ProjectionLike: data ProjEliminator
- Agda.TypeChecking.ProjectionLike: instance GHC.Classes.Eq Agda.TypeChecking.ProjectionLike.ProjEliminator
- Agda.TypeChecking.Records: etaExpandAtRecordType :: Type -> Term -> TCM (Telescope, Term)
- Agda.TypeChecking.Records: nonRecursiveRecord :: QName -> TCM ()
- Agda.TypeChecking.Records: recursiveRecord :: QName -> TCM ()
- Agda.TypeChecking.Records: updateEtaForRecord :: QName -> TCM ()
- Agda.TypeChecking.Reduce: instance (Agda.TypeChecking.Reduce.Instantiate t, Agda.TypeChecking.Reduce.Instantiate e) => Agda.TypeChecking.Reduce.Instantiate (Agda.Syntax.Internal.Dom' t e)
- Agda.TypeChecking.Reduce: instance (Agda.TypeChecking.Reduce.InstantiateFull t, Agda.TypeChecking.Reduce.InstantiateFull e) => Agda.TypeChecking.Reduce.InstantiateFull (Agda.Syntax.Internal.Dom' t e)
- Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull Agda.TypeChecking.Monad.Base.NLPSort
- Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull Agda.TypeChecking.Monad.Base.NLPType
- Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull Agda.TypeChecking.Monad.Base.NLPat
- Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull Agda.TypeChecking.Monad.Base.RewriteRule
- Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull t => Agda.TypeChecking.Reduce.InstantiateFull [t]
- Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.IsMeta a => Agda.TypeChecking.Reduce.IsMeta (Agda.Syntax.Internal.Sort' a)
- Agda.TypeChecking.Reduce.Fast: instance Agda.Syntax.Common.Pretty.Pretty (Agda.TypeChecking.Reduce.Fast.AM s)
- Agda.TypeChecking.Reduce.Fast: instance Agda.Syntax.Common.Pretty.Pretty (Agda.TypeChecking.Reduce.Fast.ControlFrame s)
- Agda.TypeChecking.Reduce.Fast: instance Agda.Syntax.Common.Pretty.Pretty a => Agda.Syntax.Common.Pretty.Pretty (Agda.TypeChecking.Reduce.Fast.Thunk a)
- Agda.TypeChecking.Reduce.Fast: instance Agda.Utils.Zipper.Zipper (Agda.TypeChecking.Reduce.Fast.ElimZipper a)
- Agda.TypeChecking.Reduce.Fast: instance GHC.Base.Functor Agda.TypeChecking.Reduce.Fast.Thunk
- Agda.TypeChecking.Reduce.Monad: constructorForm :: HasBuiltins m => Term -> m Term
- Agda.TypeChecking.Rewriting.Clause: instance Agda.TypeChecking.Rewriting.Clause.ToNLPat (Agda.Syntax.Common.Arg Agda.Syntax.Internal.DeBruijnPattern) (Agda.Syntax.Internal.Elim.Elim' Agda.TypeChecking.Monad.Base.NLPat)
- Agda.TypeChecking.Rewriting.Clause: instance Agda.TypeChecking.Rewriting.Clause.ToNLPat (Agda.Syntax.Common.NamedArg Agda.Syntax.Internal.DeBruijnPattern) (Agda.Syntax.Internal.Elim.Elim' Agda.TypeChecking.Monad.Base.NLPat)
- Agda.TypeChecking.Rewriting.Confluence: instance (Agda.TypeChecking.Free.Lazy.Free a, Agda.TypeChecking.Substitute.Class.Subst a, Agda.TypeChecking.Rewriting.Confluence.ParallelReduce a) => Agda.TypeChecking.Rewriting.Confluence.ParallelReduce (Agda.Syntax.Internal.Abs a)
- Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.TypeChecking.Rewriting.NonLinMatch.Match Agda.TypeChecking.Monad.Base.NLPSort Agda.Syntax.Internal.Sort
- Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.TypeChecking.Rewriting.NonLinMatch.Match Agda.TypeChecking.Monad.Base.NLPType Agda.Syntax.Internal.Type
- Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.TypeChecking.Rewriting.NonLinMatch.Match Agda.TypeChecking.Monad.Base.NLPat Agda.Syntax.Internal.Level
- Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.TypeChecking.Rewriting.NonLinMatch.Match Agda.TypeChecking.Monad.Base.NLPat Agda.Syntax.Internal.Term
- Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.TypeChecking.Rewriting.NonLinMatch.Match [Agda.Syntax.Internal.Elim.Elim' Agda.TypeChecking.Monad.Base.NLPat] Agda.Syntax.Internal.Elims
- Agda.TypeChecking.Rewriting.NonLinPattern: instance (Data.Foldable.Foldable f, Agda.TypeChecking.Rewriting.NonLinPattern.NLPatVars a) => Agda.TypeChecking.Rewriting.NonLinPattern.NLPatVars (f a)
- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Free.Lazy.Free Agda.TypeChecking.Monad.Base.NLPSort
- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Free.Lazy.Free Agda.TypeChecking.Monad.Base.NLPType
- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Free.Lazy.Free Agda.TypeChecking.Monad.Base.NLPat
- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.GetMatchables Agda.TypeChecking.Monad.Base.NLPSort
- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.GetMatchables Agda.TypeChecking.Monad.Base.NLPType
- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.GetMatchables Agda.TypeChecking.Monad.Base.NLPat
- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.GetMatchables Agda.TypeChecking.Monad.Base.RewriteRule
- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.NLPatToTerm Agda.TypeChecking.Monad.Base.NLPSort Agda.Syntax.Internal.Sort
- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.NLPatToTerm Agda.TypeChecking.Monad.Base.NLPType Agda.Syntax.Internal.Type
- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.NLPatToTerm Agda.TypeChecking.Monad.Base.NLPat Agda.Syntax.Internal.Level
- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.NLPatToTerm Agda.TypeChecking.Monad.Base.NLPat Agda.Syntax.Internal.Term
- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.NLPatVars Agda.TypeChecking.Monad.Base.NLPSort
- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.NLPatVars Agda.TypeChecking.Monad.Base.NLPType
- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.NLPatVars Agda.TypeChecking.Monad.Base.NLPat
- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.PatternFrom Agda.Syntax.Internal.Elims [Agda.Syntax.Internal.Elim.Elim' Agda.TypeChecking.Monad.Base.NLPat]
- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.PatternFrom Agda.Syntax.Internal.Level Agda.TypeChecking.Monad.Base.NLPat
- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.PatternFrom Agda.Syntax.Internal.Sort Agda.TypeChecking.Monad.Base.NLPSort
- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.PatternFrom Agda.Syntax.Internal.Term Agda.TypeChecking.Monad.Base.NLPat
- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.PatternFrom Agda.Syntax.Internal.Type Agda.TypeChecking.Monad.Base.NLPType
- Agda.TypeChecking.Rules.Data: PathCons :: IsPathCons
- Agda.TypeChecking.Rules.Data: PointCons :: IsPathCons
- Agda.TypeChecking.Rules.Data: data IsPathCons
- Agda.TypeChecking.Rules.Data: instance GHC.Classes.Eq Agda.TypeChecking.Rules.Data.IsPathCons
- Agda.TypeChecking.Rules.Data: instance GHC.Show.Show Agda.TypeChecking.Rules.Data.IsPathCons
- Agda.TypeChecking.Rules.Decl: checkAxiom' :: Maybe GeneralizeTelescope -> KindOfName -> DefInfo -> ArgInfo -> Maybe PragmaPolarities -> QName -> Expr -> TCM ()
- Agda.TypeChecking.Rules.Def: NoWithFunction :: WithFunctionProblem
- Agda.TypeChecking.Rules.Def: WithFunction :: QName -> QName -> Type -> Telescope -> Telescope -> Telescope -> List1 (Arg (Term, EqualityView)) -> Type -> [NamedArg DeBruijnPattern] -> Nat -> Permutation -> Permutation -> Permutation -> List1 Clause -> Substitution -> Map Name LetBinding -> WithFunctionProblem
- Agda.TypeChecking.Rules.Def: data WithFunctionProblem
- Agda.TypeChecking.Rules.Def: insertNames :: List1 (Arg (Maybe BindName)) -> RHS -> RHS
- Agda.TypeChecking.Rules.Record: addCompositionForRecord :: QName -> EtaEquality -> ConHead -> Telescope -> [Arg QName] -> Telescope -> Type -> TCM ()
- Agda.TypeChecking.Rules.Record: defineCompKitR :: QName -> Telescope -> Telescope -> [Arg QName] -> Type -> TCM CompKit
- Agda.TypeChecking.Rules.Record: defineKanOperationR :: Command -> QName -> Telescope -> Telescope -> [Arg QName] -> Type -> TCM (Maybe QName)
- Agda.TypeChecking.Serialise: class Typeable a => EmbPrj a
- Agda.TypeChecking.Serialise: decodeHashes :: ByteString -> Maybe (Hash, Hash)
- Agda.TypeChecking.Serialise: encodeInterface :: Interface -> TCM Encoded
- Agda.TypeChecking.Serialise: instance Data.Binary.Class.Binary a => Data.Binary.Class.Binary (Agda.TypeChecking.Serialise.ListLike a)
- Agda.TypeChecking.Serialise.Base: Cons :: !Word32 -> !Node -> Node
- Agda.TypeChecking.Serialise.Base: Empty :: Node
- Agda.TypeChecking.Serialise.Base: FreshAndReuse :: Word32 -> FreshAndReuse
- Agda.TypeChecking.Serialise.Base: St :: !Array Word32 [Word32] -> !Array Word32 String -> !Array Word32 Text -> !Array Word32 Text -> !Array Word32 Integer -> !Array Word32 Double -> !Memo -> !ModuleToSource -> !List1 AbsolutePath -> St
- Agda.TypeChecking.Serialise.Base: [doubleE] :: St -> !Array Word32 Double
- Agda.TypeChecking.Serialise.Base: [farFresh] :: FreshAndReuse -> Word32
- Agda.TypeChecking.Serialise.Base: [integerE] :: St -> !Array Word32 Integer
- Agda.TypeChecking.Serialise.Base: [lTextE] :: St -> !Array Word32 Text
- Agda.TypeChecking.Serialise.Base: [nodeE] :: St -> !Array Word32 [Word32]
- Agda.TypeChecking.Serialise.Base: [sTextE] :: St -> !Array Word32 Text
- Agda.TypeChecking.Serialise.Base: [stringE] :: St -> !Array Word32 String
- Agda.TypeChecking.Serialise.Base: data Node
- Agda.TypeChecking.Serialise.Base: data St
- Agda.TypeChecking.Serialise.Base: icodeX :: (Eq k, Hashable k) => (Dict -> HashTable k Word32) -> (Dict -> IORef FreshAndReuse) -> k -> S Word32
- Agda.TypeChecking.Serialise.Base: instance (Agda.Utils.TypeLevel.IsBase t GHC.Types.~ 'GHC.Types.True) => Agda.TypeChecking.Serialise.Base.ICODE t 'GHC.Types.True
- Agda.TypeChecking.Serialise.Base: instance Agda.TypeChecking.Serialise.Base.ICODE t (Agda.Utils.TypeLevel.IsBase t) => Agda.TypeChecking.Serialise.Base.ICODE (a -> t) 'GHC.Types.False
- Agda.TypeChecking.Serialise.Base: instance Agda.TypeChecking.Serialise.Base.VALU t 'GHC.Types.True
- Agda.TypeChecking.Serialise.Base: instance Agda.TypeChecking.Serialise.Base.VALU t (Agda.Utils.TypeLevel.IsBase t) => Agda.TypeChecking.Serialise.Base.VALU (a -> t) 'GHC.Types.False
- Agda.TypeChecking.Serialise.Base: instance Data.Binary.Class.Binary Agda.TypeChecking.Serialise.Base.Node
- Agda.TypeChecking.Serialise.Base: instance Data.Hashable.Class.Hashable Agda.TypeChecking.Serialise.Base.Node
- Agda.TypeChecking.Serialise.Base: instance GHC.Classes.Eq Agda.TypeChecking.Serialise.Base.Node
- Agda.TypeChecking.Serialise.Base: lensFresh :: Lens' FreshAndReuse Word32
- Agda.TypeChecking.Serialise.Base: newtype FreshAndReuse
- Agda.TypeChecking.Serialise.Base: runGetState :: Get a -> ByteString -> ByteOffset -> (a, ByteString, ByteOffset)
- Agda.TypeChecking.Serialise.Base: type Memo = IOArray Word32 MemoEntry
- Agda.TypeChecking.Serialise.Instances.Abstract: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Scope.Base.AbstractModule
- Agda.TypeChecking.Serialise.Instances.Abstract: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Scope.Base.AbstractName
- Agda.TypeChecking.Serialise.Instances.Abstract: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Scope.Base.KindOfName
- Agda.TypeChecking.Serialise.Instances.Abstract: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Scope.Base.NameMetadata
- Agda.TypeChecking.Serialise.Instances.Abstract: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Scope.Base.WhyInScope
- Agda.TypeChecking.Serialise.Instances.Common: instance (Agda.TypeChecking.Serialise.Base.EmbPrj a, Agda.TypeChecking.Serialise.Base.EmbPrj b) => Agda.TypeChecking.Serialise.Base.EmbPrj (Data.Either.Either a b)
- Agda.TypeChecking.Serialise.Instances.Common: instance (Agda.TypeChecking.Serialise.Base.EmbPrj a, Agda.TypeChecking.Serialise.Base.EmbPrj b) => Agda.TypeChecking.Serialise.Base.EmbPrj (Data.Strict.Tuple.Pair a b)
- Agda.TypeChecking.Serialise.Instances.Common: instance (Agda.TypeChecking.Serialise.Base.EmbPrj a, Agda.TypeChecking.Serialise.Base.EmbPrj b) => Agda.TypeChecking.Serialise.Base.EmbPrj (a, b)
- Agda.TypeChecking.Serialise.Instances.Common: instance (Agda.TypeChecking.Serialise.Base.EmbPrj a, Agda.TypeChecking.Serialise.Base.EmbPrj b, Agda.TypeChecking.Serialise.Base.EmbPrj c) => Agda.TypeChecking.Serialise.Base.EmbPrj (a, b, c)
- Agda.TypeChecking.Serialise.Instances.Common: instance (Agda.TypeChecking.Serialise.Base.EmbPrj a, Data.Typeable.Internal.Typeable b) => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Utils.WithDefault.WithDefault' a b)
- Agda.TypeChecking.Serialise.Instances.Common: instance (Agda.TypeChecking.Serialise.Base.EmbPrj k, Agda.TypeChecking.Serialise.Base.EmbPrj v, Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Utils.BiMap.Tag v)) => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Utils.BiMap.BiMap k v)
- Agda.TypeChecking.Serialise.Instances.Common: instance (GHC.Classes.Eq k, Data.Hashable.Class.Hashable k, Agda.TypeChecking.Serialise.Base.EmbPrj k, Agda.TypeChecking.Serialise.Base.EmbPrj v) => Agda.TypeChecking.Serialise.Base.EmbPrj (Data.HashMap.Internal.HashMap k v)
- Agda.TypeChecking.Serialise.Instances.Common: instance (GHC.Classes.Ord a, Agda.TypeChecking.Serialise.Base.EmbPrj a) => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Utils.Set1.Set1 a)
- Agda.TypeChecking.Serialise.Instances.Common: instance (GHC.Classes.Ord a, Agda.TypeChecking.Serialise.Base.EmbPrj a) => Agda.TypeChecking.Serialise.Base.EmbPrj (Data.Set.Internal.Set a)
- Agda.TypeChecking.Serialise.Instances.Common: instance (GHC.Classes.Ord a, Agda.TypeChecking.Serialise.Base.EmbPrj a, Agda.TypeChecking.Serialise.Base.EmbPrj b) => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Utils.Trie.Trie a b)
- Agda.TypeChecking.Serialise.Instances.Common: instance (GHC.Classes.Ord a, Agda.TypeChecking.Serialise.Base.EmbPrj a, Agda.TypeChecking.Serialise.Base.EmbPrj b) => Agda.TypeChecking.Serialise.Base.EmbPrj (Data.Map.Internal.Map a b)
- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj ()
- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj Data.IntSet.Internal.IntSet
- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj Data.Text.Internal.Lazy.Text
- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj Data.Text.Internal.Text
- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj GHC.Base.String
- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj GHC.Base.Void
- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj GHC.Int.Int32
- 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 GHC.Types.Bool
- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj GHC.Types.Char
- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj GHC.Types.Double
- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj GHC.Types.Int
- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj GHC.Word.Word32
- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj GHC.Word.Word64
- 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.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Utils.List2.List2 a)
- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Data.Sequence.Internal.Seq a)
- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Data.Strict.Maybe.Maybe a)
- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (GHC.Maybe.Maybe a)
- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj [a]
- Agda.TypeChecking.Serialise.Instances.Common: instance Data.Typeable.Internal.Typeable a => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Utils.SmallSet.SmallSet a)
- 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.Highlighting: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Interaction.Highlighting.Range.Range
- Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Internal.DataOrRecord
- Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.TypeChecking.Monad.Base.NLPSort
- Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.TypeChecking.Monad.Base.NLPType
- Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.TypeChecking.Monad.Base.NLPat
- Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.TypeChecking.Monad.Base.RewriteRule
- Agda.TypeChecking.Substitute: instance (Agda.TypeChecking.Substitute.Class.Subst a, GHC.Classes.Eq a) => GHC.Classes.Eq (Agda.Syntax.Internal.Elim.Elim' a)
- Agda.TypeChecking.Substitute: instance (Agda.TypeChecking.Substitute.Class.Subst a, GHC.Classes.Ord a) => GHC.Classes.Ord (Agda.Syntax.Internal.Elim.Elim' a)
- Agda.TypeChecking.Substitute: instance (GHC.Types.Coercible a Agda.Syntax.Internal.Term, Agda.TypeChecking.Substitute.Class.Subst a) => Agda.TypeChecking.Substitute.Class.Subst (Agda.Syntax.Internal.Sort' a)
- Agda.TypeChecking.Substitute: instance (GHC.Types.Coercible a Agda.Syntax.Internal.Term, Agda.TypeChecking.Substitute.Class.Subst a, Agda.TypeChecking.Substitute.Class.Subst b, Agda.TypeChecking.Substitute.Class.SubstArg a GHC.Types.~ Agda.TypeChecking.Substitute.Class.SubstArg b) => Agda.TypeChecking.Substitute.Class.Subst (Agda.Syntax.Internal.Type'' a b)
- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Abstract Agda.TypeChecking.Monad.Base.RewriteRule
- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Apply Agda.TypeChecking.Monad.Base.RewriteRule
- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Monad.Base.NLPSort
- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Monad.Base.NLPType
- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Monad.Base.NLPat
- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Monad.Base.RewriteRule
- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.DeBruijn.DeBruijn Agda.TypeChecking.Monad.Base.NLPat
- Agda.TypeChecking.Substitute: piSort' :: Dom Term -> Sort -> Abs Sort -> Either Blocker Sort
- Agda.TypeChecking.Substitute.Class: NoSubst :: a -> NoSubst t a
- Agda.TypeChecking.Substitute.Class: [unNoSubst] :: NoSubst t a -> a
- Agda.TypeChecking.Substitute.Class: instance Agda.TypeChecking.Substitute.DeBruijn.DeBruijn t => Agda.TypeChecking.Substitute.Class.Subst (Agda.TypeChecking.Substitute.Class.NoSubst t a)
- Agda.TypeChecking.Substitute.Class: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.TypeChecking.Substitute.Class.NoSubst t a)
- Agda.TypeChecking.Substitute.Class: instance GHC.Base.Functor (Agda.TypeChecking.Substitute.Class.NoSubst t)
- Agda.TypeChecking.Substitute.Class: instance GHC.Generics.Generic (Agda.TypeChecking.Substitute.Class.NoSubst t a)
- Agda.TypeChecking.Substitute.Class: newtype NoSubst t a
- Agda.Utils.Benchmark: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Utils.Benchmark.BenchmarkOn a)
- Agda.Utils.HashTable: data HashTable k v
- Agda.Utils.HashTable: keySet :: Ord k => HashTable k v -> IO (Set k)
- Agda.Utils.Lens: focus :: forall (m :: Type -> Type) o i a. Monad m => Lens' o i -> StateT i m a -> StateT o m a
- Agda.Utils.Lens: lFst :: forall a b f. Functor f => (a -> f a) -> (a, b) -> f (a, b)
- Agda.Utils.Lens: lSnd :: forall a b f. Functor f => (b -> f b) -> (a, b) -> f (a, b)
- Agda.Utils.Lens: locally' :: ((o -> o) -> m a -> m a) -> Lens' o i -> (i -> i) -> m a -> m a
- Agda.Utils.Lens: type Lens' o i = forall (f :: Type -> Type). Functor f => i -> f i -> o -> f o
- Agda.Utils.ListT: instance (GHC.Base.Applicative m, Control.Monad.IO.Class.MonadIO m) => Control.Monad.IO.Class.MonadIO (Agda.Utils.ListT.ListT m)
- Agda.Utils.ListT: instance (GHC.Base.Applicative m, Control.Monad.Reader.Class.MonadReader r m) => Control.Monad.Reader.Class.MonadReader r (Agda.Utils.ListT.ListT m)
- Agda.Utils.ListT: instance (GHC.Base.Applicative m, Control.Monad.State.Class.MonadState s m) => Control.Monad.State.Class.MonadState s (Agda.Utils.ListT.ListT m)
- Agda.Utils.ListT: instance (GHC.Base.Functor m, GHC.Base.Applicative m, GHC.Base.Monad m) => GHC.Base.Alternative (Agda.Utils.ListT.ListT m)
- Agda.Utils.ListT: instance (GHC.Base.Functor m, GHC.Base.Applicative m, GHC.Base.Monad m) => GHC.Base.Applicative (Agda.Utils.ListT.ListT m)
- Agda.Utils.ListT: instance (GHC.Base.Functor m, GHC.Base.Applicative m, GHC.Base.Monad m) => GHC.Base.Monad (Agda.Utils.ListT.ListT m)
- Agda.Utils.ListT: instance (GHC.Base.Functor m, GHC.Base.Applicative m, GHC.Base.Monad m) => GHC.Base.MonadPlus (Agda.Utils.ListT.ListT m)
- Agda.Utils.ProfileOptions: Constraints :: ProfileOption
- Agda.Utils.ProfileOptions: Conversion :: ProfileOption
- Agda.Utils.ProfileOptions: Definitions :: ProfileOption
- Agda.Utils.ProfileOptions: Instances :: 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 Agda.Utils.Null.Null Agda.Utils.ProfileOptions.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.RangeMap: PairInt :: Pair Int a -> PairInt a
- Agda.Utils.RangeMap: newtype PairInt a
- Agda.Utils.Semigroup: (<>) :: Semigroup a => a -> a -> a
- Agda.Utils.Semigroup: class Semigroup a
- Agda.Utils.Semigroup: infixr 6 <>
- Agda.Utils.Singleton: instance (GHC.Classes.Eq k, Data.Hashable.Class.Hashable k) => Agda.Utils.Singleton.Collection (k, a) (Data.HashMap.Internal.HashMap k a)
- Agda.Utils.Singleton: instance (GHC.Classes.Eq k, Data.Hashable.Class.Hashable k) => Agda.Utils.Singleton.Collection k (Data.HashSet.Internal.HashSet k)
- Agda.Utils.SmallSet: instance Agda.Utils.SmallSet.SmallSetElement a => Agda.Utils.Null.Null (Agda.Utils.SmallSet.SmallSet a)
- Agda.Utils.SmallSet: instance Agda.Utils.SmallSet.SmallSetElement a => GHC.Base.Monoid (Agda.Utils.SmallSet.SmallSet a)
- Agda.Utils.SmallSet: instance Agda.Utils.SmallSet.SmallSetElement a => GHC.Base.Semigroup (Agda.Utils.SmallSet.SmallSet a)
- Agda.Utils.Tuple: (-*-) :: (a -> c) -> (b -> d) -> (a, b) -> (c, d)
- Agda.Utils.Tuple: (/\) :: (a -> b) -> (a -> c) -> a -> (b, c)
- Agda.Utils.Tuple: infix 2 -*-
- Agda.Utils.Tuple: infix 3 /\
- Agda.Utils.Tuple: mapFst :: (a -> c) -> (a, b) -> (c, b)
- Agda.Utils.Tuple: mapFstM :: Functor m => (a -> m c) -> (a, b) -> m (c, b)
- Agda.Utils.Tuple: mapSnd :: (b -> d) -> (a, b) -> (a, d)
- Agda.Utils.Tuple: mapSndM :: Functor m => (b -> m d) -> (a, b) -> m (a, d)
- Agda.Utils.VarSet: filter :: (Key -> Bool) -> IntSet -> IntSet
- Agda.Utils.VarSet: mapMonotonic :: (Key -> Key) -> IntSet -> IntSet
- Agda.Utils.VarSet: subtract :: Int -> VarSet -> VarSet
- Agda.Utils.VarSet: toList :: IntSet -> [Key]
- Agda.Utils.VarSet: type VarSet = IntSet
- Agda.Utils.WithDefault: mapValue :: forall a (b :: Bool). Boolean a => (a -> a) -> WithDefault' a b -> WithDefault' a b
+ Agda.Benchmarking: ApplySection :: Phase
+ Agda.Benchmarking: CubicalLeftInversion :: Phase
+ Agda.Benchmarking: InverseInScope :: Phase
+ Agda.Benchmarking: InverseInScopeRecompute :: Phase
+ Agda.Benchmarking: InverseModuleLookup :: Phase
+ Agda.Benchmarking: InverseNameLookup :: Phase
+ Agda.Benchmarking: InverseNameModuleRecompute :: Phase
+ Agda.Benchmarking: Polarity :: Phase
+ Agda.Compiler.JS.Compiler: compileCaseNoPragma :: EnvWithOpts -> Int -> TTerm -> [TAlt] -> TCM Exp
+ Agda.Compiler.JS.Compiler: compileCaseWithPragma :: String -> EnvWithOpts -> Int -> [TAlt] -> TCM Exp
+ Agda.Compiler.JS.Compiler: undefinedPrimitives :: Set PrimitiveId
+ Agda.Compiler.JS.Substitution: curriedApply' :: Exp -> [Exp] -> Exp
+ Agda.Compiler.JS.Syntax: MemberIdInString :: MemberId -> Exp
+ Agda.Compiler.JS.Syntax: Ternary :: Exp -> Exp -> Exp -> Exp
+ Agda.Compiler.MAlonzo.Misc: [optGhcTrace] :: GHCOptions -> Bool
+ Agda.Compiler.MAlonzo.Pragmas: type GHCImport = String
+ Agda.Compiler.MAlonzo.Pragmas: type GHCPragma = String
+ Agda.Compiler.MAlonzo.Primitives: charBuiltins :: [SomeBuiltin]
+ Agda.Compiler.MAlonzo.Primitives: floatBuiltins :: [SomeBuiltin]
+ Agda.Compiler.MAlonzo.Primitives: usedBuiltins :: BuiltinThings -> [Definition] -> Set SomeBuiltin
+ Agda.Compiler.ToTreeless: mkDefaultCCConfig :: EvaluationStrategy -> CCConfig
+ Agda.Compiler.Treeless.EliminateDefaults: eliminateCaseDefaultAtTopLevelIfPresent :: TTerm -> TCM TTerm
+ Agda.Compiler.Treeless.EliminateDefaults: trAlt :: TAlt -> TCM TAlt
+ Agda.Compiler.Treeless.Pretty: instance Agda.Syntax.Common.Pretty.Pretty Agda.Syntax.Treeless.TAlt
+ Agda.Interaction.Base: [theCurrentFilePath] :: CommandState -> Maybe AbsolutePath
+ Agda.Interaction.BasicOps: computeInCurrent :: ComputeMode -> Expr -> TCM Expr
+ Agda.Interaction.BasicOps: prettyGoals :: Goals -> TCM Doc
+ Agda.Interaction.BasicOps: withComputeIgnoreAbstract :: MonadTCEnv m => ComputeMode -> m a -> m a
+ Agda.Interaction.BuildLibrary: printAccumulatedWarnings :: TCM ()
+ Agda.Interaction.Emacs.Lisp: A :: a -> Lisp a
+ Agda.Interaction.Emacs.Lisp: Cons :: Lisp a -> Lisp a -> Lisp a
+ Agda.Interaction.Emacs.Lisp: L :: [Lisp a] -> Lisp a
+ Agda.Interaction.Emacs.Lisp: Q :: Lisp a -> Lisp a
+ Agda.Interaction.Emacs.Lisp: data Lisp a
+ Agda.Interaction.Emacs.Lisp: instance Agda.Syntax.Common.Pretty.Pretty a => Agda.Syntax.Common.Pretty.Pretty (Agda.Interaction.Emacs.Lisp.Lisp a)
+ Agda.Interaction.Emacs.Lisp: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.Interaction.Emacs.Lisp.Lisp a)
+ Agda.Interaction.Emacs.Lisp: putResponse :: Lisp String -> IO ()
+ Agda.Interaction.Emacs.Lisp: response :: Lisp String -> String
+ Agda.Interaction.EmacsCommand: displayInfo :: String -> DocTree -> Bool -> Maybe ModuleToSource -> Lisp String
+ Agda.Interaction.EmacsCommand: displayVerboseInfo :: DocTree -> Maybe ModuleToSource -> Lisp String
+ Agda.Interaction.EmacsTop: prettyGoals :: Goals -> TCM Doc
+ Agda.Interaction.EmacsTop: prettyInferredType :: CommandState -> Expr -> TCM Doc
+ Agda.Interaction.EmacsTop: prettyInfoError :: Info_Error -> TCM Doc
+ Agda.Interaction.EmacsTop: prettyNormalForm :: CommandState -> ComputeMode -> Expr -> TCM Doc
+ Agda.Interaction.Highlighting.Emacs: lispifyHighlightingInfo_ :: ModuleToSource -> HighlightingInfo -> [Lisp String]
+ Agda.Interaction.Highlighting.Emacs: type HighlightingInfo = RangeMap Aspects
+ Agda.Interaction.Highlighting.HTML.Forester: renderForesterHtml :: Html -> Text
+ Agda.Interaction.Highlighting.LaTeX.Backend: latexBackendName :: BackendName
+ Agda.Interaction.Highlighting.Precise: URL :: Text -> Aspect
+ Agda.Interaction.Imports: MainInterface :: Mode -> MainInterface
+ Agda.Interaction.Imports: NotMainInterface :: MainInterface
+ Agda.Interaction.Imports: chaseModule :: TCWorkers -> TopLevelModuleName -> MainInterface -> Maybe Source -> TCM (TCM ModuleInfo)
+ Agda.Interaction.Imports: data MainInterface
+ Agda.Interaction.Imports: data TCWorkers
+ Agda.Interaction.Imports: scopeCheckFileImport :: TopLevelModuleName -> TCM (ModuleName, Map ModuleName Scope)
+ Agda.Interaction.Imports: setOptionsFromSourcePragmas :: Bool -> Source -> TCM ()
+ Agda.Interaction.Imports: wantsParallelChecking :: TCM (Maybe TCWorkers)
+ Agda.Interaction.InteractionTop: parseExprFromAuto :: InteractionId -> Range -> String -> (Expr -> CommandM a) -> CommandM (Either String a)
+ Agda.Interaction.InteractionTop: syncInteractionRange :: (MonadInteractionPoints m, MonadDebug m, MonadError TCErr m) => InteractionId -> Range -> m Range
+ Agda.Interaction.JSON: instance Agda.Interaction.JSON.EncodeTCM Agda.Syntax.Common.Pretty.DocTree
+ Agda.Interaction.JSON: instance Data.Aeson.Types.ToJSON.ToJSON Agda.Syntax.Common.Pretty.DocTree
+ Agda.Interaction.JSONTop: instance (Agda.Interaction.JSON.EncodeTCM a, Agda.Interaction.JSON.EncodeTCM b) => Agda.Interaction.JSON.EncodeTCM (Agda.Interaction.Output.OutputConstraint b a)
+ Agda.Interaction.JSONTop: instance Agda.Interaction.JSON.EncodeTCM Agda.Syntax.Abstract.Expr
+ Agda.Interaction.JSONTop: instance Agda.Interaction.JSON.EncodeTCM Agda.Syntax.Concrete.Expr
+ Agda.Interaction.JSONTop: instance Data.Aeson.Types.ToJSON.ToJSON Agda.Syntax.Concrete.Expr
+ Agda.Interaction.Library: [_libDependsPos] :: AgdaLibFile -> Map LibName LibFilePos
+ Agda.Interaction.Library.Base: LibDepNode :: Text -> Maybe Text -> LibDepNode
+ Agda.Interaction.Library.Base: LibFilePos :: !LineNumber -> !ColumnNumber -> !ColumnNumber -> LibFilePos
+ Agda.Interaction.Library.Base: LibraryVersionConflict :: Text -> LibDepTree -> [(Text, FilePath, Maybe LibFilePos)] -> LibWarning'
+ Agda.Interaction.Library.Base: [_libDependsPos] :: AgdaLibFile -> Map LibName LibFilePos
+ Agda.Interaction.Library.Base: [depLabel] :: LibDepNode -> Text
+ Agda.Interaction.Library.Base: [depResolvedAs] :: LibDepNode -> Maybe Text
+ Agda.Interaction.Library.Base: [lfpEndCol] :: LibFilePos -> !ColumnNumber
+ Agda.Interaction.Library.Base: [lfpLine] :: LibFilePos -> !LineNumber
+ Agda.Interaction.Library.Base: [lfpStartCol] :: LibFilePos -> !ColumnNumber
+ Agda.Interaction.Library.Base: data LibDepNode
+ Agda.Interaction.Library.Base: data LibFilePos
+ Agda.Interaction.Library.Base: instance Agda.Syntax.Common.Pretty.Pretty Agda.Interaction.Library.Base.LibDepNode
+ Agda.Interaction.Library.Base: instance Agda.Syntax.Common.Pretty.Pretty Agda.Interaction.Library.Base.LibFilePos
+ Agda.Interaction.Library.Base: instance Control.DeepSeq.NFData Agda.Interaction.Library.Base.LibDepNode
+ Agda.Interaction.Library.Base: instance Control.DeepSeq.NFData Agda.Interaction.Library.Base.LibFilePos
+ Agda.Interaction.Library.Base: instance GHC.Generics.Generic Agda.Interaction.Library.Base.LibDepNode
+ Agda.Interaction.Library.Base: instance GHC.Generics.Generic Agda.Interaction.Library.Base.LibFilePos
+ Agda.Interaction.Library.Base: instance GHC.Show.Show Agda.Interaction.Library.Base.LibDepNode
+ Agda.Interaction.Library.Base: instance GHC.Show.Show Agda.Interaction.Library.Base.LibFilePos
+ Agda.Interaction.Library.Base: libDepRootLabel :: Text
+ Agda.Interaction.Library.Base: prettyLibDepTree :: LibDepTree -> Doc
+ Agda.Interaction.Library.Base: type ColumnNumber = Int
+ Agda.Interaction.Library.Base: type LibDepTree = Tree LibDepNode
+ Agda.Interaction.Library.Parse: instance GHC.Show.Show Agda.Interaction.Library.Parse.ContentLine
+ Agda.Interaction.MakeCase: RevealDotPattern :: Name -> SplitAction
+ Agda.Interaction.MakeCase: RevealHiddenVariable :: Int -> SplitAction
+ Agda.Interaction.MakeCase: SplitOnVariable :: Int -> SplitAction
+ Agda.Interaction.MakeCase: data SplitAction
+ Agda.Interaction.MakeCase: filterOutGeneralizedVarPatterns :: [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
+ Agda.Interaction.MakeCase: instance GHC.Show.Show Agda.Interaction.MakeCase.SplitAction
+ Agda.Interaction.MakeCase: isGeneralizedVarName :: PatVarName -> Bool
+ Agda.Interaction.MakeCase: makeNamedArgUserWritten :: NamedArg a -> NamedArg a
+ Agda.Interaction.MakeCase: splitActionToEither3 :: SplitAction -> Either3 Name Int Int
+ Agda.Interaction.Options: LocalRewritingConfluenceCheck :: OptionWarning
+ Agda.Interaction.Options: Parallel :: Maybe Int -> Parallelism
+ Agda.Interaction.Options: Sequential :: Parallelism
+ Agda.Interaction.Options: [_optFunext] :: PragmaOptions -> WithDefault 'False
+ Agda.Interaction.Options: [_optIrrelevance] :: PragmaOptions -> WithDefault 'True
+ Agda.Interaction.Options: [_optLocalRewriting] :: PragmaOptions -> WithDefault 'False
+ Agda.Interaction.Options: [_optOccurrence] :: PragmaOptions -> WithDefault 'True
+ Agda.Interaction.Options: [_optPropext] :: PragmaOptions -> WithDefault 'False
+ Agda.Interaction.Options: [_optQuoteMetas] :: PragmaOptions -> WithDefault 'False
+ Agda.Interaction.Options: [_optQuotients] :: PragmaOptions -> WithDefault 'False
+ Agda.Interaction.Options: [optMdOnlyAgdaBlocks] :: CommandLineOptions -> Bool
+ Agda.Interaction.Options: [optParallelChecking] :: CommandLineOptions -> Parallelism
+ Agda.Interaction.Options: [optPrintOptions] :: CommandLineOptions -> Bool
+ Agda.Interaction.Options: [optWriteInterfaces] :: CommandLineOptions -> Bool
+ Agda.Interaction.Options: data Parallelism
+ Agda.Interaction.Options: latexPragmaOptions :: (String, [OptDescr (Flag PragmaOptions)])
+ Agda.Interaction.Options: lensOptIrrelevance :: Functor f => (WithDefault 'True -> f (WithDefault 'True)) -> PragmaOptions -> f PragmaOptions
+ Agda.Interaction.Options: lensOptLocalRewriting :: Functor f => (WithDefault 'False -> f (WithDefault 'False)) -> PragmaOptions -> f PragmaOptions
+ Agda.Interaction.Options: lensOptOccurrence :: Functor f => (WithDefault 'True -> f (WithDefault 'True)) -> PragmaOptions -> f PragmaOptions
+ Agda.Interaction.Options: optFunext :: PragmaOptions -> Bool
+ Agda.Interaction.Options: optIrrelevance :: PragmaOptions -> Bool
+ Agda.Interaction.Options: optLocalRewriting :: PragmaOptions -> Bool
+ Agda.Interaction.Options: optOccurrence :: PragmaOptions -> Bool
+ Agda.Interaction.Options: optPropext :: PragmaOptions -> Bool
+ Agda.Interaction.Options: optQuoteMetas :: PragmaOptions -> Bool
+ Agda.Interaction.Options: optQuotients :: PragmaOptions -> Bool
+ Agda.Interaction.Options: optionGroups :: [(String, [OptDescr (Flag CommandLineOptions)])]
+ Agda.Interaction.Options.Arguments: colorArg :: String
+ Agda.Interaction.Options.Arguments: colorValues :: [String]
+ Agda.Interaction.Options.Arguments: emacsModeArg :: String
+ Agda.Interaction.Options.Arguments: emacsModeValues :: [String]
+ Agda.Interaction.Options.Arguments: erasedMatchesArg :: String
+ Agda.Interaction.Options.Arguments: erasedMatchesValues :: [String]
+ Agda.Interaction.Options.Arguments: helpArg :: String
+ Agda.Interaction.Options.Arguments: helpValues :: [String]
+ Agda.Interaction.Options.Arguments: optionValues :: Map String [String]
+ Agda.Interaction.Options.Arguments: profileArg :: String
+ Agda.Interaction.Options.Arguments: profileValues :: [String]
+ Agda.Interaction.Options.Arguments: traceImportsArg :: String
+ Agda.Interaction.Options.Arguments: traceImportsValues :: [String]
+ Agda.Interaction.Options.Arguments: warningArg :: String
+ Agda.Interaction.Options.Arguments: warningValues :: [String]
+ Agda.Interaction.Options.BashCompletion: Completion :: Maybe String -> [(String, Help)] -> Completion
+ Agda.Interaction.Options.BashCompletion: [completions] :: Completion -> [(String, Help)]
+ Agda.Interaction.Options.BashCompletion: [extended] :: Completion -> Maybe String
+ Agda.Interaction.Options.BashCompletion: bashComplete :: Truncate -> [String] -> Either String String
+ Agda.Interaction.Options.BashCompletion: complete :: Truncate -> String -> Completion
+ Agda.Interaction.Options.BashCompletion: data Completion
+ Agda.Interaction.Options.BashCompletion: optionsTrie :: Trie Char Help
+ Agda.Interaction.Options.BashCompletion: printOptions :: [OptDescr a] -> [(String, Help)]
+ Agda.Interaction.Options.BashCompletion: printedOptions :: [String]
+ Agda.Interaction.Options.BashCompletion: printedOptionsWithHelp :: [(String, Help)]
+ Agda.Interaction.Options.BashCompletion: type Help = String
+ Agda.Interaction.Options.BashCompletion: type Truncate = Maybe Int
+ Agda.Interaction.Options.Default: defaultOptions :: CommandLineOptions
+ Agda.Interaction.Options.Default: defaultPragmaOptions :: PragmaOptions
+ Agda.Interaction.Options.Default: instance Agda.Utils.Null.Null Agda.Interaction.Options.Types.CommandLineOptions
+ Agda.Interaction.Options.Default: instance Agda.Utils.Null.Null Agda.Interaction.Options.Types.PragmaOptions
+ Agda.Interaction.Options.Errors: CannotGeneralizeEtaExpandable_ :: ErrorName
+ Agda.Interaction.Options.Errors: CannotGenerateTransportLocalRewrite_ :: ErrorName
+ Agda.Interaction.Options.Errors: CopatternsNotAllowed :: NotAValidLetBinding
+ Agda.Interaction.Options.Errors: ErasedMatchesDisabledDependent :: ErasedDatatypeReason
+ Agda.Interaction.Options.Errors: ErasedMatchesDisabledEmpty :: ErasedDatatypeReason
+ Agda.Interaction.Options.Errors: ErasedMatchesDisabledNonDependent :: ErasedDatatypeReason
+ Agda.Interaction.Options.Errors: EscapingVariable_ :: UnquoteError_
+ Agda.Interaction.Options.Errors: EtaPragmaVsNoEtaEquality_ :: ErrorName
+ Agda.Interaction.Options.Errors: GeneralizationFailed_ :: ErrorName
+ Agda.Interaction.Options.Errors: GeneralizationPrepruneErrorCyclicDependencies_ :: ErrorName
+ Agda.Interaction.Options.Errors: GeneralizationPrepruneErrorFailedToInstantiate_ :: ErrorName
+ Agda.Interaction.Options.Errors: GeneralizationPrepruneErrorRefinedContext_ :: ErrorName
+ Agda.Interaction.Options.Errors: IlltypedRewriteRule_ :: ErrorName
+ Agda.Interaction.Options.Errors: MissingBindingsForTelescopeVariables_ :: ErrorName
+ Agda.Interaction.Options.Errors: NamedWhereModuleUnderWith_ :: ErrorName
+ Agda.Interaction.Options.Errors: NeedOptionIrrelevance_ :: ErrorName
+ Agda.Interaction.Options.Errors: TrustedBuiltin_ :: ErrorName
+ Agda.Interaction.Options.Errors: TrustedPrimitive_ :: ErrorName
+ Agda.Interaction.Options.Errors: UnequalTypes_ :: ErrorName
+ Agda.Interaction.Options.Errors: UnguardedEtaRecord_ :: ErrorName
+ Agda.Interaction.Options.Errors: UserError_ :: ErrorName
+ Agda.Interaction.Options.Errors: WrongNamedArgumentInLHS_ :: ErrorName
+ Agda.Interaction.Options.Errors: instance GHC.Enum.Bounded a => GHC.Enum.Bounded (GHC.Maybe.Maybe a)
+ Agda.Interaction.Options.ProfileOptions: Constraints :: ProfileOption
+ Agda.Interaction.Options.ProfileOptions: Conversion :: ProfileOption
+ Agda.Interaction.Options.ProfileOptions: Definitions :: ProfileOption
+ Agda.Interaction.Options.ProfileOptions: Instances :: ProfileOption
+ Agda.Interaction.Options.ProfileOptions: Interactive :: ProfileOption
+ Agda.Interaction.Options.ProfileOptions: Internal :: ProfileOption
+ Agda.Interaction.Options.ProfileOptions: Metas :: ProfileOption
+ Agda.Interaction.Options.ProfileOptions: Modules :: ProfileOption
+ Agda.Interaction.Options.ProfileOptions: Sections :: ProfileOption
+ Agda.Interaction.Options.ProfileOptions: Serialize :: ProfileOption
+ Agda.Interaction.Options.ProfileOptions: Sharing :: ProfileOption
+ Agda.Interaction.Options.ProfileOptions: addProfileOption :: String -> ProfileOptions -> Either String ProfileOptions
+ Agda.Interaction.Options.ProfileOptions: containsProfileOption :: ProfileOption -> ProfileOptions -> Bool
+ Agda.Interaction.Options.ProfileOptions: data ProfileOption
+ Agda.Interaction.Options.ProfileOptions: data ProfileOptions
+ Agda.Interaction.Options.ProfileOptions: instance Agda.Utils.Null.Null Agda.Interaction.Options.ProfileOptions.ProfileOptions
+ Agda.Interaction.Options.ProfileOptions: instance Control.DeepSeq.NFData Agda.Interaction.Options.ProfileOptions.ProfileOption
+ Agda.Interaction.Options.ProfileOptions: instance Control.DeepSeq.NFData Agda.Interaction.Options.ProfileOptions.ProfileOptions
+ Agda.Interaction.Options.ProfileOptions: instance GHC.Classes.Eq Agda.Interaction.Options.ProfileOptions.ProfileOption
+ Agda.Interaction.Options.ProfileOptions: instance GHC.Classes.Eq Agda.Interaction.Options.ProfileOptions.ProfileOptions
+ Agda.Interaction.Options.ProfileOptions: instance GHC.Classes.Ord Agda.Interaction.Options.ProfileOptions.ProfileOption
+ Agda.Interaction.Options.ProfileOptions: instance GHC.Enum.Bounded Agda.Interaction.Options.ProfileOptions.ProfileOption
+ Agda.Interaction.Options.ProfileOptions: instance GHC.Enum.Enum Agda.Interaction.Options.ProfileOptions.ProfileOption
+ Agda.Interaction.Options.ProfileOptions: instance GHC.Generics.Generic Agda.Interaction.Options.ProfileOptions.ProfileOption
+ Agda.Interaction.Options.ProfileOptions: instance GHC.Show.Show Agda.Interaction.Options.ProfileOptions.ProfileOption
+ Agda.Interaction.Options.ProfileOptions: instance GHC.Show.Show Agda.Interaction.Options.ProfileOptions.ProfileOptions
+ Agda.Interaction.Options.ProfileOptions: noProfileOptions :: ProfileOptions
+ Agda.Interaction.Options.ProfileOptions: profileOptionsFromList :: [ProfileOption] -> ProfileOptions
+ Agda.Interaction.Options.ProfileOptions: profileOptionsToList :: ProfileOptions -> [ProfileOption]
+ Agda.Interaction.Options.ProfileOptions: validProfileOptionStrings :: [String]
+ Agda.Interaction.Options.Warnings: DefinitionBeforeDeclaration_ :: WarningName
+ Agda.Interaction.Options.Warnings: DivergentModalityInClause_ :: WarningName
+ Agda.Interaction.Options.Warnings: FixityDeclarationForNonOperator_ :: WarningName
+ Agda.Interaction.Options.Warnings: IllegalDeclarationInDataDefinition_ :: WarningName
+ Agda.Interaction.Options.Warnings: InferredLocalRewrite_ :: WarningName
+ Agda.Interaction.Options.Warnings: InvalidDataOrRecDefParameter_ :: WarningName
+ Agda.Interaction.Options.Warnings: InvalidEtaEqualityPragma_ :: WarningName
+ Agda.Interaction.Options.Warnings: InvalidTacticAttribute_ :: WarningName
+ Agda.Interaction.Options.Warnings: LibraryVersionConflict_ :: WarningName
+ Agda.Interaction.Options.Warnings: LocalRewriteOutsideTelescope_ :: WarningName
+ Agda.Interaction.Options.Warnings: LocalRewritingConfluenceCheck_ :: WarningName
+ Agda.Interaction.Options.Warnings: MismatchedBrackets_ :: WarningName
+ Agda.Interaction.Options.Warnings: MisplacedRewrite_ :: WarningName
+ Agda.Interaction.Options.Warnings: NoUnusedImportsAll :: WarningModeError
+ Agda.Interaction.Options.Warnings: RecursiveRecordNeedsInductivity_ :: WarningName
+ Agda.Interaction.Options.Warnings: RewriteVariablesBoundInSingleton_ :: WarningName
+ Agda.Interaction.Options.Warnings: ShouldBeEtaRecordPattern_ :: WarningName
+ Agda.Interaction.Options.Warnings: UnguardedEtaRecordW_ :: WarningName
+ Agda.Interaction.Options.Warnings: UnknownJSPrimitive_ :: WarningName
+ Agda.Interaction.Options.Warnings: UnusedImportsAll_ :: WarningName
+ Agda.Interaction.Options.Warnings: UnusedImports_ :: WarningName
+ Agda.Interaction.Options.Warnings: UselessImport_ :: WarningName
+ Agda.Interaction.Options.Warnings: unusedImportsWarnings :: Set WarningName
+ Agda.Interaction.Options.Warnings: warningNameToString :: WarningName -> String
+ Agda.Main: printOptions :: IO ()
+ Agda.Main: runAgdaArgs :: [Backend] -> [String] -> IO ()
+ Agda.Mimer.Monad: allOpenMetas :: (AllMetas t, ReadTCState tcm) => t -> tcm [MetaId]
+ Agda.Mimer.Monad: applyProj :: Args -> Component -> QName -> SM Component
+ Agda.Mimer.Monad: applyToMetas :: Nat -> Term -> Type -> TCM (Term, Type, [MetaId])
+ Agda.Mimer.Monad: applyToMetasG :: Maybe Nat -> Component -> SM Component
+ Agda.Mimer.Monad: assignMeta :: MetaId -> Term -> Type -> SM ()
+ Agda.Mimer.Monad: bench :: [Phase] -> SM a -> SM a
+ Agda.Mimer.Monad: branchInstantiationDoc :: SearchBranch -> SM Doc
+ Agda.Mimer.Monad: branchInstantiationDocCost :: SearchBranch -> SM Doc
+ Agda.Mimer.Monad: checkSolved :: SearchBranch -> SM SearchStepResult
+ Agda.Mimer.Monad: collectComponents :: Options -> Costs -> InteractionId -> Maybe QName -> [QName] -> MetaId -> TCM BaseComponents
+ Agda.Mimer.Monad: collectLHSVars :: (ReadTCState tcm, MonadError TCErr tcm, MonadTCM tcm, HasConstInfo tcm) => InteractionId -> tcm (Open [(Term, Maybe Int)])
+ Agda.Mimer.Monad: createMeta :: Type -> SM (MetaId, Term)
+ Agda.Mimer.Monad: customCosts :: TCM Costs
+ Agda.Mimer.Monad: declarationQnames :: Declaration -> [QName]
+ Agda.Mimer.Monad: dumbUnifier :: Type -> Type -> SM ()
+ Agda.Mimer.Monad: endsInLevelTester :: TCM (Type -> Bool)
+ Agda.Mimer.Monad: getEverythingInScope :: MetaVariable -> [QName]
+ Agda.Mimer.Monad: getLetVars :: (MonadFresh CompId tcm, MonadTCM tcm) => Cost -> tcm [Open Component]
+ Agda.Mimer.Monad: getLocalVarTerms :: Int -> TCM [(Term, Dom Type)]
+ Agda.Mimer.Monad: getLocalVars :: Int -> Cost -> TCM [Component]
+ Agda.Mimer.Monad: getMetaInstantiation :: (MonadTCM tcm, PureTCM tcm, MonadInteractionPoints tcm, MonadFresh NameId tcm) => MetaId -> tcm (Maybe Expr)
+ Agda.Mimer.Monad: getOpenComponent :: (MonadTCM tcm, MonadDebug tcm) => Open Component -> tcm Component
+ Agda.Mimer.Monad: getRecordFields :: HasConstInfo tcm => QName -> tcm [QName]
+ Agda.Mimer.Monad: getRecordInfo :: (MonadTCM tcm, HasConstInfo tcm) => Type -> tcm (Maybe (QName, Args, [QName], Bool))
+ Agda.Mimer.Monad: inGoalEnv :: Goal -> SM a -> SM a
+ Agda.Mimer.Monad: isTypeDatatype :: MonadTCM tcm => Type -> tcm Bool
+ Agda.Mimer.Monad: localVarCount :: SM Int
+ Agda.Mimer.Monad: makeSearchOptions :: Rewrite -> Options -> InteractionId -> TCM SearchOptions
+ Agda.Mimer.Monad: metaInstantiation :: (MonadDebug tcm, ReadTCState tcm) => MetaId -> tcm (Maybe Term)
+ Agda.Mimer.Monad: mimerTrace :: Int -> VerboseLevel -> SM Doc -> SM ()
+ Agda.Mimer.Monad: newComponent :: MonadFresh CompId m => [MetaId] -> Cost -> Maybe Name -> Nat -> Term -> Type -> m Component
+ Agda.Mimer.Monad: newComponentQ :: MonadFresh CompId m => [MetaId] -> Cost -> QName -> Nat -> Term -> Type -> m Component
+ Agda.Mimer.Monad: normaliseSolution :: Term -> SM Term
+ Agda.Mimer.Monad: partitionStepResult :: [SearchStepResult] -> SM ([SearchBranch], [MimerResult])
+ Agda.Mimer.Monad: prettyBranch :: SearchBranch -> SM String
+ Agda.Mimer.Monad: prettyGoalInst :: Goal -> SM Doc
+ Agda.Mimer.Monad: qnameToComponent :: (HasConstInfo tcm, ReadTCState tcm, MonadFresh CompId tcm) => Cost -> QName -> tcm Component
+ Agda.Mimer.Monad: reportSMDoc :: VerboseKey -> VerboseLevel -> SM Doc -> SM ()
+ Agda.Mimer.Monad: searchConstraintsSolved :: SM Bool
+ Agda.Mimer.Monad: solveSearchConstraints :: SM ()
+ Agda.Mimer.Monad: startSearchBranch :: [MetaId] -> TCM SearchBranch
+ Agda.Mimer.Monad: topInstantiationDoc :: SM Doc
+ Agda.Mimer.Monad: type SM a = ReaderT SearchOptions TCM a
+ Agda.Mimer.Monad: updateBranch :: [MetaId] -> SearchBranch -> SM SearchBranch
+ Agda.Mimer.Monad: updateBranch' :: Maybe Component -> [MetaId] -> SearchBranch -> SM SearchBranch
+ Agda.Mimer.Monad: updateBranchCost :: Component -> [MetaId] -> SearchBranch -> SM SearchBranch
+ Agda.Mimer.Monad: updateStat :: (MimerStats -> MimerStats) -> SM ()
+ Agda.Mimer.Monad: withBranchAndGoal :: SearchBranch -> Goal -> SM a -> SM a
+ Agda.Mimer.Monad: withBranchState :: SearchBranch -> SM a -> SM a
+ Agda.Mimer.Monad: writeTime :: (ReadTCState m, MonadError TCErr m, MonadTCM m, MonadDebug m) => InteractionId -> CPUTime -> m ()
+ Agda.Mimer.Types: BaseComponents :: [Component] -> [Component] -> [Component] -> [Component] -> [Component] -> [Component] -> Maybe Component -> [Component] -> [Open Component] -> Open [(Term, NoSubst Term Int)] -> BaseComponents
+ Agda.Mimer.Types: Component :: CompId -> Maybe Name -> Nat -> Term -> Type -> RecCall -> [MetaId] -> Cost -> Component
+ Agda.Mimer.Types: Costs :: Cost -> Cost -> Cost -> Cost -> Cost -> Cost -> Cost -> Cost -> Cost -> Cost -> Cost -> Cost -> Cost -> (Nat -> Cost) -> Costs
+ Agda.Mimer.Types: Goal :: MetaId -> Goal
+ Agda.Mimer.Types: MimerExpr :: String -> MimerResult
+ Agda.Mimer.Types: MimerList :: [(Int, String)] -> MimerResult
+ Agda.Mimer.Types: MimerNoResult :: MimerResult
+ Agda.Mimer.Types: MimerStats :: !Int -> !Int -> !Int -> !Int -> !Int -> !Int -> !Int -> !Int -> MimerStats
+ Agda.Mimer.Types: MutualCall :: RecCall
+ Agda.Mimer.Types: NoSolution :: SearchStepResult
+ Agda.Mimer.Types: NotRecCall :: RecCall
+ Agda.Mimer.Types: OpenBranch :: SearchBranch -> SearchStepResult
+ Agda.Mimer.Types: ResultExpr :: Expr -> SearchStepResult
+ Agda.Mimer.Types: SearchBranch :: TCState -> [Goal] -> Int -> Map CheckpointId ComponentCache -> Map Name Int -> SearchBranch
+ Agda.Mimer.Types: SearchOptions :: BaseComponents -> HintMode -> MilliSeconds -> Bool -> Bool -> Bool -> Bool -> Bool -> MetaId -> TCEnv -> CheckpointId -> ProblemId -> InteractionId -> Maybe QName -> Costs -> IORef MimerStats -> Rewrite -> Maybe QName -> SearchOptions
+ Agda.Mimer.Types: SelfCall :: RecCall
+ Agda.Mimer.Types: [compCost] :: Component -> Cost
+ Agda.Mimer.Types: [compId] :: Component -> CompId
+ Agda.Mimer.Types: [compMetas] :: Component -> [MetaId]
+ Agda.Mimer.Types: [compName] :: Component -> Maybe Name
+ Agda.Mimer.Types: [compPars] :: Component -> Nat
+ Agda.Mimer.Types: [compRec] :: Component -> RecCall
+ Agda.Mimer.Types: [compTerm] :: Component -> Term
+ Agda.Mimer.Types: [compType] :: Component -> Type
+ Agda.Mimer.Types: [costAxiom] :: Costs -> Cost
+ Agda.Mimer.Types: [costCompReuse] :: Costs -> Nat -> Cost
+ Agda.Mimer.Types: [costDataCon] :: Costs -> Cost
+ Agda.Mimer.Types: [costFn] :: Costs -> Cost
+ Agda.Mimer.Types: [costLet] :: Costs -> Cost
+ Agda.Mimer.Types: [costLevel] :: Costs -> Cost
+ Agda.Mimer.Types: [costLocal] :: Costs -> Cost
+ Agda.Mimer.Types: [costNewHiddenMeta] :: Costs -> Cost
+ Agda.Mimer.Types: [costNewMeta] :: Costs -> Cost
+ Agda.Mimer.Types: [costProj] :: Costs -> Cost
+ Agda.Mimer.Types: [costRecCall] :: Costs -> Cost
+ Agda.Mimer.Types: [costRecordCon] :: Costs -> Cost
+ Agda.Mimer.Types: [costSet] :: Costs -> Cost
+ Agda.Mimer.Types: [costSpeculateProj] :: Costs -> Cost
+ Agda.Mimer.Types: [goalMeta] :: Goal -> MetaId
+ Agda.Mimer.Types: [hintAxioms] :: BaseComponents -> [Component]
+ Agda.Mimer.Types: [hintDataTypes] :: BaseComponents -> [Component]
+ Agda.Mimer.Types: [hintFns] :: BaseComponents -> [Component]
+ Agda.Mimer.Types: [hintLetVars] :: BaseComponents -> [Open Component]
+ Agda.Mimer.Types: [hintLevel] :: BaseComponents -> [Component]
+ Agda.Mimer.Types: [hintMutualFns] :: BaseComponents -> [Component]
+ Agda.Mimer.Types: [hintProjections] :: BaseComponents -> [Component]
+ Agda.Mimer.Types: [hintRecVars] :: BaseComponents -> Open [(Term, NoSubst Term Int)]
+ Agda.Mimer.Types: [hintRecordTypes] :: BaseComponents -> [Component]
+ Agda.Mimer.Types: [hintThisFn] :: BaseComponents -> Maybe Component
+ Agda.Mimer.Types: [sbCache] :: SearchBranch -> Map CheckpointId ComponentCache
+ Agda.Mimer.Types: [sbComponentsUsed] :: SearchBranch -> Map Name Int
+ Agda.Mimer.Types: [sbCost] :: SearchBranch -> Int
+ Agda.Mimer.Types: [sbGoals] :: SearchBranch -> [Goal]
+ Agda.Mimer.Types: [sbTCState] :: SearchBranch -> TCState
+ Agda.Mimer.Types: [searchBaseComponents] :: SearchOptions -> BaseComponents
+ Agda.Mimer.Types: [searchBuiltinFlat] :: SearchOptions -> Maybe QName
+ Agda.Mimer.Types: [searchCosts] :: SearchOptions -> Costs
+ Agda.Mimer.Types: [searchFnName] :: SearchOptions -> Maybe QName
+ Agda.Mimer.Types: [searchGenProjectionsExternal] :: SearchOptions -> Bool
+ Agda.Mimer.Types: [searchGenProjectionsLet] :: SearchOptions -> Bool
+ Agda.Mimer.Types: [searchGenProjectionsLocal] :: SearchOptions -> Bool
+ Agda.Mimer.Types: [searchGenProjectionsRec] :: SearchOptions -> Bool
+ Agda.Mimer.Types: [searchHintMode] :: SearchOptions -> HintMode
+ Agda.Mimer.Types: [searchInteractionId] :: SearchOptions -> InteractionId
+ Agda.Mimer.Types: [searchProblem] :: SearchOptions -> ProblemId
+ Agda.Mimer.Types: [searchRewrite] :: SearchOptions -> Rewrite
+ Agda.Mimer.Types: [searchSpeculateProjections] :: SearchOptions -> Bool
+ Agda.Mimer.Types: [searchStats] :: SearchOptions -> IORef MimerStats
+ Agda.Mimer.Types: [searchTimeout] :: SearchOptions -> MilliSeconds
+ Agda.Mimer.Types: [searchTopCheckpoint] :: SearchOptions -> CheckpointId
+ Agda.Mimer.Types: [searchTopEnv] :: SearchOptions -> TCEnv
+ Agda.Mimer.Types: [searchTopMeta] :: SearchOptions -> MetaId
+ Agda.Mimer.Types: [statCompGen] :: MimerStats -> !Int
+ Agda.Mimer.Types: [statCompHit] :: MimerStats -> !Int
+ Agda.Mimer.Types: [statCompNoRegen] :: MimerStats -> !Int
+ Agda.Mimer.Types: [statCompRegen] :: MimerStats -> !Int
+ Agda.Mimer.Types: [statMetasCreated] :: MimerStats -> !Int
+ Agda.Mimer.Types: [statRefineFail] :: MimerStats -> !Int
+ Agda.Mimer.Types: [statRefineSuccess] :: MimerStats -> !Int
+ Agda.Mimer.Types: [statTypeEqChecks] :: MimerStats -> !Int
+ Agda.Mimer.Types: addCost :: Cost -> Component -> Component
+ Agda.Mimer.Types: data BaseComponents
+ Agda.Mimer.Types: data Component
+ Agda.Mimer.Types: data Costs
+ Agda.Mimer.Types: data Goal
+ Agda.Mimer.Types: data MimerResult
+ Agda.Mimer.Types: data MimerStats
+ Agda.Mimer.Types: data RecCall
+ Agda.Mimer.Types: data SearchBranch
+ Agda.Mimer.Types: data SearchOptions
+ Agda.Mimer.Types: data SearchStepResult
+ Agda.Mimer.Types: defaultCosts :: Costs
+ Agda.Mimer.Types: deleteCompMeta :: MetaId -> Component -> Component
+ Agda.Mimer.Types: emptyMimerStats :: MimerStats
+ Agda.Mimer.Types: haskellRecord :: Doc -> [(Doc, Doc)] -> Doc
+ Agda.Mimer.Types: incCompGen :: MimerStats -> MimerStats
+ Agda.Mimer.Types: incCompHit :: MimerStats -> MimerStats
+ Agda.Mimer.Types: incCompNoRegen :: MimerStats -> MimerStats
+ Agda.Mimer.Types: incCompRegen :: MimerStats -> MimerStats
+ Agda.Mimer.Types: incMetasCreated :: MimerStats -> MimerStats
+ Agda.Mimer.Types: incRefineFail :: MimerStats -> MimerStats
+ Agda.Mimer.Types: incRefineSuccess :: MimerStats -> MimerStats
+ Agda.Mimer.Types: incTypeEqChecks :: MimerStats -> MimerStats
+ Agda.Mimer.Types: instance Agda.Syntax.Common.Pretty.Pretty Agda.Mimer.Types.BaseComponents
+ Agda.Mimer.Types: instance Agda.Syntax.Common.Pretty.Pretty Agda.Mimer.Types.Component
+ Agda.Mimer.Types: instance Agda.Syntax.Common.Pretty.Pretty Agda.Mimer.Types.Costs
+ Agda.Mimer.Types: instance Agda.Syntax.Common.Pretty.Pretty Agda.Mimer.Types.Goal
+ Agda.Mimer.Types: instance Agda.Syntax.Common.Pretty.Pretty Agda.Mimer.Types.SearchBranch
+ Agda.Mimer.Types: instance Agda.Syntax.Common.Pretty.Pretty Agda.Mimer.Types.SearchOptions
+ Agda.Mimer.Types: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Mimer.Types.BaseComponents
+ Agda.Mimer.Types: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Mimer.Types.Component
+ Agda.Mimer.Types: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Mimer.Types.MimerResult
+ Agda.Mimer.Types: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Mimer.Types.SearchOptions
+ Agda.Mimer.Types: instance Control.DeepSeq.NFData Agda.Mimer.Types.BaseComponents
+ Agda.Mimer.Types: instance Control.DeepSeq.NFData Agda.Mimer.Types.Component
+ Agda.Mimer.Types: instance Control.DeepSeq.NFData Agda.Mimer.Types.Goal
+ Agda.Mimer.Types: instance Control.DeepSeq.NFData Agda.Mimer.Types.MimerResult
+ Agda.Mimer.Types: instance Control.DeepSeq.NFData Agda.Mimer.Types.MimerStats
+ Agda.Mimer.Types: instance Control.DeepSeq.NFData Agda.Mimer.Types.RecCall
+ Agda.Mimer.Types: instance Control.DeepSeq.NFData Agda.Mimer.Types.SearchBranch
+ Agda.Mimer.Types: instance Control.DeepSeq.NFData Agda.Mimer.Types.SearchStepResult
+ Agda.Mimer.Types: instance GHC.Classes.Eq Agda.Mimer.Types.Component
+ Agda.Mimer.Types: instance GHC.Classes.Eq Agda.Mimer.Types.Goal
+ Agda.Mimer.Types: instance GHC.Classes.Eq Agda.Mimer.Types.MimerStats
+ Agda.Mimer.Types: instance GHC.Classes.Eq Agda.Mimer.Types.RecCall
+ Agda.Mimer.Types: instance GHC.Classes.Eq Agda.Mimer.Types.SearchBranch
+ Agda.Mimer.Types: instance GHC.Classes.Ord Agda.Mimer.Types.Component
+ Agda.Mimer.Types: instance GHC.Classes.Ord Agda.Mimer.Types.SearchBranch
+ Agda.Mimer.Types: instance GHC.Generics.Generic Agda.Mimer.Types.BaseComponents
+ Agda.Mimer.Types: instance GHC.Generics.Generic Agda.Mimer.Types.Component
+ Agda.Mimer.Types: instance GHC.Generics.Generic Agda.Mimer.Types.Goal
+ Agda.Mimer.Types: instance GHC.Generics.Generic Agda.Mimer.Types.MimerResult
+ Agda.Mimer.Types: instance GHC.Generics.Generic Agda.Mimer.Types.MimerStats
+ Agda.Mimer.Types: instance GHC.Generics.Generic Agda.Mimer.Types.RecCall
+ Agda.Mimer.Types: instance GHC.Generics.Generic Agda.Mimer.Types.SearchBranch
+ Agda.Mimer.Types: instance GHC.Generics.Generic Agda.Mimer.Types.SearchStepResult
+ Agda.Mimer.Types: instance GHC.Show.Show Agda.Mimer.Types.MimerStats
+ Agda.Mimer.Types: instance GHC.Show.Show Agda.Mimer.Types.RecCall
+ Agda.Mimer.Types: isNoResult :: MimerResult -> Bool
+ Agda.Mimer.Types: keyValueList :: [(Doc, Doc)] -> Doc
+ Agda.Mimer.Types: mkComponent :: CompId -> [MetaId] -> Cost -> Maybe Name -> Nat -> Term -> Type -> Component
+ Agda.Mimer.Types: mkComponentQ :: CompId -> Cost -> QName -> Nat -> Term -> Type -> Component
+ Agda.Mimer.Types: nextGoal :: SearchBranch -> (Goal, SearchBranch)
+ Agda.Mimer.Types: noCost :: Cost
+ Agda.Mimer.Types: noName :: Maybe Name
+ Agda.Mimer.Types: type CompId = Int
+ Agda.Mimer.Types: type ComponentCache = Map Component Maybe [Component]
+ Agda.Mimer.Types: type Cost = Int
+ Agda.Setup.LockFile: withLockFile :: FilePath -> IO a -> IO a
+ Agda.Syntax.Abstract: ($dmanyAbstract) :: forall (t :: Type -> Type) b. (AnyAbstract a, Foldable t, AnyAbstract b, t b ~ a) => a -> Bool
+ Agda.Syntax.Abstract: ForeignPragma :: Ranged BackendName -> String -> Pragma
+ Agda.Syntax.Abstract: Highlighted :: Aspects -> Expr -> Expr
+ Agda.Syntax.Abstract: PatternSynDefn :: ![WithHiding Name] -> !Pattern' Void -> PatternSynDefn
+ Agda.Syntax.Abstract: Qualified :: ModuleName -> Expr -> Expr
+ Agda.Syntax.Abstract: [patSynParams] :: PatternSynDefn -> ![WithHiding Name]
+ Agda.Syntax.Abstract: [patSynPat] :: PatternSynDefn -> !Pattern' Void
+ Agda.Syntax.Abstract: data PatternSynDefn
+ Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.AnyAbstract a => Agda.Syntax.Abstract.AnyAbstract (Agda.Utils.List1.List1 a)
+ Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.NameToExpr Agda.Syntax.Abstract.Name.AbstractName
+ Agda.Syntax.Abstract: instance Agda.Syntax.Position.KillRange Agda.Syntax.Abstract.PatternSynDefn
+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.PatternSynDefn
+ Agda.Syntax.Abstract: instance GHC.Generics.Generic Agda.Syntax.Abstract.PatternSynDefn
+ Agda.Syntax.Abstract: instance GHC.Show.Show Agda.Syntax.Abstract.PatternSynDefn
+ Agda.Syntax.Abstract: renamingSize :: Ren a -> Int
+ Agda.Syntax.Abstract.Name: AbsModule :: ModuleName -> WhyInScope -> AbstractModule
+ Agda.Syntax.Abstract.Name: AbsName :: QName -> KindOfName -> WhyInScope -> NameMetadata -> AbstractName
+ Agda.Syntax.Abstract.Name: AmbAbstractName :: AbstractName -> AmbQNameEntry
+ Agda.Syntax.Abstract.Name: AmbQName :: QName -> AmbQNameEntry
+ Agda.Syntax.Abstract.Name: Applied :: QName -> WhyInScope -> WhyInScope
+ Agda.Syntax.Abstract.Name: AxiomName :: KindOfName
+ Agda.Syntax.Abstract.Name: CoConName :: KindOfName
+ Agda.Syntax.Abstract.Name: ConName :: KindOfName
+ Agda.Syntax.Abstract.Name: DataName :: KindOfName
+ Agda.Syntax.Abstract.Name: Defined :: WhyInScope
+ Agda.Syntax.Abstract.Name: DisallowedGeneralizeName :: KindOfName
+ Agda.Syntax.Abstract.Name: FldName :: KindOfName
+ Agda.Syntax.Abstract.Name: FunName :: KindOfName
+ Agda.Syntax.Abstract.Name: GeneralizeName :: KindOfName
+ Agda.Syntax.Abstract.Name: MacroName :: KindOfName
+ Agda.Syntax.Abstract.Name: NameMetadata :: Map QName Name -> IsInstance -> NameMetadata
+ Agda.Syntax.Abstract.Name: Opened :: QName -> WhyInScope -> WhyInScope
+ Agda.Syntax.Abstract.Name: OtherDefName :: KindOfName
+ Agda.Syntax.Abstract.Name: PatternSynName :: KindOfName
+ Agda.Syntax.Abstract.Name: PrimName :: KindOfName
+ Agda.Syntax.Abstract.Name: QuotableName :: KindOfName
+ Agda.Syntax.Abstract.Name: RecName :: KindOfName
+ Agda.Syntax.Abstract.Name: [_nameBindingSite] :: Name -> Range
+ Agda.Syntax.Abstract.Name: [_nameId] :: Name -> {-# UNPACK #-} !NameId
+ Agda.Syntax.Abstract.Name: [amodLineage] :: AbstractModule -> WhyInScope
+ Agda.Syntax.Abstract.Name: [amodName] :: AbstractModule -> ModuleName
+ Agda.Syntax.Abstract.Name: [anameKind] :: AbstractName -> KindOfName
+ Agda.Syntax.Abstract.Name: [anameLineage] :: AbstractName -> WhyInScope
+ Agda.Syntax.Abstract.Name: [anameMetadata] :: AbstractName -> NameMetadata
+ Agda.Syntax.Abstract.Name: [anameName] :: AbstractName -> QName
+ Agda.Syntax.Abstract.Name: [nameDataGeneralizedVars] :: NameMetadata -> Map QName Name
+ Agda.Syntax.Abstract.Name: [nameDataIsInstance] :: NameMetadata -> IsInstance
+ Agda.Syntax.Abstract.Name: ambAbstractNames :: AmbiguousQName -> [AbstractName]
+ Agda.Syntax.Abstract.Name: ambigName :: List1 AbstractName -> AmbiguousQName
+ Agda.Syntax.Abstract.Name: ambiguous :: List1 QName -> AmbiguousQName
+ Agda.Syntax.Abstract.Name: class HasNameBindingSite a
+ Agda.Syntax.Abstract.Name: class HasNameId a
+ Agda.Syntax.Abstract.Name: data AbstractModule
+ Agda.Syntax.Abstract.Name: data AbstractName
+ Agda.Syntax.Abstract.Name: data AmbQNameEntry
+ Agda.Syntax.Abstract.Name: data KindOfName
+ Agda.Syntax.Abstract.Name: data NameMetadata
+ Agda.Syntax.Abstract.Name: data WhyInScope
+ Agda.Syntax.Abstract.Name: dropAnonymousModules :: ModuleName -> ModuleName
+ Agda.Syntax.Abstract.Name: fromAmbQName :: AmbQNameEntry -> QName
+ Agda.Syntax.Abstract.Name: generalizedVarsMetadata :: Map QName Name -> NameMetadata
+ Agda.Syntax.Abstract.Name: getAmbiguous :: AmbiguousQName -> List1 QName
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Abstract.Name.HasNameBindingSite Agda.Syntax.Abstract.Name.AbstractModule
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Abstract.Name.HasNameBindingSite Agda.Syntax.Abstract.Name.AbstractName
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Abstract.Name.HasNameBindingSite Agda.Syntax.Abstract.Name.ModuleName
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Abstract.Name.HasNameBindingSite Agda.Syntax.Abstract.Name.Name
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Abstract.Name.HasNameBindingSite Agda.Syntax.Abstract.Name.QName
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Abstract.Name.HasNameId Agda.Syntax.Abstract.Name.AbstractName
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Abstract.Name.HasNameId Agda.Syntax.Abstract.Name.Name
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Abstract.Name.HasNameId Agda.Syntax.Abstract.Name.QName
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Common.IsInstanceDef Agda.Syntax.Abstract.Name.AbstractName
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Common.IsInstanceDef Agda.Syntax.Abstract.Name.NameMetadata
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Common.LensFixity Agda.Syntax.Abstract.Name.AbstractName
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Common.Pretty.Pretty Agda.Syntax.Abstract.Name.AbstractModule
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Common.Pretty.Pretty Agda.Syntax.Abstract.Name.AbstractName
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Common.Pretty.Pretty Agda.Syntax.Abstract.Name.Suffix
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Position.HasRange Agda.Syntax.Abstract.Name.AbstractName
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Position.HasRange Agda.Syntax.Abstract.Name.AmbQNameEntry
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Position.KillRange Agda.Syntax.Abstract.Name.AbstractName
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Position.KillRange Agda.Syntax.Abstract.Name.AmbQNameEntry
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Position.KillRange Agda.Syntax.Abstract.Name.KindOfName
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Position.KillRange Agda.Syntax.Abstract.Name.NameMetadata
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Position.KillRange Agda.Syntax.Abstract.Name.WhyInScope
+ Agda.Syntax.Abstract.Name: instance Agda.Syntax.Position.SetRange Agda.Syntax.Abstract.Name.AbstractName
+ Agda.Syntax.Abstract.Name: instance Agda.Utils.Null.Null Agda.Syntax.Abstract.Name.Name
+ Agda.Syntax.Abstract.Name: instance Agda.Utils.Null.Null Agda.Syntax.Abstract.Name.NameMetadata
+ Agda.Syntax.Abstract.Name: instance Agda.Utils.Null.Null Agda.Syntax.Abstract.Name.QName
+ Agda.Syntax.Abstract.Name: instance Agda.Utils.Size.Sized Agda.Syntax.Abstract.Name.AmbiguousQName
+ Agda.Syntax.Abstract.Name: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.Name.AbstractModule
+ Agda.Syntax.Abstract.Name: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.Name.AbstractName
+ Agda.Syntax.Abstract.Name: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.Name.AmbQNameEntry
+ Agda.Syntax.Abstract.Name: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.Name.KindOfName
+ Agda.Syntax.Abstract.Name: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.Name.NameMetadata
+ Agda.Syntax.Abstract.Name: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.Name.WhyInScope
+ Agda.Syntax.Abstract.Name: instance Data.Hashable.Class.Hashable Agda.Syntax.Abstract.Name.AbstractName
+ Agda.Syntax.Abstract.Name: instance Data.Hashable.Class.Hashable Agda.Syntax.Abstract.Name.ModuleName
+ Agda.Syntax.Abstract.Name: instance GHC.Base.Semigroup Agda.Syntax.Abstract.Name.AmbQNameEntry
+ Agda.Syntax.Abstract.Name: instance GHC.Classes.Eq Agda.Syntax.Abstract.Name.AbstractModule
+ Agda.Syntax.Abstract.Name: instance GHC.Classes.Eq Agda.Syntax.Abstract.Name.AbstractName
+ Agda.Syntax.Abstract.Name: instance GHC.Classes.Eq Agda.Syntax.Abstract.Name.AmbQNameEntry
+ Agda.Syntax.Abstract.Name: instance GHC.Classes.Eq Agda.Syntax.Abstract.Name.KindOfName
+ Agda.Syntax.Abstract.Name: instance GHC.Classes.Ord Agda.Syntax.Abstract.Name.AbstractModule
+ Agda.Syntax.Abstract.Name: instance GHC.Classes.Ord Agda.Syntax.Abstract.Name.AbstractName
+ Agda.Syntax.Abstract.Name: instance GHC.Classes.Ord Agda.Syntax.Abstract.Name.AmbQNameEntry
+ Agda.Syntax.Abstract.Name: instance GHC.Classes.Ord Agda.Syntax.Abstract.Name.KindOfName
+ Agda.Syntax.Abstract.Name: instance GHC.Enum.Bounded Agda.Syntax.Abstract.Name.KindOfName
+ Agda.Syntax.Abstract.Name: instance GHC.Enum.Enum Agda.Syntax.Abstract.Name.KindOfName
+ Agda.Syntax.Abstract.Name: instance GHC.Generics.Generic Agda.Syntax.Abstract.Name.AbstractModule
+ Agda.Syntax.Abstract.Name: instance GHC.Generics.Generic Agda.Syntax.Abstract.Name.AbstractName
+ Agda.Syntax.Abstract.Name: instance GHC.Generics.Generic Agda.Syntax.Abstract.Name.AmbQNameEntry
+ Agda.Syntax.Abstract.Name: instance GHC.Generics.Generic Agda.Syntax.Abstract.Name.KindOfName
+ Agda.Syntax.Abstract.Name: instance GHC.Generics.Generic Agda.Syntax.Abstract.Name.NameMetadata
+ Agda.Syntax.Abstract.Name: instance GHC.Generics.Generic Agda.Syntax.Abstract.Name.QName
+ Agda.Syntax.Abstract.Name: instance GHC.Generics.Generic Agda.Syntax.Abstract.Name.WhyInScope
+ Agda.Syntax.Abstract.Name: instance GHC.Show.Show Agda.Syntax.Abstract.Name.AbstractModule
+ Agda.Syntax.Abstract.Name: instance GHC.Show.Show Agda.Syntax.Abstract.Name.AbstractName
+ Agda.Syntax.Abstract.Name: instance GHC.Show.Show Agda.Syntax.Abstract.Name.AmbQNameEntry
+ Agda.Syntax.Abstract.Name: instance GHC.Show.Show Agda.Syntax.Abstract.Name.KindOfName
+ Agda.Syntax.Abstract.Name: instance GHC.Show.Show Agda.Syntax.Abstract.Name.NameMetadata
+ Agda.Syntax.Abstract.Name: instance GHC.Show.Show Agda.Syntax.Abstract.Name.WhyInScope
+ Agda.Syntax.Abstract.Name: instanceMetadata :: IsInstance -> NameMetadata
+ Agda.Syntax.Abstract.Name: lensAmodName :: Lens' AbstractModule ModuleName
+ Agda.Syntax.Abstract.Name: lensAnameName :: Lens' AbstractName QName
+ Agda.Syntax.Abstract.Name: mergeAmbQ :: AmbiguousQName -> AmbiguousQName -> AmbiguousQName
+ Agda.Syntax.Abstract.Name: nameBindingSite :: HasNameBindingSite a => a -> Range
+ Agda.Syntax.Abstract.Name: nameId :: HasNameId a => a -> NameId
+ Agda.Syntax.Abstract.Name: noMetadata :: NameMetadata
+ Agda.Syntax.Abstract.Name: unambigName :: AbstractName -> AmbiguousQName
+ Agda.Syntax.Abstract.UsedNames: allBoundNames :: BoundAndUsed a => a -> Set Name
+ Agda.Syntax.Abstract.Views: class DeepUnscopeDecls (t :: Type -> Type)
+ Agda.Syntax.Abstract.Views: instance (Agda.Syntax.Abstract.Views.ExprLike qn, Agda.Syntax.Abstract.Views.ExprLike p, Agda.Syntax.Abstract.Views.ExprLike e) => Agda.Syntax.Abstract.Views.ExprLike (Agda.Syntax.Common.RewriteEqn' qn nm p e)
+ Agda.Syntax.Abstract.Views: instance Agda.Syntax.Abstract.Views.DeepUnscopeDecls Agda.Utils.List1.List1
+ Agda.Syntax.Abstract.Views: instance Agda.Syntax.Abstract.Views.DeepUnscopeDecls []
+ Agda.Syntax.Builtin: BuiltinQuotientConstructor :: BuiltinId
+ Agda.Syntax.Builtin: PrimQrec :: PrimitiveId
+ Agda.Syntax.Builtin: PrimRewriteNoMatch :: PrimitiveId
+ Agda.Syntax.Builtin: builtinQuotientConstructor :: BuiltinId
+ Agda.Syntax.Builtin: builtinRewriteNoMatch :: PrimitiveId
+ Agda.Syntax.Common: AllowedErasedMatches :: !Bool -> !Bool -> !Maybe AllowedErasedMatchesIndexed -> AllowedErasedMatches
+ Agda.Syntax.Common: CWithoutGlue :: Cubical
+ Agda.Syntax.Common: ConversionFail :: Origin
+ Agda.Syntax.Common: ErasedMatches :: AllowedErasedMatches -> AllowedErasedMatchesWithDefaults
+ Agda.Syntax.Common: ErasedMatchesDefault :: AllowedErasedMatchesWithDefaults
+ Agda.Syntax.Common: ErasedMatchesDefaultOn :: AllowedErasedMatchesWithDefaults
+ Agda.Syntax.Common: IsData :: DataOrRecord' p
+ Agda.Syntax.Common: IsNotRewrite :: RewriteAnn
+ Agda.Syntax.Common: IsRecord :: p -> DataOrRecord' p
+ Agda.Syntax.Common: IsRewrite :: Range -> RewriteAnn
+ Agda.Syntax.Common: NoForceRecordEta :: ForceRecordEta
+ Agda.Syntax.Common: NotHIT :: IsHIT
+ Agda.Syntax.Common: RecordSelf :: Origin
+ Agda.Syntax.Common: Restricted :: AllowedErasedMatchesIndexed
+ Agda.Syntax.Common: Sharp :: Cohesion
+ Agda.Syntax.Common: Unrestricted :: AllowedErasedMatchesIndexed
+ Agda.Syntax.Common: YesForceRecordEta :: ForceRecordEta
+ Agda.Syntax.Common: YesHIT :: IsHIT
+ Agda.Syntax.Common: [annRewrite] :: Annotation -> RewriteAnn
+ Agda.Syntax.Common: [emDependent] :: AllowedErasedMatches -> !Maybe AllowedErasedMatchesIndexed
+ Agda.Syntax.Common: [emEmpty] :: AllowedErasedMatches -> !Bool
+ Agda.Syntax.Common: [emNonDependent] :: AllowedErasedMatches -> !Bool
+ Agda.Syntax.Common: class IsInstanceDef a
+ Agda.Syntax.Common: class LensRewriteAnn a
+ Agda.Syntax.Common: data AllowedErasedMatches
+ Agda.Syntax.Common: data AllowedErasedMatchesIndexed
+ Agda.Syntax.Common: data AllowedErasedMatchesWithDefaults
+ Agda.Syntax.Common: data DataOrRecord' p
+ Agda.Syntax.Common: data ForceRecordEta
+ Agda.Syntax.Common: data IsHIT
+ Agda.Syntax.Common: data RewriteAnn
+ Agda.Syntax.Common: defaultRewrite :: RewriteAnn
+ Agda.Syntax.Common: emRestricted :: AllowedErasedMatches -> Bool
+ Agda.Syntax.Common: emUnrestricted :: AllowedErasedMatches -> Bool
+ Agda.Syntax.Common: getRewriteAnn :: LensRewriteAnn a => a -> RewriteAnn
+ Agda.Syntax.Common: ignoreRew :: (Monad m, LensRewriteAnn a) => (RewriteAnn -> m ()) -> a -> m a
+ Agda.Syntax.Common: instance (Agda.Syntax.Position.HasRange qn, Agda.Syntax.Position.HasRange p, Agda.Syntax.Position.HasRange e) => Agda.Syntax.Position.HasRange (Agda.Syntax.Common.RewriteEqn' qn nm p e)
+ Agda.Syntax.Common: instance Agda.Syntax.Common.CopatternMatchingAllowed Agda.Syntax.Common.DataOrRecord
+ Agda.Syntax.Common: instance Agda.Syntax.Common.IsInstanceDef Agda.Syntax.Common.IsInstance
+ Agda.Syntax.Common: instance Agda.Syntax.Common.LensRewriteAnn (Agda.Syntax.Common.Arg t)
+ Agda.Syntax.Common: instance Agda.Syntax.Common.LensRewriteAnn Agda.Syntax.Common.ArgInfo
+ Agda.Syntax.Common: instance Agda.Syntax.Common.LensRewriteAnn Agda.Syntax.Common.RewriteAnn
+ Agda.Syntax.Common: instance Agda.Syntax.Common.PatternMatchingAllowed Agda.Syntax.Common.DataOrRecord
+ Agda.Syntax.Common: instance Agda.Syntax.Common.Pretty.Pretty Agda.Syntax.Common.Fixity'
+ Agda.Syntax.Common: instance Agda.Syntax.Common.Pretty.Pretty Agda.Syntax.Common.NotationPart
+ Agda.Syntax.Common: instance Agda.Syntax.Common.Pretty.Pretty Agda.Syntax.Common.RewriteAnn
+ Agda.Syntax.Common: instance Agda.Syntax.Position.HasRange (Agda.Syntax.Common.ImportDirective' a b)
+ Agda.Syntax.Common: instance Agda.Syntax.Position.HasRange Agda.Syntax.Common.Fixity'
+ Agda.Syntax.Common: instance Agda.Syntax.Position.HasRange Agda.Syntax.Common.RewriteAnn
+ Agda.Syntax.Common: instance Agda.Syntax.Position.KillRange Agda.Syntax.Common.ForceRecordEta
+ Agda.Syntax.Common: instance Agda.Syntax.Position.KillRange Agda.Syntax.Common.IsHIT
+ Agda.Syntax.Common: instance Agda.Syntax.Position.KillRange Agda.Syntax.Common.RewriteAnn
+ Agda.Syntax.Common: instance Agda.Syntax.Position.KillRange a => Agda.Syntax.Position.KillRange (Agda.Syntax.Common.DataOrRecord' a)
+ Agda.Syntax.Common: instance Agda.Syntax.Position.SetRange Agda.Syntax.Common.RewriteAnn
+ Agda.Syntax.Common: instance Agda.Utils.Boolean.Boolean Agda.Syntax.Common.DataOrRecord_
+ Agda.Syntax.Common: instance Agda.Utils.Boolean.Boolean Agda.Syntax.Common.IsHIT
+ Agda.Syntax.Common: instance Agda.Utils.Boolean.IsBool Agda.Syntax.Common.DataOrRecord_
+ Agda.Syntax.Common: instance Agda.Utils.Boolean.IsBool Agda.Syntax.Common.IsHIT
+ Agda.Syntax.Common: instance Agda.Utils.Null.Null Agda.Syntax.Common.ForceRecordEta
+ Agda.Syntax.Common: instance Agda.Utils.Null.Null Agda.Syntax.Common.IsInstance
+ Agda.Syntax.Common: instance Agda.Utils.Null.Null Agda.Syntax.Common.NameId
+ Agda.Syntax.Common: instance Agda.Utils.Null.Null Agda.Syntax.Common.PositivityCheck
+ Agda.Syntax.Common: instance Agda.Utils.Null.Null Agda.Syntax.Common.RewriteAnn
+ Agda.Syntax.Common: instance Agda.Utils.Null.Null Agda.Syntax.Common.UniverseCheck
+ Agda.Syntax.Common: instance Agda.Utils.SmallSet.SmallSetElement Agda.Syntax.Common.Origin
+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.AllowedErasedMatches
+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.AllowedErasedMatchesIndexed
+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.AllowedErasedMatchesWithDefaults
+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.ForceRecordEta
+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.IsHIT
+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.RewriteAnn
+ Agda.Syntax.Common: instance GHC.Base.Monoid (Agda.Syntax.Common.ImportDirective' n m)
+ Agda.Syntax.Common: instance GHC.Base.Monoid Agda.Syntax.Common.AllowedErasedMatches
+ Agda.Syntax.Common: instance GHC.Base.Monoid Agda.Syntax.Common.AllowedErasedMatchesIndexed
+ Agda.Syntax.Common: instance GHC.Base.Monoid Agda.Syntax.Common.AllowedErasedMatchesWithDefaults
+ Agda.Syntax.Common: instance GHC.Base.Monoid Agda.Syntax.Common.ForceRecordEta
+ Agda.Syntax.Common: instance GHC.Base.Monoid Agda.Syntax.Common.UniverseCheck
+ Agda.Syntax.Common: instance GHC.Base.Semigroup (Agda.Syntax.Common.ImportDirective' n m)
+ Agda.Syntax.Common: instance GHC.Base.Semigroup Agda.Syntax.Common.AllowedErasedMatches
+ Agda.Syntax.Common: instance GHC.Base.Semigroup Agda.Syntax.Common.AllowedErasedMatchesIndexed
+ Agda.Syntax.Common: instance GHC.Base.Semigroup Agda.Syntax.Common.AllowedErasedMatchesWithDefaults
+ Agda.Syntax.Common: instance GHC.Base.Semigroup Agda.Syntax.Common.ForceRecordEta
+ Agda.Syntax.Common: instance GHC.Base.Semigroup Agda.Syntax.Common.UniverseCheck
+ Agda.Syntax.Common: instance GHC.Classes.Eq Agda.Syntax.Common.AllowedErasedMatches
+ Agda.Syntax.Common: instance GHC.Classes.Eq Agda.Syntax.Common.AllowedErasedMatchesIndexed
+ Agda.Syntax.Common: instance GHC.Classes.Eq Agda.Syntax.Common.AllowedErasedMatchesWithDefaults
+ Agda.Syntax.Common: instance GHC.Classes.Eq Agda.Syntax.Common.ForceRecordEta
+ Agda.Syntax.Common: instance GHC.Classes.Eq Agda.Syntax.Common.IsHIT
+ Agda.Syntax.Common: instance GHC.Classes.Eq Agda.Syntax.Common.RewriteAnn
+ Agda.Syntax.Common: instance GHC.Classes.Eq p => GHC.Classes.Eq (Agda.Syntax.Common.DataOrRecord' p)
+ Agda.Syntax.Common: instance GHC.Classes.Ord Agda.Syntax.Common.AllowedErasedMatches
+ Agda.Syntax.Common: instance GHC.Classes.Ord Agda.Syntax.Common.AllowedErasedMatchesIndexed
+ Agda.Syntax.Common: instance GHC.Classes.Ord Agda.Syntax.Common.ForceRecordEta
+ Agda.Syntax.Common: instance GHC.Classes.Ord Agda.Syntax.Common.IsHIT
+ Agda.Syntax.Common: instance GHC.Classes.Ord Agda.Syntax.Common.RewriteAnn
+ Agda.Syntax.Common: instance GHC.Enum.Bounded Agda.Syntax.Common.ForceRecordEta
+ Agda.Syntax.Common: instance GHC.Enum.Bounded Agda.Syntax.Common.Origin
+ Agda.Syntax.Common: instance GHC.Enum.Enum Agda.Syntax.Common.ForceRecordEta
+ Agda.Syntax.Common: instance GHC.Enum.Enum Agda.Syntax.Common.Origin
+ Agda.Syntax.Common: instance GHC.Generics.Generic (Agda.Syntax.Common.DataOrRecord' p)
+ Agda.Syntax.Common: instance GHC.Generics.Generic Agda.Syntax.Common.AllowedErasedMatches
+ Agda.Syntax.Common: instance GHC.Generics.Generic Agda.Syntax.Common.AllowedErasedMatchesIndexed
+ Agda.Syntax.Common: instance GHC.Generics.Generic Agda.Syntax.Common.AllowedErasedMatchesWithDefaults
+ Agda.Syntax.Common: instance GHC.Generics.Generic Agda.Syntax.Common.ForceRecordEta
+ Agda.Syntax.Common: instance GHC.Generics.Generic Agda.Syntax.Common.IsHIT
+ Agda.Syntax.Common: instance GHC.Generics.Generic Agda.Syntax.Common.RewriteAnn
+ Agda.Syntax.Common: instance GHC.Ix.Ix Agda.Syntax.Common.Origin
+ Agda.Syntax.Common: instance GHC.Show.Show Agda.Syntax.Common.AllowedErasedMatches
+ Agda.Syntax.Common: instance GHC.Show.Show Agda.Syntax.Common.AllowedErasedMatchesIndexed
+ Agda.Syntax.Common: instance GHC.Show.Show Agda.Syntax.Common.AllowedErasedMatchesWithDefaults
+ Agda.Syntax.Common: instance GHC.Show.Show Agda.Syntax.Common.ForceRecordEta
+ Agda.Syntax.Common: instance GHC.Show.Show Agda.Syntax.Common.IsHIT
+ Agda.Syntax.Common: instance GHC.Show.Show Agda.Syntax.Common.RewriteAnn
+ Agda.Syntax.Common: instance GHC.Show.Show p => GHC.Show.Show (Agda.Syntax.Common.DataOrRecord' p)
+ Agda.Syntax.Common: isInstanceDef :: IsInstanceDef a => a -> Maybe KwRange
+ Agda.Syntax.Common: isKindPattern :: ExprKind -> Bool
+ Agda.Syntax.Common: isRewrite :: LensRewriteAnn a => a -> Bool
+ Agda.Syntax.Common: mapRewriteAnn :: LensRewriteAnn a => (RewriteAnn -> RewriteAnn) -> a -> a
+ Agda.Syntax.Common: noinlineEqModality :: Modality -> Modality -> Bool
+ Agda.Syntax.Common: pattern IsRecord_ :: DataOrRecord_
+ Agda.Syntax.Common: prettyRewriteAnn :: LensRewriteAnn a => a -> Doc -> Doc
+ Agda.Syntax.Common: setRewriteAnn :: LensRewriteAnn a => RewriteAnn -> a -> a
+ Agda.Syntax.Common: type DataOrRecord = DataOrRecord' PatternOrCopattern
+ Agda.Syntax.Common: type DataOrRecordEta = DataOrRecord' ForceRecordEta
+ Agda.Syntax.Common: type DataOrRecord_ = DataOrRecord' ()
+ Agda.Syntax.Common: unArgKeepHiding :: Arg a -> WithHiding a
+ Agda.Syntax.Common.Aspect: URL :: Text -> Aspect
+ Agda.Syntax.Common.Aspect: instance Agda.Utils.Null.Null Agda.Syntax.Common.Aspect.Aspects
+ Agda.Syntax.Common.Aspect: instance Agda.Utils.Null.Null Agda.Syntax.Common.Aspect.TokenBased
+ Agda.Syntax.Common.Aspect: instance Control.DeepSeq.NFData Agda.Syntax.Common.Aspect.Aspect
+ Agda.Syntax.Common.Aspect: instance Control.DeepSeq.NFData Agda.Syntax.Common.Aspect.Aspects
+ Agda.Syntax.Common.Aspect: instance Control.DeepSeq.NFData Agda.Syntax.Common.Aspect.DefinitionSite
+ Agda.Syntax.Common.Aspect: instance Control.DeepSeq.NFData Agda.Syntax.Common.Aspect.OtherAspect
+ Agda.Syntax.Common.Aspect: instance Control.DeepSeq.NFData Agda.Syntax.Common.Aspect.TokenBased
+ Agda.Syntax.Common.Aspect: instance GHC.Generics.Generic Agda.Syntax.Common.Aspect.Induction
+ Agda.Syntax.Common.Aspect: instance GHC.Generics.Generic Agda.Syntax.Common.Aspect.TokenBased
+ Agda.Syntax.Common.Aspect: rangeDefinitionSite :: HasRange a => a -> Aspects
+ Agda.Syntax.Common.Pretty: TreeGlyphs :: Doc -> Doc -> Doc -> Doc -> TreeGlyphs
+ Agda.Syntax.Common.Pretty: [treeBranch] :: TreeGlyphs -> Doc
+ Agda.Syntax.Common.Pretty: [treeContinue] :: TreeGlyphs -> Doc
+ Agda.Syntax.Common.Pretty: [treeEmpty] :: TreeGlyphs -> Doc
+ Agda.Syntax.Common.Pretty: [treeLastBranch] :: TreeGlyphs -> Doc
+ Agda.Syntax.Common.Pretty: data TreeGlyphs
+ Agda.Syntax.Common.Pretty: definedAt :: HasRange a => Doc -> a -> Doc
+ Agda.Syntax.Common.Pretty: githubIssue :: Int -> Doc
+ Agda.Syntax.Common.Pretty: hlArgument :: Doc -> Doc
+ Agda.Syntax.Common.Pretty: hlBound :: Doc -> Doc
+ Agda.Syntax.Common.Pretty: hlConstructor :: Induction -> Doc -> Doc
+ Agda.Syntax.Common.Pretty: hlDatatype :: Doc -> Doc
+ Agda.Syntax.Common.Pretty: hlField :: Doc -> Doc
+ Agda.Syntax.Common.Pretty: hlFunction :: Doc -> Doc
+ Agda.Syntax.Common.Pretty: hlGeneralizable :: Doc -> Doc
+ Agda.Syntax.Common.Pretty: hlMacro :: Doc -> Doc
+ Agda.Syntax.Common.Pretty: hlModule :: Doc -> Doc
+ Agda.Syntax.Common.Pretty: hlNameKind :: NameKind -> Doc -> Doc
+ Agda.Syntax.Common.Pretty: hlPostulate :: Doc -> Doc
+ Agda.Syntax.Common.Pretty: hlPrimitive :: Doc -> Doc
+ Agda.Syntax.Common.Pretty: hlRecord :: Doc -> Doc
+ Agda.Syntax.Common.Pretty: href :: Text -> Doc -> Doc
+ Agda.Syntax.Common.Pretty: instance (a GHC.Types.~ Agda.Syntax.Common.Aspect.Aspects) => Agda.Syntax.Common.Pretty.Pretty (Agda.Utils.DocTree.DocTree a)
+ Agda.Syntax.Common.Pretty: instance Agda.Syntax.Common.Pretty.Pretty a => Agda.Syntax.Common.Pretty.Pretty (Agda.Syntax.Position.Interval' a)
+ Agda.Syntax.Common.Pretty: instance Agda.Syntax.Common.Pretty.Pretty a => Agda.Syntax.Common.Pretty.Pretty (Agda.Syntax.Position.Range' a)
+ Agda.Syntax.Common.Pretty: instance Agda.Syntax.Common.Pretty.Pretty a => Agda.Syntax.Common.Pretty.Pretty (Agda.Utils.List2.List2 a)
+ Agda.Syntax.Common.Pretty: instance Agda.Syntax.Common.Pretty.Pretty a => Agda.Syntax.Common.Pretty.Pretty (Data.Strict.Maybe.Maybe a)
+ Agda.Syntax.Common.Pretty: pipe :: Doc
+ Agda.Syntax.Common.Pretty: prettyInterval :: Eq a => Position' a -> Position' a -> Doc
+ Agda.Syntax.Common.Pretty: prettyTree :: Pretty a => TreeGlyphs -> Tree a -> Doc
+ Agda.Syntax.Common.Pretty: twords :: Text -> [Doc]
+ Agda.Syntax.Common.Pretty: type DocTree = DocTree Aspects
+ Agda.Syntax.Common.Pretty: url :: String -> Doc
+ Agda.Syntax.Common.Pretty.ANSI: printTreeAnsi :: DocTree -> IO ()
+ Agda.Syntax.Common.Pretty.ANSI: putDocLn :: (MonadIO m, HasOptions m) => Doc -> m ()
+ Agda.Syntax.Common.Pretty.ANSI: putDocTree :: (MonadIO m, HasOptions m) => DocTree -> m ()
+ Agda.Syntax.Common.Pretty.ANSI: putDocTreeLn :: (MonadIO m, HasOptions m) => DocTree -> m ()
+ Agda.Syntax.Concrete: CannotBeProjectionPattern :: PossiblyProjectionPattern
+ Agda.Syntax.Concrete: CouldBeProjectionPattern :: PossiblyProjectionPattern
+ Agda.Syntax.Concrete: EtaEqualityPragma :: Range -> Pragma
+ Agda.Syntax.Concrete: Highlighted :: Aspects -> Expr -> Expr
+ Agda.Syntax.Concrete: [modName] :: Module -> QName
+ Agda.Syntax.Concrete: data PossiblyProjectionPattern
+ Agda.Syntax.Concrete: defParametersToParameters :: DefParameters -> Parameters
+ Agda.Syntax.Concrete: instance Agda.Syntax.Position.HasRange Agda.Syntax.Concrete.OpenShortHand
+ Agda.Syntax.Concrete: instance Agda.Syntax.Position.KillRange Agda.Syntax.Concrete.OpenShortHand
+ Agda.Syntax.Concrete: instance Agda.Utils.Null.Null Agda.Syntax.Concrete.OpenShortHand
+ Agda.Syntax.Concrete: instance GHC.Classes.Eq Agda.Syntax.Concrete.PossiblyProjectionPattern
+ Agda.Syntax.Concrete: instance GHC.Show.Show Agda.Syntax.Concrete.PossiblyProjectionPattern
+ Agda.Syntax.Concrete: parametersToDefParameters :: Parameters -> DefParameters
+ Agda.Syntax.Concrete: parametersToTelescope :: Range -> Parameters -> Telescope
+ Agda.Syntax.Concrete: type DefParameters = [WithHiding Named_ Name]
+ Agda.Syntax.Concrete: type Parameters = [LamBinding]
+ Agda.Syntax.Concrete: type RawOpenArgs = [Expr]
+ Agda.Syntax.Concrete.Attribute: RewriteAttribute :: RewriteAnn -> Attribute
+ Agda.Syntax.Concrete.Attribute: isRewriteAttribute :: Attribute -> Maybe RewriteAnn
+ Agda.Syntax.Concrete.Attribute: rewAttributes :: [Attribute] -> [Attribute]
+ Agda.Syntax.Concrete.Attribute: rewriteAttributeTable :: [(String, RewriteAnn)]
+ Agda.Syntax.Concrete.Attribute: setPristineRewriteAnn :: LensRewriteAnn a => RewriteAnn -> a -> Maybe a
+ Agda.Syntax.Concrete.Definitions: DivergentModalityInClause :: ArgInfo -> ArgInfo -> DeclarationWarning'
+ Agda.Syntax.Concrete.Definitions: FixityDeclarationForNonOperator :: Range -> Name -> DeclarationWarning'
+ Agda.Syntax.Concrete.Definitions: InvalidDataOrRecDefParameter :: Range -> DataOrRecord_ -> Text -> Text -> DeclarationWarning'
+ Agda.Syntax.Concrete.Definitions: InvalidEtaEqualityPragma :: Range -> DeclarationWarning'
+ Agda.Syntax.Concrete.Definitions: InvalidRewriteAttribute :: Range -> DeclarationWarning'
+ Agda.Syntax.Concrete.Definitions: InvalidTacticAttribute :: Range -> DeclarationWarning'
+ Agda.Syntax.Concrete.Definitions: UselessImport :: Range -> DeclarationWarning'
+ Agda.Syntax.Concrete.Definitions: instance Agda.Syntax.Concrete.Definitions.MakeAbstract a => Agda.Syntax.Concrete.Definitions.MakeAbstract (Agda.Utils.List1.List1 a)
+ Agda.Syntax.Concrete.Definitions: instance Agda.Syntax.Concrete.Definitions.MakePrivate a => Agda.Syntax.Concrete.Definitions.MakePrivate (Agda.Utils.List1.List1 a)
+ Agda.Syntax.Concrete.Definitions.Errors: DivergentModalityInClause :: ArgInfo -> ArgInfo -> DeclarationWarning'
+ Agda.Syntax.Concrete.Definitions.Errors: FixityDeclarationForNonOperator :: Range -> Name -> DeclarationWarning'
+ Agda.Syntax.Concrete.Definitions.Errors: InvalidDataOrRecDefParameter :: Range -> DataOrRecord_ -> Text -> Text -> DeclarationWarning'
+ Agda.Syntax.Concrete.Definitions.Errors: InvalidEtaEqualityPragma :: Range -> DeclarationWarning'
+ Agda.Syntax.Concrete.Definitions.Errors: InvalidRewriteAttribute :: Range -> DeclarationWarning'
+ Agda.Syntax.Concrete.Definitions.Errors: InvalidTacticAttribute :: Range -> DeclarationWarning'
+ Agda.Syntax.Concrete.Definitions.Errors: UselessImport :: Range -> DeclarationWarning'
+ Agda.Syntax.Concrete.Definitions.Monad: [_forceEta] :: NiceState -> ForceRecordEta
+ Agda.Syntax.Concrete.Definitions.Monad: etaEqualityPragma :: Lens' NiceState ForceRecordEta
+ Agda.Syntax.Concrete.Definitions.Monad: type INice = StateT InterleavedState Nice
+ Agda.Syntax.Concrete.Definitions.Monad: withEtaEqualityPragma :: ForceRecordEta -> Nice a -> Nice a
+ Agda.Syntax.Concrete.Definitions.Types: ISt :: InterleavedMutual -> MutualChecks -> DeclNum -> InterleavedState
+ Agda.Syntax.Concrete.Definitions.Types: [_kindForceEta] :: DataRecOrFun -> ForceRecordEta
+ Agda.Syntax.Concrete.Definitions.Types: [interleavedCurrentDeclNum] :: InterleavedState -> DeclNum
+ Agda.Syntax.Concrete.Definitions.Types: [interleavedMutualChecks] :: InterleavedState -> MutualChecks
+ Agda.Syntax.Concrete.Definitions.Types: [interleavedMutual] :: InterleavedState -> InterleavedMutual
+ Agda.Syntax.Concrete.Definitions.Types: data InterleavedState
+ Agda.Syntax.Concrete.Definitions.Types: forceRecordEta :: DataRecOrFun -> ForceRecordEta
+ Agda.Syntax.Concrete.Definitions.Types: instance Agda.Syntax.Common.LensArgInfo Agda.Syntax.Concrete.Definitions.Types.Clause
+ Agda.Syntax.Concrete.Definitions.Types: instance Agda.Syntax.Position.HasRange Agda.Syntax.Concrete.Definitions.Types.InterleavedDecl
+ Agda.Syntax.Concrete.Definitions.Types: mergeDataRecOrFun :: DataRecOrFun -> DataRecOrFun -> Maybe DataRecOrFun
+ Agda.Syntax.Concrete.Fixity: warnFixityDeclarationForNonOperator :: MonadFixityError m => Range -> Name -> m ()
+ Agda.Syntax.Concrete.Generic: instance Agda.Syntax.Concrete.Generic.FoldDecl Agda.Syntax.Concrete.Module
+ Agda.Syntax.Concrete.Glyph: [_fromArrow] :: SpecialCharacters -> Doc
+ Agda.Syntax.Concrete.Glyph: [_treeBranch] :: SpecialCharacters -> Doc
+ Agda.Syntax.Concrete.Glyph: [_treeContinue] :: SpecialCharacters -> Doc
+ Agda.Syntax.Concrete.Glyph: [_treeLastBranch] :: SpecialCharacters -> Doc
+ Agda.Syntax.Concrete.Glyph: fromArrow :: Doc
+ Agda.Syntax.Concrete.Glyph: treeGlyphs :: TreeGlyphs
+ Agda.Syntax.Concrete.Name: instance Agda.Utils.Null.Null Agda.Syntax.Concrete.Name.Name
+ Agda.Syntax.Concrete.Name: instance Agda.Utils.Null.Null Agda.Syntax.Concrete.Name.QName
+ Agda.Syntax.Concrete.Name: isPrePostOrInfixOperator :: Name -> Bool
+ Agda.Syntax.Concrete.Name: isSimpleName :: Name -> Maybe RawName
+ Agda.Syntax.Concrete.Operators.Parser.Monad: data PrecedenceKey
+ Agda.Syntax.Concrete.Operators.Parser.Monad: instance Data.Hashable.Class.Hashable Agda.Syntax.Concrete.Operators.Parser.Monad.PrecedenceKey
+ Agda.Syntax.Concrete.Operators.Parser.Monad: instance GHC.Classes.Eq Agda.Syntax.Concrete.Operators.Parser.Monad.PrecedenceKey
+ Agda.Syntax.Concrete.Operators.Parser.Monad: instance GHC.Show.Show Agda.Syntax.Concrete.Operators.Parser.Monad.PrecedenceKey
+ Agda.Syntax.Concrete.Operators.Parser.Monad: pattern LeftPK :: PrecedenceLevel -> PrecedenceKey
+ Agda.Syntax.Concrete.Operators.Parser.Monad: pattern RightPK :: PrecedenceLevel -> PrecedenceKey
+ Agda.Syntax.Concrete.Pretty: qualifier :: Pretty a => Maybe a -> Doc -> Doc
+ Agda.Syntax.Info: instance Agda.Syntax.Position.KillRange (Agda.Syntax.Info.DefInfo' t)
+ Agda.Syntax.Internal: AlwaysSing :: DefSing
+ Agda.Syntax.Internal: CodomainSortOld :: t -> BlockedDepCheck t
+ Agda.Syntax.Internal: CodomainSortSame :: BlockedDepCheck t
+ Agda.Syntax.Internal: Dom' :: !DomInfo t -> e -> Dom' t e
+ Agda.Syntax.Internal: DomInfo :: ArgInfo -> Maybe NamedName -> Bool -> Maybe t -> Maybe (RewDom' t) -> DomInfo t
+ Agda.Syntax.Internal: DummyBrave :: Term -> DummyTermKind
+ Agda.Syntax.Internal: DummyNamed :: String -> DummyTermKind
+ Agda.Syntax.Internal: LitPatternInfo :: PatternInfo -> MatchPrio -> LitPatternInfo
+ Agda.Syntax.Internal: LocalEquation :: !Tele (Dom' t (Type'' t t)) -> t -> t -> Type'' t t -> LocalEquation' t
+ Agda.Syntax.Internal: MatchPrio :: Int -> MatchPrio
+ Agda.Syntax.Internal: MaybeRecursive :: ClauseRecursive
+ Agda.Syntax.Internal: MaybeSing :: DefSing
+ Agda.Syntax.Internal: NLPType :: NLPSort -> NLPat -> NLPType
+ Agda.Syntax.Internal: NeverSing :: DefSing
+ Agda.Syntax.Internal: NoSubst :: a -> NoSubst t a
+ Agda.Syntax.Internal: NotRecursive :: ClauseRecursive
+ Agda.Syntax.Internal: PBoundVar :: {-# UNPACK #-} !Int -> PElims -> NLPat
+ Agda.Syntax.Internal: PDef :: QName -> PElims -> NLPat
+ Agda.Syntax.Internal: PInf :: Univ -> Integer -> NLPSort
+ Agda.Syntax.Internal: PIntervalUniv :: NLPSort
+ Agda.Syntax.Internal: PLam :: ArgInfo -> Abs NLPat -> NLPat
+ Agda.Syntax.Internal: PLevelUniv :: NLPSort
+ Agda.Syntax.Internal: PLockUniv :: NLPSort
+ Agda.Syntax.Internal: PPi :: Dom NLPType -> Abs NLPType -> NLPat
+ Agda.Syntax.Internal: PSizeUniv :: NLPSort
+ Agda.Syntax.Internal: PSort :: NLPSort -> NLPat
+ Agda.Syntax.Internal: PTerm :: Term -> NLPat
+ Agda.Syntax.Internal: PUniv :: Univ -> NLPat -> NLPSort
+ Agda.Syntax.Internal: PVar :: DefSing -> !Int -> [Arg Int] -> NLPat
+ Agda.Syntax.Internal: PiSort' :: BlockedDepCheck (Sort' t) -> Dom' t t -> Sort' t -> Abs (Sort' t) -> Sort' t
+ Agda.Syntax.Internal: RewDefHead :: QName -> RewriteHead
+ Agda.Syntax.Internal: RewDom :: LocalEquation' t -> Maybe RewriteRule -> RewDom' t
+ Agda.Syntax.Internal: RewVarHead :: Nat -> RewriteHead
+ Agda.Syntax.Internal: RewriteRule :: Telescope -> RewriteHead -> PElims -> Term -> Type -> RewriteRule
+ Agda.Syntax.Internal: SHDef :: !QName -> SpineHead'
+ Agda.Syntax.Internal: SHMetaV :: {-# UNPACK #-} !MetaId -> SpineHead'
+ Agda.Syntax.Internal: SHVar :: !Int -> SpineHead'
+ Agda.Syntax.Internal: SpineHead :: {-# UNPACK #-} !SpineHead' -> SpineHead
+ Agda.Syntax.Internal: Var' :: {-# UNPACK #-} !Int -> Elims -> Term
+ Agda.Syntax.Internal: YesRecursive :: ClauseRecursive
+ Agda.Syntax.Internal: [conIsHIT] :: ConHead -> IsHIT
+ Agda.Syntax.Internal: [conPPrio] :: ConPatternInfo -> !MatchPrio
+ Agda.Syntax.Internal: [domDomInfo] :: Dom' t e -> !DomInfo t
+ Agda.Syntax.Internal: [domInfoArgInfo] :: DomInfo t -> ArgInfo
+ Agda.Syntax.Internal: [domInfoIsFinite] :: DomInfo t -> Bool
+ Agda.Syntax.Internal: [domInfoName] :: DomInfo t -> Maybe NamedName
+ Agda.Syntax.Internal: [domInfoRew] :: DomInfo t -> Maybe (RewDom' t)
+ Agda.Syntax.Internal: [domInfoTactic] :: DomInfo t -> Maybe t
+ Agda.Syntax.Internal: [lEqContext] :: LocalEquation' t -> !Tele (Dom' t (Type'' t t))
+ Agda.Syntax.Internal: [lEqLHS] :: LocalEquation' t -> t
+ Agda.Syntax.Internal: [lEqRHS] :: LocalEquation' t -> t
+ Agda.Syntax.Internal: [lEqType] :: LocalEquation' t -> Type'' t t
+ Agda.Syntax.Internal: [litPInfo] :: LitPatternInfo -> PatternInfo
+ Agda.Syntax.Internal: [litPPrio] :: LitPatternInfo -> MatchPrio
+ Agda.Syntax.Internal: [nlpTypeSort] :: NLPType -> NLPSort
+ Agda.Syntax.Internal: [nlpTypeUnEl] :: NLPType -> NLPat
+ Agda.Syntax.Internal: [rewContext] :: RewriteRule -> Telescope
+ Agda.Syntax.Internal: [rewDomEq] :: RewDom' t -> LocalEquation' t
+ Agda.Syntax.Internal: [rewDomRew] :: RewDom' t -> Maybe RewriteRule
+ Agda.Syntax.Internal: [rewHead] :: RewriteRule -> RewriteHead
+ Agda.Syntax.Internal: [rewPats] :: RewriteRule -> PElims
+ Agda.Syntax.Internal: [rewRHS] :: RewriteRule -> Term
+ Agda.Syntax.Internal: [rewType] :: RewriteRule -> Type
+ Agda.Syntax.Internal: [theMatchPrio] :: MatchPrio -> Int
+ Agda.Syntax.Internal: [unNoSubst] :: NoSubst t a -> a
+ Agda.Syntax.Internal: applySpineHead :: SpineHead -> Elims -> Term
+ Agda.Syntax.Internal: class LensLocalEquation a
+ Agda.Syntax.Internal: codomainSortOld :: t -> BlockedDepCheck t -> t
+ Agda.Syntax.Internal: couldBeRecursive :: ClauseRecursive -> Bool
+ Agda.Syntax.Internal: dInfo :: forall t e f. Functor f => (ArgInfo -> f ArgInfo) -> Dom' t e -> f (Dom' t e)
+ Agda.Syntax.Internal: dIsFinite :: forall t e f. Functor f => (Bool -> f Bool) -> Dom' t e -> f (Dom' t e)
+ Agda.Syntax.Internal: dName :: forall t e f. Functor f => (Maybe NamedName -> f (Maybe NamedName)) -> Dom' t e -> f (Dom' t e)
+ Agda.Syntax.Internal: dRew :: forall t e f. Functor f => (Maybe (RewDom' t) -> f (Maybe (RewDom' t))) -> Dom' t e -> f (Dom' t e)
+ Agda.Syntax.Internal: dTactic :: forall t e f. Functor f => (Maybe t -> f (Maybe t)) -> Dom' t e -> f (Dom' t e)
+ Agda.Syntax.Internal: data BlockedDepCheck t
+ Agda.Syntax.Internal: data ClauseRecursive
+ Agda.Syntax.Internal: data DefSing
+ Agda.Syntax.Internal: data DomInfo t
+ Agda.Syntax.Internal: data DummyTermKind
+ Agda.Syntax.Internal: data LitPatternInfo
+ Agda.Syntax.Internal: data LocalEquation' t
+ Agda.Syntax.Internal: data NLPSort
+ Agda.Syntax.Internal: data NLPType
+ Agda.Syntax.Internal: data NLPat
+ Agda.Syntax.Internal: data RewDom' t
+ Agda.Syntax.Internal: data RewriteHead
+ Agda.Syntax.Internal: data RewriteRule
+ Agda.Syntax.Internal: data SpineHead
+ Agda.Syntax.Internal: data SpineHead'
+ Agda.Syntax.Internal: decideRecursive :: Bool -> ClauseRecursive
+ Agda.Syntax.Internal: defaultArgDomRew :: ArgInfo -> Maybe RewDom -> a -> Dom a
+ Agda.Syntax.Internal: domEq :: Dom' t e -> Maybe (LocalEquation' t)
+ Agda.Syntax.Internal: domFromArgRew :: Maybe RewDom -> Arg a -> Dom a
+ Agda.Syntax.Internal: domInfo :: Dom' t e -> ArgInfo
+ Agda.Syntax.Internal: domIsFinite :: Dom' t e -> Bool
+ Agda.Syntax.Internal: domName :: Dom' t e -> Maybe NamedName
+ Agda.Syntax.Internal: domTactic :: Dom' t e -> Maybe t
+ Agda.Syntax.Internal: getLocalEq :: LensLocalEquation a => a -> Maybe LocalEquation
+ Agda.Syntax.Internal: hasProj :: Elims -> Bool
+ Agda.Syntax.Internal: headToPat :: Nat -> RewriteHead -> PElims -> NLPat
+ Agda.Syntax.Internal: headToTerm :: Nat -> RewriteHead -> Elims -> Term
+ Agda.Syntax.Internal: instance (Agda.Syntax.Position.KillRange a, Agda.Syntax.Position.KillRange b) => Agda.Syntax.Position.KillRange (Agda.Syntax.Internal.Type'' a b)
+ Agda.Syntax.Internal: instance Agda.Syntax.Common.LensRewriteAnn (Agda.Syntax.Internal.Dom' t e)
+ Agda.Syntax.Internal: instance Agda.Syntax.Common.Pretty.Pretty Agda.Syntax.Internal.ClauseRecursive
+ Agda.Syntax.Internal: instance Agda.Syntax.Common.Pretty.Pretty a => Agda.Syntax.Common.Pretty.Pretty (Agda.Syntax.Internal.NoSubst t a)
+ Agda.Syntax.Internal: instance Agda.Syntax.Common.Pretty.Pretty t => Agda.Syntax.Common.Pretty.Pretty (Agda.Syntax.Internal.BlockedDepCheck t)
+ Agda.Syntax.Internal: instance Agda.Syntax.Internal.LensLocalEquation (Agda.Syntax.Internal.Dom e)
+ Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange Agda.Syntax.Internal.ClauseRecursive
+ Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange Agda.Syntax.Internal.LitPatternInfo
+ Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange Agda.Syntax.Internal.MatchPrio
+ Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange Agda.Syntax.Internal.NLPSort
+ Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange Agda.Syntax.Internal.NLPType
+ Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange Agda.Syntax.Internal.NLPat
+ Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange Agda.Syntax.Internal.RewriteHead
+ Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange Agda.Syntax.Internal.RewriteRule
+ Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange a => Agda.Syntax.Position.KillRange (Agda.Syntax.Internal.BlockedDepCheck a)
+ Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange a => Agda.Syntax.Position.KillRange (Agda.Syntax.Internal.Level' a)
+ Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange a => Agda.Syntax.Position.KillRange (Agda.Syntax.Internal.PlusLevel' a)
+ Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange a => Agda.Syntax.Position.KillRange (Agda.Syntax.Internal.Sort' a)
+ Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange t => Agda.Syntax.Position.KillRange (Agda.Syntax.Internal.LocalEquation' t)
+ Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange t => Agda.Syntax.Position.KillRange (Agda.Syntax.Internal.RewDom' t)
+ Agda.Syntax.Internal: instance Agda.Utils.ExpandCase.ExpandCase (Agda.Syntax.Internal.Tele a)
+ Agda.Syntax.Internal: instance Agda.Utils.Null.Null Agda.Syntax.Internal.ClauseRecursive
+ Agda.Syntax.Internal: instance Agda.Utils.Null.Null Agda.Syntax.Internal.LitPatternInfo
+ Agda.Syntax.Internal: instance Agda.Utils.Null.Null Agda.Syntax.Internal.MatchPrio
+ Agda.Syntax.Internal: instance Agda.Utils.Null.Null Agda.Syntax.Internal.PatternInfo
+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData Agda.Syntax.Internal.ClauseRecursive
+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData Agda.Syntax.Internal.DefSing
+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData Agda.Syntax.Internal.LitPatternInfo
+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData Agda.Syntax.Internal.LocalEquation
+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData Agda.Syntax.Internal.MatchPrio
+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData Agda.Syntax.Internal.NLPSort
+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData Agda.Syntax.Internal.NLPType
+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData Agda.Syntax.Internal.NLPat
+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData Agda.Syntax.Internal.RewDom
+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData Agda.Syntax.Internal.RewriteHead
+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData Agda.Syntax.Internal.RewriteRule
+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Syntax.Common.DataOrRecord' a)
+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Syntax.Internal.BlockedDepCheck a)
+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Syntax.Internal.NoSubst t a)
+ Agda.Syntax.Internal: instance Data.Foldable.Foldable Agda.Syntax.Internal.BlockedDepCheck
+ Agda.Syntax.Internal: instance Data.String.IsString Agda.Syntax.Internal.DummyTermKind
+ Agda.Syntax.Internal: instance Data.Traversable.Traversable Agda.Syntax.Internal.BlockedDepCheck
+ Agda.Syntax.Internal: instance GHC.Base.Functor (Agda.Syntax.Internal.NoSubst t)
+ Agda.Syntax.Internal: instance GHC.Base.Functor Agda.Syntax.Internal.BlockedDepCheck
+ Agda.Syntax.Internal: instance GHC.Base.Monoid Agda.Syntax.Internal.MatchPrio
+ Agda.Syntax.Internal: instance GHC.Base.Semigroup Agda.Syntax.Internal.MatchPrio
+ Agda.Syntax.Internal: instance GHC.Classes.Eq Agda.Syntax.Internal.ClauseRecursive
+ Agda.Syntax.Internal: instance GHC.Classes.Eq Agda.Syntax.Internal.LitPatternInfo
+ Agda.Syntax.Internal: instance GHC.Classes.Eq Agda.Syntax.Internal.MatchPrio
+ Agda.Syntax.Internal: instance GHC.Classes.Eq Agda.Syntax.Internal.RewriteHead
+ Agda.Syntax.Internal: instance GHC.Classes.Ord Agda.Syntax.Internal.MatchPrio
+ Agda.Syntax.Internal: instance GHC.Enum.Bounded Agda.Syntax.Internal.ClauseRecursive
+ Agda.Syntax.Internal: instance GHC.Enum.Bounded Agda.Syntax.Internal.DefSing
+ Agda.Syntax.Internal: instance GHC.Enum.Enum Agda.Syntax.Internal.ClauseRecursive
+ Agda.Syntax.Internal: instance GHC.Enum.Enum Agda.Syntax.Internal.DefSing
+ Agda.Syntax.Internal: instance GHC.Enum.Enum Agda.Syntax.Internal.MatchPrio
+ Agda.Syntax.Internal: instance GHC.Generics.Generic (Agda.Syntax.Internal.BlockedDepCheck t)
+ Agda.Syntax.Internal: instance GHC.Generics.Generic (Agda.Syntax.Internal.LocalEquation' t)
+ Agda.Syntax.Internal: instance GHC.Generics.Generic (Agda.Syntax.Internal.NoSubst t a)
+ Agda.Syntax.Internal: instance GHC.Generics.Generic (Agda.Syntax.Internal.RewDom' t)
+ Agda.Syntax.Internal: instance GHC.Generics.Generic Agda.Syntax.Internal.ClauseRecursive
+ Agda.Syntax.Internal: instance GHC.Generics.Generic Agda.Syntax.Internal.DefSing
+ Agda.Syntax.Internal: instance GHC.Generics.Generic Agda.Syntax.Internal.LitPatternInfo
+ Agda.Syntax.Internal: instance GHC.Generics.Generic Agda.Syntax.Internal.NLPSort
+ Agda.Syntax.Internal: instance GHC.Generics.Generic Agda.Syntax.Internal.NLPType
+ Agda.Syntax.Internal: instance GHC.Generics.Generic Agda.Syntax.Internal.NLPat
+ Agda.Syntax.Internal: instance GHC.Generics.Generic Agda.Syntax.Internal.RewriteHead
+ Agda.Syntax.Internal: instance GHC.Generics.Generic Agda.Syntax.Internal.RewriteRule
+ Agda.Syntax.Internal: instance GHC.Show.Show Agda.Syntax.Internal.ClauseRecursive
+ Agda.Syntax.Internal: instance GHC.Show.Show Agda.Syntax.Internal.DefSing
+ Agda.Syntax.Internal: instance GHC.Show.Show Agda.Syntax.Internal.DummyTermKind
+ Agda.Syntax.Internal: instance GHC.Show.Show Agda.Syntax.Internal.LitPatternInfo
+ Agda.Syntax.Internal: instance GHC.Show.Show Agda.Syntax.Internal.MatchPrio
+ Agda.Syntax.Internal: instance GHC.Show.Show Agda.Syntax.Internal.NLPSort
+ Agda.Syntax.Internal: instance GHC.Show.Show Agda.Syntax.Internal.NLPType
+ Agda.Syntax.Internal: instance GHC.Show.Show Agda.Syntax.Internal.NLPat
+ Agda.Syntax.Internal: instance GHC.Show.Show Agda.Syntax.Internal.RewriteHead
+ Agda.Syntax.Internal: instance GHC.Show.Show Agda.Syntax.Internal.RewriteRule
+ Agda.Syntax.Internal: instance GHC.Show.Show t => GHC.Show.Show (Agda.Syntax.Internal.BlockedDepCheck t)
+ Agda.Syntax.Internal: instance GHC.Show.Show t => GHC.Show.Show (Agda.Syntax.Internal.DomInfo t)
+ Agda.Syntax.Internal: instance GHC.Show.Show t => GHC.Show.Show (Agda.Syntax.Internal.LocalEquation' t)
+ Agda.Syntax.Internal: instance GHC.Show.Show t => GHC.Show.Show (Agda.Syntax.Internal.RewDom' t)
+ Agda.Syntax.Internal: invalidRew :: Dom' t e -> Bool
+ Agda.Syntax.Internal: isAlwaysSing :: DefSing -> Bool
+ Agda.Syntax.Internal: lrewHasProjectionPattern :: RewriteRule -> Bool
+ Agda.Syntax.Internal: maxDefSing :: DefSing -> DefSing -> DefSing
+ Agda.Syntax.Internal: minDefSing :: DefSing -> DefSing -> DefSing
+ Agda.Syntax.Internal: mustBeAbs :: Impossible -> Abs t -> Abs t
+ Agda.Syntax.Internal: newtype MatchPrio
+ Agda.Syntax.Internal: newtype NoSubst t a
+ Agda.Syntax.Internal: pattern Dom :: ArgInfo -> Maybe NamedName -> Bool -> Maybe t -> Maybe (RewDom' t) -> e -> Dom' t e
+ Agda.Syntax.Internal: pattern PProp :: NLPat -> NLPSort
+ Agda.Syntax.Internal: pattern PSSet :: NLPat -> NLPSort
+ Agda.Syntax.Internal: pattern PType :: NLPat -> NLPSort
+ Agda.Syntax.Internal: pattern PiSort :: BlockedDepCheck (Sort' t) -> Dom' t t -> Sort' t -> Abs (Sort' t) -> Sort' t
+ Agda.Syntax.Internal: pattern Var :: Int -> Elims -> Term
+ Agda.Syntax.Internal: relToDefSing :: Relevance -> DefSing
+ Agda.Syntax.Internal: rewDom :: Dom' t e -> Maybe (RewDom' t)
+ Agda.Syntax.Internal: type Args1 = List1 Arg Term
+ Agda.Syntax.Internal: type LocalEquation = LocalEquation' Term
+ Agda.Syntax.Internal: type NamedArgs1 = List1 NamedArg Term
+ Agda.Syntax.Internal: type PElims = [Elim' NLPat]
+ Agda.Syntax.Internal: type Renaming = Substitution' Nat
+ Agda.Syntax.Internal: type RewDom = RewDom' Term
+ Agda.Syntax.Internal: unSpineLoop :: SpineHead -> Elims -> Elims -> Term
+ Agda.Syntax.Internal: varTable :: Array Term
+ Agda.Syntax.Internal: varTableSize :: Int
+ Agda.Syntax.Internal.Blockers: instance GHC.Base.Monoid a => GHC.Base.Monoid (Agda.Syntax.Internal.Blockers.Blocked' t a)
+ Agda.Syntax.Internal.Defs: getDefListNoMetas :: Term -> [QName]
+ Agda.Syntax.Internal.Defs: instance Agda.Syntax.Internal.Defs.GetDefs a => Agda.Syntax.Internal.Defs.GetDefs (Agda.Syntax.Internal.BlockedDepCheck a)
+ Agda.Syntax.Internal.Elim: mustAllApplyElims :: [Elim' a] -> [Arg a]
+ Agda.Syntax.Internal.Elim: mustApplyElim :: Elim' a -> Arg a
+ Agda.Syntax.Internal.Generic: instance (Agda.Syntax.Internal.Generic.TermLike a, Agda.Syntax.Internal.Generic.TermLike b) => Agda.Syntax.Internal.Generic.TermLike (Agda.Syntax.Internal.Dom' a b)
+ Agda.Syntax.Internal.Generic: instance Agda.Syntax.Internal.Generic.TermLike a => Agda.Syntax.Internal.Generic.TermLike (Agda.Syntax.Internal.BlockedDepCheck a)
+ Agda.Syntax.Internal.Generic: instance Agda.Syntax.Internal.Generic.TermLike b => Agda.Syntax.Internal.Generic.TermLike (Agda.Syntax.Internal.Type'' a b)
+ Agda.Syntax.Internal.MetaVars: instance (Agda.Syntax.Internal.Generic.TermLike a, Agda.Syntax.Internal.Generic.TermLike b) => Agda.Syntax.Internal.MetaVars.AllMetas (Agda.Syntax.Internal.Type'' a b)
+ Agda.Syntax.Internal.MetaVars: instance (Agda.Syntax.Internal.Generic.TermLike a, Agda.Syntax.Internal.MetaVars.AllMetas a) => Agda.Syntax.Internal.MetaVars.AllMetas (Agda.Syntax.Internal.LocalEquation' a)
+ Agda.Syntax.Internal.MetaVars: instance (Agda.Syntax.Internal.Generic.TermLike a, Agda.Syntax.Internal.MetaVars.AllMetas a) => Agda.Syntax.Internal.MetaVars.AllMetas (Agda.Syntax.Internal.RewDom' a)
+ Agda.Syntax.Internal.MetaVars: instance (Agda.Syntax.Internal.Generic.TermLike a, 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 Agda.Syntax.Internal.RewriteRule
+ 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.Type'' 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.Either.Either a b)
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.Syntax.Abstract.PatternSynDefn
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.Syntax.Internal.NLPSort
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.Syntax.Internal.NLPType
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.Syntax.Internal.NLPat
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.Syntax.Internal.RewriteHead
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.Syntax.Internal.RewriteRule
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.TypeChecking.Monad.Base.GlobalRewriteRule
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.TypeChecking.Monad.Base.Projection
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.TypeChecking.Monad.Base.ProjectionLikenessMissing
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn GHC.Types.Int
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn a => Agda.Syntax.Internal.Names.NamesIn (Agda.Syntax.Internal.BlockedDepCheck a)
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn a => Agda.Syntax.Internal.Names.NamesIn (Agda.Syntax.Internal.Level' a)
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn a => Agda.Syntax.Internal.Names.NamesIn (Agda.Syntax.Internal.LocalEquation' a)
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn a => Agda.Syntax.Internal.Names.NamesIn (Agda.Syntax.Internal.PlusLevel' a)
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn a => Agda.Syntax.Internal.Names.NamesIn (Agda.Syntax.Internal.RewDom' a)
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn a => Agda.Syntax.Internal.Names.NamesIn (Agda.Syntax.Internal.Sort' a)
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn b => Agda.Syntax.Internal.Names.NamesIn (Data.HashMap.Internal.HashMap a b)
+ Agda.Syntax.Notation: isPrePostOrInfixNotation :: Notation -> Bool
+ Agda.Syntax.Parser: MismatchedBrackets :: Range -> !OpenBracket -> ParseWarning
+ Agda.Syntax.Parser: parseRangeString :: Parser a -> Range -> String -> PM (a, Attributes)
+ Agda.Syntax.Parser.Helpers: applyAttrsDropTactic :: LensAttribute a => [Attr] -> a -> Parser a
+ Agda.Syntax.Parser.Helpers: closeTwoBraces :: Interval -> Interval -> Parser Range
+ Agda.Syntax.Parser.Helpers: haveRewAttr :: [Attr] -> Maybe RewriteAnn
+ Agda.Syntax.Parser.Helpers: haveTacticAttr :: [Attr] -> Maybe (Ranged Expr)
+ Agda.Syntax.Parser.Helpers: isModule :: Declaration -> Bool
+ Agda.Syntax.Parser.Helpers: patternToArgPattern :: Pattern -> Arg Pattern
+ Agda.Syntax.Parser.Helpers: rewAttribute :: Range -> Parser (Maybe Attr)
+ Agda.Syntax.Parser.Helpers: theAttribute :: Attr -> Parser Attr
+ Agda.Syntax.Parser.Helpers: unqualifyToken :: QualifiedToken -> Parser (QName, Range)
+ Agda.Syntax.Parser.LexActions: qualifiedToken :: LexAction Token
+ Agda.Syntax.Parser.Literate: literateExts :: [String]
+ Agda.Syntax.Parser.Monad: MismatchedBrackets :: Range -> !OpenBracket -> ParseWarning
+ Agda.Syntax.Parser.Monad: OpenDoubleBrace :: Bool -> Interval -> OpenBracket
+ Agda.Syntax.Parser.Monad: OpenIdiomBracket :: Bool -> Interval -> OpenBracket
+ Agda.Syntax.Parser.Monad: [openBracketInterval] :: OpenBracket -> Interval
+ Agda.Syntax.Parser.Monad: [openBracketUnicode] :: OpenBracket -> Bool
+ Agda.Syntax.Parser.Monad: [parseBrackets] :: ParseState -> ![OpenBracket]
+ Agda.Syntax.Parser.Monad: closeBracket :: Token -> Parser Range
+ Agda.Syntax.Parser.Monad: data OpenBracket
+ Agda.Syntax.Parser.Monad: instance Agda.Syntax.Position.KillRange Agda.Syntax.Parser.Monad.ParseError
+ Agda.Syntax.Parser.Monad: instance Control.DeepSeq.NFData Agda.Syntax.Parser.Monad.OpenBracket
+ Agda.Syntax.Parser.Monad: instance GHC.Classes.Eq Agda.Syntax.Parser.Monad.OpenBracket
+ Agda.Syntax.Parser.Monad: instance GHC.Show.Show Agda.Syntax.Parser.Monad.OpenBracket
+ Agda.Syntax.Parser.Monad: openBracket :: Token -> Parser Range
+ Agda.Syntax.Parser.Tokens: KwETA_EQUALITY :: Keyword
+ Agda.Syntax.Parser.Tokens: QualDo :: QualifiableToken
+ Agda.Syntax.Parser.Tokens: QualEmptyIdiom :: QualifiableToken
+ Agda.Syntax.Parser.Tokens: QualOpenIdiom :: Bool -> QualifiableToken
+ Agda.Syntax.Parser.Tokens: QualifiedToken :: QualifiableToken -> [(Interval, String)] -> Interval -> QualifiedToken
+ Agda.Syntax.Parser.Tokens: TokQual_ :: QualifiedToken -> Token
+ Agda.Syntax.Parser.Tokens: data QualifiableToken
+ Agda.Syntax.Parser.Tokens: data QualifiedToken
+ Agda.Syntax.Parser.Tokens: instance Agda.Syntax.Position.HasRange Agda.Syntax.Parser.Tokens.QualifiedToken
+ Agda.Syntax.Parser.Tokens: instance GHC.Classes.Eq Agda.Syntax.Parser.Tokens.QualifiableToken
+ Agda.Syntax.Parser.Tokens: instance GHC.Classes.Eq Agda.Syntax.Parser.Tokens.QualifiedToken
+ Agda.Syntax.Parser.Tokens: instance GHC.Show.Show Agda.Syntax.Parser.Tokens.QualifiableToken
+ Agda.Syntax.Parser.Tokens: instance GHC.Show.Show Agda.Syntax.Parser.Tokens.QualifiedToken
+ Agda.Syntax.Parser.Tokens: pattern TokQual :: QualifiableToken -> [(Interval, String)] -> Interval -> Token
+ Agda.Syntax.Position: Pn' :: !a -> !Word32 -> !Word64 -> Position' a
+ Agda.Syntax.Position: [posLineCol] :: Position' a -> !Word64
+ Agda.Syntax.Position: data IntervalWithoutFile'
+ Agda.Syntax.Position: instance Agda.Syntax.Position.HasRangeWithoutFile Agda.Syntax.Position.Range
+ Agda.Syntax.Position: instance Agda.Syntax.Position.KillRange a => Agda.Syntax.Position.KillRange (Agda.Utils.Map1.Map1 k a)
+ Agda.Syntax.Position: instance Agda.Utils.Null.Null Agda.Syntax.Position.RangeFile
+ Agda.Syntax.Position: instance Agda.Utils.Null.Null a => Agda.Utils.Null.Null (Agda.Syntax.Position.Position' a)
+ Agda.Syntax.Position: instance Control.DeepSeq.NFData Agda.Syntax.Position.IntervalWithoutFile'
+ Agda.Syntax.Position: instance Data.Hashable.Class.Hashable Agda.Syntax.Position.IntervalWithoutFile'
+ Agda.Syntax.Position: instance Data.Hashable.Class.Hashable Agda.Syntax.Position.RangeFile
+ Agda.Syntax.Position: instance Data.Hashable.Class.Hashable a => Data.Hashable.Class.Hashable (Agda.Syntax.Position.Interval' a)
+ Agda.Syntax.Position: instance Data.Hashable.Class.Hashable a => Data.Hashable.Class.Hashable (Agda.Syntax.Position.Position' a)
+ Agda.Syntax.Position: instance Data.Hashable.Class.Hashable a => Data.Hashable.Class.Hashable (Agda.Syntax.Position.Range' a)
+ Agda.Syntax.Position: instance GHC.Classes.Eq Agda.Syntax.Position.IntervalWithoutFile'
+ Agda.Syntax.Position: instance GHC.Classes.Ord Agda.Syntax.Position.IntervalWithoutFile'
+ Agda.Syntax.Position: instance GHC.Show.Show Agda.Syntax.Position.IntervalWithoutFile'
+ Agda.Syntax.Position: pattern PackIWF :: IntervalWithoutFile -> IntervalWithoutFile'
+ Agda.Syntax.Position: pattern Pn :: a -> Word32 -> Word32 -> Word32 -> Position' a
+ Agda.Syntax.Position: posCol :: Position' a -> Word32
+ Agda.Syntax.Position: posLine :: Position' a -> Word32
+ Agda.Syntax.Position: unpackIWF :: IntervalWithoutFile' -> IntervalWithoutFile
+ Agda.Syntax.Scope.Base: AllLiveNames :: LiveNames
+ Agda.Syntax.Scope.Base: OpScope :: !Bool -> Map QName (List1 AbstractName) -> !AssocList Name Name -> OperatorScope
+ Agda.Syntax.Scope.Base: OpenedModule :: KwRange -> ModuleName -> ModuleName -> Bool -> NamesInScope -> ModulesInScope -> Set Name -> OpenedModule
+ Agda.Syntax.Scope.Base: PrettyWithBindingSite :: a -> PrettyWithBindingSite a
+ Agda.Syntax.Scope.Base: PrettyWithInstance :: a -> PrettyWithInstance a
+ Agda.Syntax.Scope.Base: SomeLiveNames :: !Set ModuleName -> !Set QName -> LiveNames
+ Agda.Syntax.Scope.Base: UnusedImportsState :: ![AbstractName] -> !IntMap (List2 AbstractName) -> ![AbstractModule] -> !IntMap OpenedModule -> UnusedImportsState
+ Agda.Syntax.Scope.Base: [ambiguousLookups] :: UnusedImportsState -> !IntMap (List2 AbstractName)
+ Agda.Syntax.Scope.Base: [liveModules] :: LiveNames -> !Set ModuleName
+ Agda.Syntax.Scope.Base: [liveNames] :: LiveNames -> !Set QName
+ Agda.Syntax.Scope.Base: [moduleLookups] :: UnusedImportsState -> ![AbstractModule]
+ Agda.Syntax.Scope.Base: [nsNameParts] :: NameSpace -> NamePartsInScope
+ Agda.Syntax.Scope.Base: [openedCompanions] :: OpenedModule -> Set Name
+ Agda.Syntax.Scope.Base: [openedHasDir] :: OpenedModule -> Bool
+ Agda.Syntax.Scope.Base: [openedModuleScope] :: OpenedModule -> ModulesInScope
+ Agda.Syntax.Scope.Base: [openedModule] :: OpenedModule -> ModuleName
+ Agda.Syntax.Scope.Base: [openedModules] :: UnusedImportsState -> !IntMap OpenedModule
+ Agda.Syntax.Scope.Base: [openedNameScope] :: OpenedModule -> NamesInScope
+ Agda.Syntax.Scope.Base: [openedParent] :: OpenedModule -> ModuleName
+ Agda.Syntax.Scope.Base: [openedRange] :: OpenedModule -> KwRange
+ Agda.Syntax.Scope.Base: [osHasOps] :: OperatorScope -> !Bool
+ Agda.Syntax.Scope.Base: [osLocals] :: OperatorScope -> !AssocList Name Name
+ Agda.Syntax.Scope.Base: [osScope] :: OperatorScope -> Map QName (List1 AbstractName)
+ Agda.Syntax.Scope.Base: [unambiguousLookups] :: UnusedImportsState -> ![AbstractName]
+ Agda.Syntax.Scope.Base: addNamePartsToScope :: NameSpaceId -> Name -> AbstractName -> Scope -> Scope
+ Agda.Syntax.Scope.Base: addNameToNameParts :: Name -> AbstractName -> NamePartsInScope -> NamePartsInScope
+ Agda.Syntax.Scope.Base: data LiveNames
+ Agda.Syntax.Scope.Base: data OpenedModule
+ Agda.Syntax.Scope.Base: data OperatorScope
+ Agda.Syntax.Scope.Base: data UnusedImportsState
+ Agda.Syntax.Scope.Base: findQNameInScope :: InScope a => ScopeInfo -> QName -> Scope -> [(a, Access)]
+ Agda.Syntax.Scope.Base: instance (Agda.Syntax.Abstract.Name.HasNameBindingSite a, Agda.Syntax.Common.Pretty.Pretty a) => Agda.Syntax.Common.Pretty.Pretty (Agda.Syntax.Scope.Base.PrettyWithBindingSite a)
+ Agda.Syntax.Scope.Base: instance (Agda.Syntax.Common.IsInstanceDef a, Agda.Syntax.Common.Pretty.Pretty a) => Agda.Syntax.Common.Pretty.Pretty (Agda.Syntax.Scope.Base.PrettyWithInstance a)
+ Agda.Syntax.Scope.Base: instance Agda.Syntax.Common.IsInstanceDef a => Agda.Syntax.Common.IsInstanceDef (Agda.Syntax.Scope.Base.PrettyWithBindingSite a)
+ Agda.Syntax.Scope.Base: instance Agda.Syntax.Common.Pretty.Pretty Agda.Syntax.Scope.Base.LiveNames
+ Agda.Syntax.Scope.Base: instance Agda.Syntax.Common.Pretty.Pretty Agda.Syntax.Scope.Base.OperatorScope
+ Agda.Syntax.Scope.Base: instance Agda.Syntax.Scope.Base.InScope Agda.Syntax.Abstract.Name.AbstractModule
+ Agda.Syntax.Scope.Base: instance Agda.Syntax.Scope.Base.InScope Agda.Syntax.Abstract.Name.AbstractName
+ Agda.Syntax.Scope.Base: instance Agda.Syntax.Scope.Base.SetBindingSite Agda.Syntax.Abstract.Name.AbstractModule
+ Agda.Syntax.Scope.Base: instance Agda.Syntax.Scope.Base.SetBindingSite Agda.Syntax.Abstract.Name.AbstractName
+ Agda.Syntax.Scope.Base: instance Agda.Utils.Null.Null Agda.Syntax.Scope.Base.OpenedModule
+ Agda.Syntax.Scope.Base: instance Agda.Utils.Null.Null Agda.Syntax.Scope.Base.OperatorScope
+ Agda.Syntax.Scope.Base: instance Agda.Utils.Null.Null Agda.Syntax.Scope.Base.UnusedImportsState
+ Agda.Syntax.Scope.Base: instance Control.DeepSeq.NFData Agda.Syntax.Scope.Base.OperatorScope
+ Agda.Syntax.Scope.Base: instance GHC.Base.Monoid Agda.Syntax.Scope.Base.LiveNames
+ Agda.Syntax.Scope.Base: instance GHC.Base.Semigroup Agda.Syntax.Scope.Base.LiveNames
+ Agda.Syntax.Scope.Base: instance GHC.Classes.Eq Agda.Syntax.Scope.Base.LiveNames
+ Agda.Syntax.Scope.Base: instance GHC.Classes.Eq Agda.Syntax.Scope.Base.OperatorScope
+ Agda.Syntax.Scope.Base: instance GHC.Generics.Generic Agda.Syntax.Scope.Base.OpenedModule
+ Agda.Syntax.Scope.Base: instance GHC.Generics.Generic Agda.Syntax.Scope.Base.OperatorScope
+ Agda.Syntax.Scope.Base: instance GHC.Generics.Generic Agda.Syntax.Scope.Base.UnusedImportsState
+ Agda.Syntax.Scope.Base: instance GHC.Show.Show Agda.Syntax.Scope.Base.AllowAmbiguousNames
+ Agda.Syntax.Scope.Base: instance GHC.Show.Show Agda.Syntax.Scope.Base.OperatorScope
+ Agda.Syntax.Scope.Base: isModuleAlive :: ModuleName -> LiveNames -> Bool
+ Agda.Syntax.Scope.Base: isNameAlive :: QName -> LiveNames -> Bool
+ Agda.Syntax.Scope.Base: lensAmbiguousLookups :: Lens' UnusedImportsState (IntMap (List2 AbstractName))
+ Agda.Syntax.Scope.Base: lensModuleLookups :: Lens' UnusedImportsState [AbstractModule]
+ Agda.Syntax.Scope.Base: lensOpenedModules :: Lens' UnusedImportsState (IntMap OpenedModule)
+ Agda.Syntax.Scope.Base: lensUnambiguousLookups :: Lens' UnusedImportsState [AbstractName]
+ Agda.Syntax.Scope.Base: mapScopeMaybe :: (Name -> Maybe Name) -> (Name -> Maybe Name) -> Scope -> Scope
+ Agda.Syntax.Scope.Base: newtype PrettyWithBindingSite a
+ Agda.Syntax.Scope.Base: newtype PrettyWithInstance a
+ Agda.Syntax.Scope.Base: qualifierScopes :: ScopeInfo -> Name -> Scope -> [(AbstractModule, Scope)]
+ Agda.Syntax.Scope.Base: recomputeInScopeSet :: ScopeInfo -> Set QName
+ Agda.Syntax.Scope.Base: recomputeInverseNamesAndModules :: ScopeInfo -> (NameMap, ModuleMap)
+ Agda.Syntax.Scope.Base: recomputeInverseScope' :: ScopeInfo -> ScopeInfo
+ Agda.Syntax.Scope.Base: recomputeNameParts :: Scope -> Scope
+ Agda.Syntax.Scope.Base: scopeAndParents :: ScopeInfo -> [Scope]
+ Agda.Syntax.Scope.Base: scopeLookupQualifier :: InScope a => QName -> [a] -> ScopeInfo -> [AbstractModule]
+ Agda.Syntax.Scope.Base: scopeOfModule :: ScopeInfo -> ModuleName -> Scope
+ Agda.Syntax.Scope.Base: type NamePartsInScope = Map RawName NamesInScope
+ Agda.Syntax.Scope.Base: whyInScopeDataFromAbstractName :: QName -> AbstractName -> WhyInScopeData
+ Agda.Syntax.Scope.Base: whyInScopeDataFromAmbiguousQName :: QName -> AmbiguousQName -> Maybe WhyInScopeData
+ Agda.Syntax.Scope.Monad: addNameToInverseScope :: KindOfName -> Name -> AbstractName -> ScopeInfo -> ScopeInfo
+ Agda.Syntax.Scope.Monad: bindRecordConstructorPseudoName :: ModuleName -> KindOfName -> QName -> ScopeM ()
+ Agda.Syntax.Scope.Monad: checkNoFixityForClosedOperator :: [Renaming] -> ScopeM ()
+ Agda.Syntax.Scope.Monad: dropRecordConstructorPseudoName :: Scope -> Scope
+ Agda.Syntax.Scope.Monad: instance Agda.Syntax.Concrete.Fixity.MonadFixityError Agda.Syntax.Scope.State.ScopeM
+ Agda.Syntax.Scope.Monad: recordConstructorPseudoName :: Name
+ Agda.Syntax.Scope.Operator: OpScope :: !Bool -> Map QName (List1 AbstractName) -> !AssocList Name Name -> OperatorScope
+ Agda.Syntax.Scope.Operator: [osHasOps] :: OperatorScope -> !Bool
+ Agda.Syntax.Scope.Operator: [osLocals] :: OperatorScope -> !AssocList Name Name
+ Agda.Syntax.Scope.Operator: [osScope] :: OperatorScope -> Map QName (List1 AbstractName)
+ Agda.Syntax.Scope.Operator: data OperatorScope
+ Agda.Syntax.Scope.Operator: getDefinedNames :: KindsOfNames -> OperatorScope -> [List1 NewNotation]
+ Agda.Syntax.Scope.Operator: getOperatorScope :: Set QName -> ScopeInfo -> OperatorScope
+ Agda.Syntax.Scope.Operator: localNames :: ExprKind -> Maybe QName -> OperatorScope -> ScopeM ([QName], [NewNotation])
+ Agda.Syntax.Scope.State: getCurrentModule :: ReadTCState m => m ModuleName
+ Agda.Syntax.Scope.State: setCurrentModule :: MonadTCState m => ModuleName -> m ()
+ Agda.Syntax.Scope.State: type ScopeM = TCM
+ Agda.Syntax.Scope.State: withCurrentModule :: (ReadTCState m, MonadTCState m) => ModuleName -> m a -> m a
+ Agda.Syntax.Scope.State: withCurrentModule' :: (MonadTrans t, Monad (t ScopeM)) => ModuleName -> t ScopeM a -> t ScopeM a
+ Agda.Syntax.Scope.UnusedImports: instance Agda.Syntax.Common.Pretty.Pretty a => Agda.Syntax.Common.Pretty.Pretty (Agda.Syntax.Scope.UnusedImports.Imported a)
+ Agda.Syntax.Scope.UnusedImports: instance Agda.Syntax.Scope.UnusedImports.Lineage Agda.Syntax.Abstract.Name.AbstractModule
+ Agda.Syntax.Scope.UnusedImports: instance Agda.Syntax.Scope.UnusedImports.Lineage Agda.Syntax.Abstract.Name.AbstractName
+ Agda.Syntax.Scope.UnusedImports: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.Syntax.Scope.UnusedImports.Imported a)
+ Agda.Syntax.Scope.UnusedImports: instance GHC.Classes.Ord a => GHC.Classes.Ord (Agda.Syntax.Scope.UnusedImports.Imported a)
+ Agda.Syntax.Scope.UnusedImports: instance GHC.Show.Show a => GHC.Show.Show (Agda.Syntax.Scope.UnusedImports.Imported a)
+ Agda.Syntax.Scope.UnusedImports: lookedupModule :: QName -> AbstractModule -> ScopeM ()
+ Agda.Syntax.Scope.UnusedImports: lookedupName :: QName -> ResolvedName -> ScopeM ()
+ Agda.Syntax.Scope.UnusedImports: registerModuleOpening :: KwRange -> ModuleName -> QName -> ImportDirective -> Scope -> ScopeM ()
+ Agda.Syntax.Scope.UnusedImports: warnUnusedImports :: TCM ()
+ Agda.Syntax.TopLevelModuleName.Boot: instance Agda.Utils.Null.Null Agda.Syntax.TopLevelModuleName.Boot.ModuleNameHash
+ Agda.Syntax.Translation.AbstractToConcrete: instance (Agda.TypeChecking.Monad.Builtin.HasBuiltins m, Agda.TypeChecking.Monad.Signature.HasConstInfo m, Agda.TypeChecking.Monad.Context.MonadAddContext m, Agda.Utils.FileId.MonadFileId m, Agda.TypeChecking.Monad.Base.MonadReduce m) => Agda.TypeChecking.Monad.Pure.PureTCM (Agda.Syntax.Translation.AbstractToConcrete.AbsToConT m)
+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.NameAspects Agda.Syntax.Abstract.Name.AmbiguousQName
+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.NameAspects Agda.Syntax.Abstract.Name.Name
+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.NameAspects Agda.Syntax.Abstract.Name.QName
+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.Name.AbstractName
+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Concrete.Name.Name
+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Utils.FileId.MonadFileId m => Agda.Utils.FileId.MonadFileId (Agda.Syntax.Translation.AbstractToConcrete.AbsToConT m)
+ Agda.Syntax.Translation.AbstractToConcrete: instance GHC.Base.Monad m => GHC.Base.Semigroup (Agda.Syntax.Translation.AbstractToConcrete.AbsToConT m Agda.Syntax.Common.Pretty.Doc)
+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.AddGeneralizable Agda.Syntax.Abstract.Name.AbstractName
+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.LivesInCurrentModule Agda.Syntax.Abstract.Name.AbstractName
+ Agda.Syntax.Translation.InternalToAbstract: instance (Agda.Syntax.Translation.InternalToAbstract.BlankVars a, Agda.Syntax.Translation.InternalToAbstract.BlankVars b, Agda.Syntax.Translation.InternalToAbstract.BlankVars c) => Agda.Syntax.Translation.InternalToAbstract.BlankVars (a, b, c)
+ Agda.Syntax.Translation.InternalToAbstract: instance (Agda.TypeChecking.Free.Generic.Free i, Agda.Syntax.Translation.InternalToAbstract.Reify i) => Agda.Syntax.Translation.InternalToAbstract.Reify (Agda.Syntax.Internal.Abs i)
+ Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.TypeChecking.Monad.Base.Types.Context
+ Agda.Syntax.Treeless: NonStrict :: Strictness
+ Agda.Syntax.Treeless: Strict :: Strictness
+ Agda.Syntax.Treeless: [caseInduction] :: CaseInfo -> !Induction
+ Agda.Syntax.Treeless: data Strictness
+ Agda.Syntax.Treeless: defaultConstructorStrictness :: EvaluationStrategy -> Induction -> Strictness
+ Agda.Syntax.Treeless: defaultStrictness :: EvaluationStrategy -> Strictness
+ Agda.Syntax.Treeless: instance Agda.Syntax.Internal.TermSize Agda.Syntax.Treeless.TAlt
+ Agda.Syntax.Treeless: instance Agda.Syntax.Internal.TermSize Agda.Syntax.Treeless.TTerm
+ Agda.Syntax.Treeless: instance Control.DeepSeq.NFData Agda.Syntax.Treeless.EvaluationStrategy
+ Agda.Syntax.Treeless: instance Control.DeepSeq.NFData Agda.Syntax.Treeless.Strictness
+ Agda.Syntax.Treeless: instance GHC.Classes.Eq Agda.Syntax.Treeless.Strictness
+ Agda.Syntax.Treeless: instance GHC.Classes.Ord Agda.Syntax.Treeless.EvaluationStrategy
+ Agda.Syntax.Treeless: instance GHC.Classes.Ord Agda.Syntax.Treeless.Strictness
+ Agda.Syntax.Treeless: instance GHC.Generics.Generic Agda.Syntax.Treeless.EvaluationStrategy
+ Agda.Syntax.Treeless: instance GHC.Generics.Generic Agda.Syntax.Treeless.Strictness
+ Agda.Syntax.Treeless: instance GHC.Show.Show Agda.Syntax.Treeless.Strictness
+ Agda.Termination.CallGraph: loops :: CallGraph cinfo -> [(Node, CMSet cinfo)]
+ Agda.Termination.CallMatrix: mapCMSet :: (Favorites (CallMatrixAug cinfo) -> Favorites (CallMatrixAug cinfo)) -> CMSet cinfo -> CMSet cinfo
+ Agda.Termination.CallMatrix: mapCallMatrix :: (Matrix ArgumentIndex a -> Matrix ArgumentIndex a) -> CallMatrix' a -> CallMatrix' a
+ Agda.Termination.CallMatrix: mapCallMatrixAug :: (CallMatrix -> CallMatrix) -> CallMatrixAug cinfo -> CallMatrixAug cinfo
+ Agda.Termination.CutOff: instance GHC.Num.Num Agda.Termination.CutOff.CutOff
+ Agda.Termination.Monad: [callPathStart] :: CallPath -> QName
+ Agda.Termination.Monad: [callPathSteps] :: CallPath -> BinTree CallInfo
+ Agda.Termination.Monad: [terNameToProjections] :: TerEnv -> !Map QName [[QName]]
+ Agda.Termination.Monad: [terNodeToName] :: TerEnv -> !IntMap QName
+ Agda.Termination.Monad: [terProjectedNameToMaskArgs] :: TerEnv -> !Map (QName, [QName]) (ListInf Bool)
+ Agda.Termination.Monad: [terProjectedNameToNode] :: TerEnv -> !Map (QName, [QName]) Node
+ Agda.Termination.Monad: data CallPath
+ Agda.Termination.Monad: elimNotCoinductive :: MonadTCM tcm => Elim' t -> tcm Bool
+ Agda.Termination.Monad: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Termination.CallMatrix.CallMatrix
+ Agda.Termination.Monad: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Termination.Monad.CallPath
+ Agda.Termination.Monad: instance Agda.TypeChecking.Pretty.PrettyTCM cinfo => Agda.TypeChecking.Pretty.PrettyTCM (Agda.Termination.CallGraph.Call cinfo)
+ Agda.Termination.Monad: instance Agda.TypeChecking.Pretty.PrettyTCM cinfo => Agda.TypeChecking.Pretty.PrettyTCM (Agda.Termination.CallGraph.CallGraph cinfo)
+ Agda.Termination.Monad: instance Agda.TypeChecking.Pretty.PrettyTCM cinfo => Agda.TypeChecking.Pretty.PrettyTCM (Agda.Termination.CallMatrix.CMSet cinfo)
+ Agda.Termination.Monad: instance Agda.TypeChecking.Pretty.PrettyTCM cinfo => Agda.TypeChecking.Pretty.PrettyTCM (Agda.Termination.CallMatrix.CallMatrixAug cinfo)
+ Agda.Termination.Monad: instance Agda.Utils.FileId.MonadFileId Agda.Termination.Monad.TerM
+ Agda.Termination.Monad: instance GHC.Base.Monoid m => GHC.Base.Monoid (Agda.Termination.Monad.TerM m)
+ Agda.Termination.Monad: terGetNameToProjections :: TerM (Map QName [[QName]])
+ Agda.Termination.Monad: terGetNodeToName :: TerM (IntMap QName)
+ Agda.Termination.Monad: terGetProjectedNameToMaskArgs :: TerM (Map (QName, [QName]) (ListInf Bool))
+ Agda.Termination.Monad: terGetProjectedNameToNode :: TerM (Map (QName, [QName]) Node)
+ Agda.Termination.Monad: terSetNameToProjections :: Map QName [[QName]] -> TerM a -> TerM a
+ Agda.Termination.Monad: terSetNodeToName :: IntMap QName -> TerM a -> TerM a
+ Agda.Termination.Monad: terSetProjectedNameToMaskArgs :: Map (QName, [QName]) (ListInf Bool) -> TerM a -> TerM a
+ Agda.Termination.Monad: terSetProjectedNameToNode :: Map (QName, [QName]) Node -> TerM a -> TerM a
+ Agda.Termination.Order: makeIncreaseInfinite :: Order -> Order
+ Agda.Termination.SparseMatrix: mapDiagonalNonZeros :: (Integral i, HasZero a) => (a -> a) -> Matrix i a -> Matrix i a
+ Agda.Termination.SparseMatrix: mapNonZeros :: forall i a b. HasZero b => (i -> i -> a -> b) -> Matrix i a -> Matrix i b
+ Agda.Termination.Termination: idempotentEndos :: (?cutoff :: CutOff) => CallGraph cinfo -> [CallMatrixAug cinfo]
+ Agda.Termination.Termination: terminationCounterexample :: (?cutoff :: CutOff) => Bool -> (Node -> Bool) -> CallGraph cinfo -> Terminates cinfo
+ Agda.TypeChecking.Abstract: instance Agda.TypeChecking.Abstract.EqualSy a => Agda.TypeChecking.Abstract.EqualSy (Agda.Syntax.Internal.BlockedDepCheck a)
+ Agda.TypeChecking.CompiledClause: CCDone :: !ClauseNumber -> !ClauseRecursive -> ![Arg ArgName] -> a -> CCDone a
+ Agda.TypeChecking.CompiledClause: Done_ :: !CCDone a -> CompiledClauses' a
+ Agda.TypeChecking.CompiledClause: [ccBody] :: CCDone a -> a
+ Agda.TypeChecking.CompiledClause: [ccBoundVars] :: CCDone a -> ![Arg ArgName]
+ Agda.TypeChecking.CompiledClause: [ccClauseNumber] :: CCDone a -> !ClauseNumber
+ Agda.TypeChecking.CompiledClause: [ccClauseRecursive] :: CCDone a -> !ClauseRecursive
+ Agda.TypeChecking.CompiledClause: class MapDone (f :: Type -> Type)
+ Agda.TypeChecking.CompiledClause: data CCDone a
+ Agda.TypeChecking.CompiledClause: instance Agda.Syntax.Common.Pretty.Pretty a => Agda.Syntax.Common.Pretty.Pretty (Agda.TypeChecking.CompiledClause.CCDone a)
+ Agda.TypeChecking.CompiledClause: instance Agda.Syntax.Common.Pretty.Pretty a => Agda.Syntax.Common.Pretty.Pretty (Agda.TypeChecking.CompiledClause.CompiledClauses' a)
+ Agda.TypeChecking.CompiledClause: instance Agda.Syntax.Internal.Generic.TermLike a => Agda.Syntax.Internal.Generic.TermLike (Agda.TypeChecking.CompiledClause.CCDone a)
+ Agda.TypeChecking.CompiledClause: instance Agda.TypeChecking.CompiledClause.MapDone Agda.TypeChecking.CompiledClause.CompiledClauses'
+ Agda.TypeChecking.CompiledClause: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.TypeChecking.CompiledClause.CCDone a)
+ Agda.TypeChecking.CompiledClause: instance Data.Foldable.Foldable Agda.TypeChecking.CompiledClause.CCDone
+ Agda.TypeChecking.CompiledClause: instance Data.Traversable.Traversable Agda.TypeChecking.CompiledClause.CCDone
+ Agda.TypeChecking.CompiledClause: instance GHC.Base.Functor Agda.TypeChecking.CompiledClause.CCDone
+ Agda.TypeChecking.CompiledClause: instance GHC.Base.Monoid c => GHC.Base.Monoid (Agda.TypeChecking.CompiledClause.WithArity c)
+ Agda.TypeChecking.CompiledClause: instance GHC.Base.Monoid m => GHC.Base.Monoid (Agda.TypeChecking.CompiledClause.Case m)
+ Agda.TypeChecking.CompiledClause: instance GHC.Generics.Generic (Agda.TypeChecking.CompiledClause.CCDone a)
+ Agda.TypeChecking.CompiledClause: instance GHC.Show.Show a => GHC.Show.Show (Agda.TypeChecking.CompiledClause.CCDone a)
+ Agda.TypeChecking.CompiledClause: mapDone :: MapDone f => (CCDone a -> CCDone b) -> f a -> f b
+ Agda.TypeChecking.CompiledClause: pattern Done :: ClauseNumber -> ClauseRecursive -> [Arg ArgName] -> a -> CompiledClauses' a
+ Agda.TypeChecking.CompiledClause: type ClauseNumber = Int
+ Agda.TypeChecking.CompiledClause.Compile: [clNumber] :: Cl -> ClauseNumber
+ Agda.TypeChecking.CompiledClause.Compile: [clRecursive] :: Cl -> ClauseRecursive
+ Agda.TypeChecking.Constraints: newProblemDontWake_ :: (MonadFresh ProblemId m, MonadConstraint m) => m a -> m ProblemId
+ Agda.TypeChecking.Conversion: computeRewHeadType :: Int -> RewriteHead -> Elims -> Elims -> TCM Type
+ Agda.TypeChecking.Conversion: failConversion :: (MonadTCError m, HasBuiltins m) => Comparison -> Term -> Term -> CompareAs -> m a
+ Agda.TypeChecking.Conversion.Errors: ConvApply :: Term -> Abs Type -> Arg ConversionZipper -> [Elim] -> [Elim] -> ConversionZipper
+ Agda.TypeChecking.Conversion.Errors: ConvCod :: Dom Type -> ArgName -> ConversionZipper -> ConversionZipper
+ Agda.TypeChecking.Conversion.Errors: ConvDom :: Dom ConversionZipper -> Abs Type -> Abs Type -> ConversionZipper
+ Agda.TypeChecking.Conversion.Errors: ConvLam :: Dom Type -> Abs () -> ArgName -> ConversionZipper -> ConversionZipper
+ Agda.TypeChecking.Conversion.Errors: ConvStop :: ConversionZipper
+ Agda.TypeChecking.Conversion.Errors: ConversionError :: Comparison -> FailedCompareAs -> Term -> Term -> ConversionErrorContext -> ConversionError
+ Agda.TypeChecking.Conversion.Errors: FailAsTermsOf :: Type -> Type -> FailedCompareAs
+ Agda.TypeChecking.Conversion.Errors: FailAsTypes :: FailedCompareAs
+ Agda.TypeChecking.Conversion.Errors: Finished :: HereOrThere -> Maybe HeadMismatch -> ConversionErrorContext
+ Agda.TypeChecking.Conversion.Errors: Floating :: ConversionZipper -> ConversionErrorContext
+ Agda.TypeChecking.Conversion.Errors: [convErrCmp] :: ConversionError -> Comparison
+ Agda.TypeChecking.Conversion.Errors: [convErrCtx] :: ConversionError -> ConversionErrorContext
+ Agda.TypeChecking.Conversion.Errors: [convErrLhs] :: ConversionError -> Term
+ Agda.TypeChecking.Conversion.Errors: [convErrRhs] :: ConversionError -> Term
+ Agda.TypeChecking.Conversion.Errors: [convErrTys] :: ConversionError -> FailedCompareAs
+ Agda.TypeChecking.Conversion.Errors: addConversionContext :: MonadTCError m => (ConversionZipper -> ConversionZipper) -> m a -> m a
+ Agda.TypeChecking.Conversion.Errors: cutConversionErrors :: (MonadPretty m, MonadError TCErr m) => m a -> m a
+ Agda.TypeChecking.Conversion.Errors: data ConversionError
+ Agda.TypeChecking.Conversion.Errors: data ConversionErrorContext
+ Agda.TypeChecking.Conversion.Errors: data ConversionZipper
+ Agda.TypeChecking.Conversion.Errors: data FailedCompareAs
+ Agda.TypeChecking.Conversion.Errors: failConversion :: (MonadTCError m, HasBuiltins m) => Comparison -> Term -> Term -> CompareAs -> m a
+ Agda.TypeChecking.Conversion.Errors: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Conversion.Errors.ConversionError
+ Agda.TypeChecking.Conversion.Errors: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Conversion.Errors.ConversionZipper
+ Agda.TypeChecking.Conversion.Errors: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Conversion.Errors.FailedCompareAs
+ Agda.TypeChecking.Conversion.Errors: instance Control.DeepSeq.NFData Agda.TypeChecking.Conversion.Errors.ConversionError
+ Agda.TypeChecking.Conversion.Errors: instance Control.DeepSeq.NFData Agda.TypeChecking.Conversion.Errors.ConversionErrorContext
+ Agda.TypeChecking.Conversion.Errors: instance Control.DeepSeq.NFData Agda.TypeChecking.Conversion.Errors.ConversionZipper
+ Agda.TypeChecking.Conversion.Errors: instance Control.DeepSeq.NFData Agda.TypeChecking.Conversion.Errors.FailedCompareAs
+ Agda.TypeChecking.Conversion.Errors: instance Control.DeepSeq.NFData Agda.TypeChecking.Conversion.Errors.HeadMismatch
+ Agda.TypeChecking.Conversion.Errors: instance Control.DeepSeq.NFData Agda.TypeChecking.Conversion.Errors.HereOrThere
+ Agda.TypeChecking.Conversion.Errors: instance Control.DeepSeq.NFData Agda.TypeChecking.Conversion.Errors.WhyUnequalTypes
+ Agda.TypeChecking.Conversion.Errors: instance GHC.Generics.Generic Agda.TypeChecking.Conversion.Errors.ConversionError
+ Agda.TypeChecking.Conversion.Errors: instance GHC.Generics.Generic Agda.TypeChecking.Conversion.Errors.ConversionErrorContext
+ Agda.TypeChecking.Conversion.Errors: instance GHC.Generics.Generic Agda.TypeChecking.Conversion.Errors.ConversionZipper
+ Agda.TypeChecking.Conversion.Errors: instance GHC.Generics.Generic Agda.TypeChecking.Conversion.Errors.FailedCompareAs
+ Agda.TypeChecking.Conversion.Errors: instance GHC.Generics.Generic Agda.TypeChecking.Conversion.Errors.HeadMismatch
+ Agda.TypeChecking.Conversion.Errors: instance GHC.Generics.Generic Agda.TypeChecking.Conversion.Errors.HereOrThere
+ Agda.TypeChecking.Conversion.Errors: instance GHC.Show.Show Agda.TypeChecking.Conversion.Errors.ConversionError
+ Agda.TypeChecking.Conversion.Errors: instance GHC.Show.Show Agda.TypeChecking.Conversion.Errors.ConversionErrorContext
+ Agda.TypeChecking.Conversion.Errors: instance GHC.Show.Show Agda.TypeChecking.Conversion.Errors.ConversionZipper
+ Agda.TypeChecking.Conversion.Errors: instance GHC.Show.Show Agda.TypeChecking.Conversion.Errors.FailedCompareAs
+ Agda.TypeChecking.Conversion.Errors: instance GHC.Show.Show Agda.TypeChecking.Conversion.Errors.HeadMismatch
+ Agda.TypeChecking.Conversion.Errors: instance GHC.Show.Show Agda.TypeChecking.Conversion.Errors.HereOrThere
+ Agda.TypeChecking.Conversion.Errors: instance GHC.Show.Show Agda.TypeChecking.Conversion.Errors.WhyUnequalTypes
+ Agda.TypeChecking.Conversion.Errors: mismatchedProjections :: (MonadError TCErr m, PureTCM m) => Type -> Term -> Elims -> Type -> Term -> Elims -> m a
+ Agda.TypeChecking.Conversion.Errors: nowConversionChecking :: (MonadTCError m, HasBuiltins m) => Comparison -> Term -> Term -> CompareAs -> m a -> m a
+ Agda.TypeChecking.Conversion.Pure: pureBlockOrEqualTerm :: Type -> Term -> Term -> TCM (Either Blocker Bool)
+ Agda.TypeChecking.Conversion.Pure: pureBlockOrEqualTermPureTCM :: PureTCM m => Type -> Term -> Term -> m (Either Blocker Bool)
+ Agda.TypeChecking.Conversion.Pure: pureBlockOrEqualType :: Type -> Type -> TCM (Either Blocker Bool)
+ Agda.TypeChecking.Conversion.Pure: pureBlockOrEqualTypePureTCM :: PureTCM m => Type -> Type -> m (Either Blocker Bool)
+ Agda.TypeChecking.Conversion.Pure: pureConversion :: TCM b -> (Blocker -> TCM b) -> (a -> TCM b) -> TCM a -> TCM b
+ Agda.TypeChecking.Coverage: instance GHC.Classes.Eq Agda.TypeChecking.Coverage.InferMissing
+ Agda.TypeChecking.Coverage: instance GHC.Show.Show Agda.TypeChecking.Coverage.InferMissing
+ Agda.TypeChecking.Coverage.SplitClause: instance Agda.Syntax.Common.Pretty.Pretty Agda.TypeChecking.Coverage.SplitClause.SplitClause
+ Agda.TypeChecking.Coverage.SplitClause: instance GHC.Show.Show Agda.TypeChecking.Coverage.SplitClause.SplitClause
+ Agda.TypeChecking.Coverage.SplitPattern: SplitPatVar :: PatVarName -> Int -> [Literal] -> SplitPatVar
+ Agda.TypeChecking.Coverage.SplitPattern: [splitExcludedLits] :: SplitPatVar -> [Literal]
+ Agda.TypeChecking.Coverage.SplitPattern: [splitPatVarIndex] :: SplitPatVar -> Int
+ Agda.TypeChecking.Coverage.SplitPattern: [splitPatVarName] :: SplitPatVar -> PatVarName
+ Agda.TypeChecking.Coverage.SplitPattern: applySplitPSubst :: TermSubst a => SplitPSubstitution -> a -> a
+ Agda.TypeChecking.Coverage.SplitPattern: data SplitPatVar
+ Agda.TypeChecking.Coverage.SplitPattern: fromSplitPattern :: NamedArg SplitPattern -> NamedArg DeBruijnPattern
+ Agda.TypeChecking.Coverage.SplitPattern: fromSplitPatterns :: [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
+ Agda.TypeChecking.Coverage.SplitPattern: instance Agda.Syntax.Common.Pretty.Pretty Agda.TypeChecking.Coverage.SplitPattern.SplitPatVar
+ Agda.TypeChecking.Coverage.SplitPattern: instance Agda.Syntax.Position.KillRange Agda.TypeChecking.Coverage.SplitPattern.SplitPatVar
+ Agda.TypeChecking.Coverage.SplitPattern: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Coverage.SplitPattern.SplitPatVar
+ Agda.TypeChecking.Coverage.SplitPattern: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Coverage.SplitPattern.SplitPattern
+ Agda.TypeChecking.Coverage.SplitPattern: instance Agda.TypeChecking.Substitute.DeBruijn.DeBruijn Agda.TypeChecking.Coverage.SplitPattern.SplitPatVar
+ Agda.TypeChecking.Coverage.SplitPattern: instance GHC.Show.Show Agda.TypeChecking.Coverage.SplitPattern.SplitPatVar
+ Agda.TypeChecking.Coverage.SplitPattern: isTrivialPattern :: HasConstInfo m => Pattern' a -> m Bool
+ Agda.TypeChecking.Coverage.SplitPattern: toSplitPSubst :: PatternSubstitution -> SplitPSubstitution
+ Agda.TypeChecking.Coverage.SplitPattern: toSplitPatterns :: [NamedArg DeBruijnPattern] -> [NamedArg SplitPattern]
+ Agda.TypeChecking.Coverage.SplitPattern: type SplitPattern = Pattern' SplitPatVar
+ Agda.TypeChecking.Errors: Indefinite :: a -> Indefinite a
+ Agda.TypeChecking.Errors: Ordinal :: Int -> Ordinal
+ Agda.TypeChecking.Errors: instance Agda.TypeChecking.Errors.Verbalize Agda.TypeChecking.Errors.Ordinal
+ Agda.TypeChecking.Errors: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Monad.Base.Types.TopLevelModuleNameWithSourceFile
+ Agda.TypeChecking.Errors: newtype Indefinite a
+ Agda.TypeChecking.Errors: newtype Ordinal
+ Agda.TypeChecking.Errors: prettyShadowedModule :: MonadPretty m => Name -> List1 ModuleName -> m (m Doc, Range)
+ Agda.TypeChecking.Free: MetaSet :: HashSet MetaId -> MetaSet
+ Agda.TypeChecking.Free: VarMap :: TheVarMap' a -> VarMap' a
+ Agda.TypeChecking.Free: [theMetaSet] :: MetaSet -> HashSet MetaId
+ Agda.TypeChecking.Free: [theVarMap] :: VarMap' a -> TheVarMap' a
+ Agda.TypeChecking.Free: allFreeVar :: Free t => (Int -> Bool) -> t -> Bool
+ Agda.TypeChecking.Free: allFreeVarIgnoreAll :: Free t => (Int -> Bool) -> t -> Bool
+ Agda.TypeChecking.Free: anyFreeVar :: Free t => (Int -> Bool) -> t -> Bool
+ Agda.TypeChecking.Free: anyFreeVarIgnoreAll :: (Int -> Bool) -> Term -> Bool
+ Agda.TypeChecking.Free: composeFlexRig :: Semigroup a => FlexRig' a -> FlexRig' a -> FlexRig' a
+ Agda.TypeChecking.Free: flexRigToBlocker :: FlexRig -> Blocker
+ Agda.TypeChecking.Free: freeVarCounts :: Free t => t -> VarCounts
+ Agda.TypeChecking.Free: freeVarList :: Free t => t -> [Int]
+ Agda.TypeChecking.Free: freeVarMap :: Free t => t -> VarMap
+ Agda.TypeChecking.Free: freeVarMapIgnoreAnn :: Free t => t -> VarMap
+ Agda.TypeChecking.Free: freeVarSet :: Free t => t -> VarSet
+ Agda.TypeChecking.Free: inRewVars :: Telescope -> VarSet
+ Agda.TypeChecking.Free: instance Agda.Syntax.Common.LensModality Agda.TypeChecking.Free.FreeVarMap
+ Agda.TypeChecking.Free: instance Agda.Syntax.Common.LensModality Agda.TypeChecking.Free.FreeVarMapIgnoreAnn
+ Agda.TypeChecking.Free: instance Agda.Syntax.Common.LensModality Agda.TypeChecking.Free.SingleVarOcc
+ Agda.TypeChecking.Free: instance Agda.Syntax.Common.LensRelevance Agda.TypeChecking.Free.FreeVarMap
+ Agda.TypeChecking.Free: instance Agda.Syntax.Common.LensRelevance Agda.TypeChecking.Free.FreeVarMapIgnoreAnn
+ Agda.TypeChecking.Free: instance Agda.Syntax.Common.LensRelevance Agda.TypeChecking.Free.RelevantInIgnoringSortAnn
+ Agda.TypeChecking.Free: instance Agda.Syntax.Common.LensRelevance Agda.TypeChecking.Free.SetRelInIgnoring
+ Agda.TypeChecking.Free: instance Agda.Syntax.Common.LensRelevance Agda.TypeChecking.Free.SingleVarOcc
+ Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Base.LensFlexRig Agda.TypeChecking.Free.FreeVarMap Agda.TypeChecking.Free.Base.MetaSet
+ Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Base.LensFlexRig Agda.TypeChecking.Free.FreeVarMapIgnoreAnn Agda.TypeChecking.Free.Base.MetaSet
+ Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Base.LensFlexRig Agda.TypeChecking.Free.SingleVarOcc Agda.TypeChecking.Free.Base.MetaSet
+ Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Generic.ComputeFree Agda.TypeChecking.Free.AnyFreeVar
+ Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Generic.ComputeFree Agda.TypeChecking.Free.AnyFreeVarIgnoreAll
+ Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Generic.ComputeFree Agda.TypeChecking.Free.Closed
+ Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Generic.ComputeFree Agda.TypeChecking.Free.FreeIn
+ Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Generic.ComputeFree Agda.TypeChecking.Free.FreeInIgnoringSorts
+ Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Generic.ComputeFree Agda.TypeChecking.Free.FreeVarCounts
+ Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Generic.ComputeFree Agda.TypeChecking.Free.FreeVarList
+ Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Generic.ComputeFree Agda.TypeChecking.Free.FreeVarMap
+ Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Generic.ComputeFree Agda.TypeChecking.Free.FreeVarMapIgnoreAnn
+ Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Generic.ComputeFree Agda.TypeChecking.Free.FreeVarSet
+ Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Generic.ComputeFree Agda.TypeChecking.Free.RelevantInIgnoringSortAnn
+ Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Generic.ComputeFree Agda.TypeChecking.Free.SetRelInIgnoring
+ Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Generic.ComputeFree Agda.TypeChecking.Free.SingleVarOcc
+ Agda.TypeChecking.Free: instance Agda.Utils.ExpandCase.ExpandCase Agda.TypeChecking.Free.CollectSFII
+ Agda.TypeChecking.Free: instance GHC.Base.Monoid Agda.TypeChecking.Free.CollectSFII
+ Agda.TypeChecking.Free: instance GHC.Base.Semigroup Agda.TypeChecking.Free.CollectSFII
+ Agda.TypeChecking.Free: instance GHC.Base.Semigroup Agda.TypeChecking.Free.CollectSingleVarOcc
+ Agda.TypeChecking.Free: lookupVarMap :: Variable -> VarMap' a -> Maybe (VarOcc' a)
+ Agda.TypeChecking.Free: mapVarMap :: (TheVarMap' a -> TheVarMap' b) -> VarMap' a -> VarMap' b
+ Agda.TypeChecking.Free: newtype MetaSet
+ Agda.TypeChecking.Free: newtype VarMap' a
+ Agda.TypeChecking.Free: setRelInIgnoring :: Free t => VarSet -> t -> VarSet
+ Agda.TypeChecking.Free: theRewVars :: Telescope -> VarSet
+ Agda.TypeChecking.Free: type VarMap = VarMap' MetaSet
+ Agda.TypeChecking.Free.Base: Flexible :: !a -> FlexRig' a
+ Agda.TypeChecking.Free.Base: IgnoreAll :: IgnoreSorts
+ Agda.TypeChecking.Free.Base: IgnoreInAnnotations :: IgnoreSorts
+ Agda.TypeChecking.Free.Base: IgnoreNot :: IgnoreSorts
+ Agda.TypeChecking.Free.Base: MetaSet :: HashSet MetaId -> MetaSet
+ Agda.TypeChecking.Free.Base: StronglyRigid :: FlexRig' a
+ Agda.TypeChecking.Free.Base: Unguarded :: FlexRig' a
+ Agda.TypeChecking.Free.Base: VarCounts :: IntMap Int -> VarCounts
+ Agda.TypeChecking.Free.Base: VarMap :: TheVarMap' a -> VarMap' a
+ Agda.TypeChecking.Free.Base: VarOcc :: !FlexRig' a -> {-# UNPACK #-} !Modality -> VarOcc' a
+ Agda.TypeChecking.Free.Base: WeaklyRigid :: FlexRig' a
+ Agda.TypeChecking.Free.Base: [theMetaSet] :: MetaSet -> HashSet MetaId
+ Agda.TypeChecking.Free.Base: [theVarMap] :: VarMap' a -> TheVarMap' a
+ Agda.TypeChecking.Free.Base: [varCounts] :: VarCounts -> IntMap Int
+ Agda.TypeChecking.Free.Base: [varFlexRig] :: VarOcc' a -> !FlexRig' a
+ Agda.TypeChecking.Free.Base: [varModality] :: VarOcc' a -> {-# UNPACK #-} !Modality
+ Agda.TypeChecking.Free.Base: addFlexRig :: Semigroup a => FlexRig' a -> FlexRig' a -> FlexRig' a
+ Agda.TypeChecking.Free.Base: class LensFlexRig o a | o -> a
+ Agda.TypeChecking.Free.Base: composeFlexRig :: Semigroup a => FlexRig' a -> FlexRig' a -> FlexRig' a
+ Agda.TypeChecking.Free.Base: composeVarOcc :: Semigroup a => VarOcc' a -> VarOcc' a -> VarOcc' a
+ Agda.TypeChecking.Free.Base: constructorFlexRig :: ConHead -> Elims -> FlexRig' a
+ Agda.TypeChecking.Free.Base: data FlexRig' a
+ Agda.TypeChecking.Free.Base: data IgnoreSorts
+ Agda.TypeChecking.Free.Base: data VarOcc' a
+ Agda.TypeChecking.Free.Base: flexRigToBlocker :: FlexRig -> Blocker
+ Agda.TypeChecking.Free.Base: foldrMetaSet :: (MetaId -> a -> a) -> a -> MetaSet -> a
+ Agda.TypeChecking.Free.Base: insertMetaSet :: MetaId -> MetaSet -> MetaSet
+ Agda.TypeChecking.Free.Base: instance Agda.Syntax.Common.LensModality (Agda.TypeChecking.Free.Base.VarOcc' a)
+ Agda.TypeChecking.Free.Base: instance Agda.Syntax.Common.LensQuantity (Agda.TypeChecking.Free.Base.VarOcc' a)
+ Agda.TypeChecking.Free.Base: instance Agda.Syntax.Common.LensRelevance (Agda.TypeChecking.Free.Base.VarOcc' a)
+ Agda.TypeChecking.Free.Base: instance Agda.Syntax.Common.Pretty.Pretty Agda.TypeChecking.Free.Base.MetaSet
+ Agda.TypeChecking.Free.Base: instance Agda.Syntax.Common.Pretty.Pretty a => Agda.Syntax.Common.Pretty.Pretty (Agda.TypeChecking.Free.Base.FlexRig' a)
+ Agda.TypeChecking.Free.Base: instance Agda.Syntax.Common.Pretty.Pretty a => Agda.Syntax.Common.Pretty.Pretty (Agda.TypeChecking.Free.Base.VarOcc' a)
+ Agda.TypeChecking.Free.Base: instance Agda.TypeChecking.Free.Base.LensFlexRig (Agda.TypeChecking.Free.Base.FlexRig' a) a
+ Agda.TypeChecking.Free.Base: instance Agda.TypeChecking.Free.Base.LensFlexRig (Agda.TypeChecking.Free.Base.VarOcc' a) a
+ Agda.TypeChecking.Free.Base: instance Agda.Utils.Null.Null Agda.TypeChecking.Free.Base.MetaSet
+ Agda.TypeChecking.Free.Base: instance Agda.Utils.Singleton.Singleton Agda.Syntax.Common.MetaId Agda.TypeChecking.Free.Base.MetaSet
+ Agda.TypeChecking.Free.Base: instance Agda.Utils.Singleton.Singleton Agda.TypeChecking.Free.Base.Variable (Agda.TypeChecking.Free.Base.VarMap' a)
+ Agda.TypeChecking.Free.Base: instance Data.Foldable.Foldable Agda.TypeChecking.Free.Base.FlexRig'
+ Agda.TypeChecking.Free.Base: instance GHC.Base.Functor Agda.TypeChecking.Free.Base.FlexRig'
+ Agda.TypeChecking.Free.Base: instance GHC.Base.Monoid Agda.TypeChecking.Free.Base.MetaSet
+ Agda.TypeChecking.Free.Base: instance GHC.Base.Monoid Agda.TypeChecking.Free.Base.VarCounts
+ Agda.TypeChecking.Free.Base: instance GHC.Base.Monoid a => GHC.Base.Monoid (Agda.TypeChecking.Free.Base.VarOcc' a)
+ Agda.TypeChecking.Free.Base: instance GHC.Base.Semigroup Agda.TypeChecking.Free.Base.MetaSet
+ Agda.TypeChecking.Free.Base: instance GHC.Base.Semigroup Agda.TypeChecking.Free.Base.VarCounts
+ Agda.TypeChecking.Free.Base: instance GHC.Base.Semigroup a => GHC.Base.Monoid (Agda.TypeChecking.Free.Base.VarMap' a)
+ Agda.TypeChecking.Free.Base: instance GHC.Base.Semigroup a => GHC.Base.Semigroup (Agda.TypeChecking.Free.Base.VarMap' a)
+ Agda.TypeChecking.Free.Base: instance GHC.Base.Semigroup a => GHC.Base.Semigroup (Agda.TypeChecking.Free.Base.VarOcc' a)
+ Agda.TypeChecking.Free.Base: instance GHC.Classes.Eq Agda.TypeChecking.Free.Base.IgnoreSorts
+ Agda.TypeChecking.Free.Base: instance GHC.Classes.Eq Agda.TypeChecking.Free.Base.MetaSet
+ Agda.TypeChecking.Free.Base: instance GHC.Classes.Eq Agda.TypeChecking.Free.Base.VarCounts
+ Agda.TypeChecking.Free.Base: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.TypeChecking.Free.Base.FlexRig' a)
+ Agda.TypeChecking.Free.Base: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.TypeChecking.Free.Base.VarMap' a)
+ Agda.TypeChecking.Free.Base: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.TypeChecking.Free.Base.VarOcc' a)
+ Agda.TypeChecking.Free.Base: instance GHC.Show.Show Agda.TypeChecking.Free.Base.IgnoreSorts
+ Agda.TypeChecking.Free.Base: instance GHC.Show.Show Agda.TypeChecking.Free.Base.MetaSet
+ Agda.TypeChecking.Free.Base: instance GHC.Show.Show Agda.TypeChecking.Free.Base.VarCounts
+ Agda.TypeChecking.Free.Base: instance GHC.Show.Show a => GHC.Show.Show (Agda.TypeChecking.Free.Base.FlexRig' a)
+ Agda.TypeChecking.Free.Base: instance GHC.Show.Show a => GHC.Show.Show (Agda.TypeChecking.Free.Base.VarMap' a)
+ Agda.TypeChecking.Free.Base: instance GHC.Show.Show a => GHC.Show.Show (Agda.TypeChecking.Free.Base.VarOcc' a)
+ Agda.TypeChecking.Free.Base: isFlexible :: LensFlexRig o a => o -> Bool
+ Agda.TypeChecking.Free.Base: isStronglyRigid :: LensFlexRig o a => o -> Bool
+ Agda.TypeChecking.Free.Base: isUnguarded :: LensFlexRig o a => o -> Bool
+ Agda.TypeChecking.Free.Base: isWeaklyRigid :: LensFlexRig o a => o -> Bool
+ Agda.TypeChecking.Free.Base: lensFlexRig :: LensFlexRig o a => Lens' o (FlexRig' a)
+ Agda.TypeChecking.Free.Base: lookupVarMap :: Variable -> VarMap' a -> Maybe (VarOcc' a)
+ Agda.TypeChecking.Free.Base: mapVarMap :: (TheVarMap' a -> TheVarMap' b) -> VarMap' a -> VarMap' b
+ Agda.TypeChecking.Free.Base: metaSetToBlocker :: MetaSet -> Blocker
+ Agda.TypeChecking.Free.Base: newtype MetaSet
+ Agda.TypeChecking.Free.Base: newtype VarCounts
+ Agda.TypeChecking.Free.Base: newtype VarMap' a
+ Agda.TypeChecking.Free.Base: omegaFlexRig :: FlexRig' a
+ Agda.TypeChecking.Free.Base: oneFlexRig :: FlexRig' a
+ Agda.TypeChecking.Free.Base: oneVarOcc :: VarOcc' a
+ Agda.TypeChecking.Free.Base: topVarOcc :: VarOcc' a
+ Agda.TypeChecking.Free.Base: type FlexRig = FlexRig' MetaSet
+ Agda.TypeChecking.Free.Base: type TheVarMap = TheVarMap' MetaSet
+ Agda.TypeChecking.Free.Base: type TheVarMap' a = IntMap VarOcc' a
+ Agda.TypeChecking.Free.Base: type VarMap = VarMap' MetaSet
+ Agda.TypeChecking.Free.Base: type VarOcc = VarOcc' MetaSet
+ Agda.TypeChecking.Free.Base: type Variable = Int
+ Agda.TypeChecking.Free.Base: zeroFlexRig :: Monoid a => FlexRig' a
+ Agda.TypeChecking.Free.Generic: -- <tt>StrictEndo</tt> from <a>StrictEndo</a>. The latter is used to
+ Agda.TypeChecking.Free.Generic: -- efficiently accummulate sets or maps.
+ Agda.TypeChecking.Free.Generic: -- newtype wrapper on <a>Bool</a> or some instantiation of
+ Agda.TypeChecking.Free.Generic: -- | The result type of the traversal. Most commonly, this is either a
+ Agda.TypeChecking.Free.Generic: class (ExpandCase Collect r, Monoid Collect r) => ComputeFree r where {
+ Agda.TypeChecking.Free.Generic: class Free t
+ Agda.TypeChecking.Free.Generic: defaultUnderConstructor :: (Semigroup a, LensFlexRig r a) => ConHead -> Elims -> r -> r
+ Agda.TypeChecking.Free.Generic: defaultUnderFlexRig :: (Semigroup a, LensFlexRig r a) => Maybe (FlexRig' a -> r -> r)
+ Agda.TypeChecking.Free.Generic: defaultUnderModality :: LensModality r => Maybe (Modality -> r -> r)
+ Agda.TypeChecking.Free.Generic: defaultUnderRelevance :: LensRelevance r => Maybe (Relevance -> r -> r)
+ Agda.TypeChecking.Free.Generic: freeVars :: (Free t, ComputeFree r) => t -> Reader r (Collect r)
+ Agda.TypeChecking.Free.Generic: ignoreSorts' :: ComputeFree r => IgnoreSorts
+ Agda.TypeChecking.Free.Generic: instance (Agda.TypeChecking.Free.Generic.Free a, Agda.TypeChecking.Free.Generic.Free b) => Agda.TypeChecking.Free.Generic.Free (a, b)
+ Agda.TypeChecking.Free.Generic: instance (Agda.TypeChecking.Free.Generic.Free a, Agda.TypeChecking.Free.Generic.Free b, Agda.TypeChecking.Free.Generic.Free c) => Agda.TypeChecking.Free.Generic.Free (a, b, c)
+ Agda.TypeChecking.Free.Generic: instance (Agda.TypeChecking.Free.Generic.Free a, Agda.TypeChecking.Free.Generic.Free b, Agda.TypeChecking.Free.Generic.Free c, Agda.TypeChecking.Free.Generic.Free d) => Agda.TypeChecking.Free.Generic.Free (a, b, c, d)
+ Agda.TypeChecking.Free.Generic: instance (Agda.TypeChecking.Free.Generic.Free a, Agda.TypeChecking.Free.Generic.Free b, Agda.TypeChecking.Free.Generic.Free c, Agda.TypeChecking.Free.Generic.Free d, Agda.TypeChecking.Free.Generic.Free e) => Agda.TypeChecking.Free.Generic.Free (a, b, c, d, e)
+ Agda.TypeChecking.Free.Generic: instance Agda.TypeChecking.Free.Generic.Free Agda.Syntax.Internal.Clause
+ Agda.TypeChecking.Free.Generic: instance Agda.TypeChecking.Free.Generic.Free Agda.Syntax.Internal.EqualityView
+ Agda.TypeChecking.Free.Generic: instance Agda.TypeChecking.Free.Generic.Free Agda.Syntax.Internal.Level
+ Agda.TypeChecking.Free.Generic: instance Agda.TypeChecking.Free.Generic.Free Agda.Syntax.Internal.LocalEquation
+ Agda.TypeChecking.Free.Generic: instance Agda.TypeChecking.Free.Generic.Free Agda.Syntax.Internal.NLPSort
+ Agda.TypeChecking.Free.Generic: instance Agda.TypeChecking.Free.Generic.Free Agda.Syntax.Internal.NLPType
+ Agda.TypeChecking.Free.Generic: instance Agda.TypeChecking.Free.Generic.Free Agda.Syntax.Internal.NLPat
+ Agda.TypeChecking.Free.Generic: instance Agda.TypeChecking.Free.Generic.Free Agda.Syntax.Internal.RewriteHead
+ Agda.TypeChecking.Free.Generic: instance Agda.TypeChecking.Free.Generic.Free Agda.Syntax.Internal.RewriteRule
+ Agda.TypeChecking.Free.Generic: instance Agda.TypeChecking.Free.Generic.Free Agda.Syntax.Internal.Sort
+ Agda.TypeChecking.Free.Generic: instance Agda.TypeChecking.Free.Generic.Free Agda.Syntax.Internal.Term
+ Agda.TypeChecking.Free.Generic: instance Agda.TypeChecking.Free.Generic.Free t => Agda.TypeChecking.Free.Generic.Free (Agda.Syntax.Common.Arg t)
+ Agda.TypeChecking.Free.Generic: instance Agda.TypeChecking.Free.Generic.Free t => Agda.TypeChecking.Free.Generic.Free (Agda.Syntax.Internal.Abs t)
+ Agda.TypeChecking.Free.Generic: instance Agda.TypeChecking.Free.Generic.Free t => Agda.TypeChecking.Free.Generic.Free (Agda.Syntax.Internal.Dom t)
+ Agda.TypeChecking.Free.Generic: instance Agda.TypeChecking.Free.Generic.Free t => Agda.TypeChecking.Free.Generic.Free (Agda.Syntax.Internal.Elim.Elim' t)
+ Agda.TypeChecking.Free.Generic: instance Agda.TypeChecking.Free.Generic.Free t => Agda.TypeChecking.Free.Generic.Free (Agda.Syntax.Internal.PlusLevel' t)
+ Agda.TypeChecking.Free.Generic: instance Agda.TypeChecking.Free.Generic.Free t => Agda.TypeChecking.Free.Generic.Free (Agda.Syntax.Internal.Tele t)
+ Agda.TypeChecking.Free.Generic: instance Agda.TypeChecking.Free.Generic.Free t => Agda.TypeChecking.Free.Generic.Free (Agda.Syntax.Internal.Type' t)
+ Agda.TypeChecking.Free.Generic: instance Agda.TypeChecking.Free.Generic.Free t => Agda.TypeChecking.Free.Generic.Free (Agda.Utils.List1.List1 t)
+ Agda.TypeChecking.Free.Generic: instance Agda.TypeChecking.Free.Generic.Free t => Agda.TypeChecking.Free.Generic.Free (GHC.Maybe.Maybe t)
+ Agda.TypeChecking.Free.Generic: instance Agda.TypeChecking.Free.Generic.Free t => Agda.TypeChecking.Free.Generic.Free [t]
+ Agda.TypeChecking.Free.Generic: type Collect r;
+ Agda.TypeChecking.Free.Generic: underBinder :: ComputeFree r => Reader r (Collect r) -> Reader r (Collect r)
+ Agda.TypeChecking.Free.Generic: underBinders :: ComputeFree r => Int -> Reader r (Collect r) -> Reader r (Collect r)
+ Agda.TypeChecking.Free.Generic: underBinders' :: ComputeFree r => Int -> r -> r
+ Agda.TypeChecking.Free.Generic: underConstructor :: ComputeFree r => ConHead -> Elims -> Reader r (Collect r) -> Reader r (Collect r)
+ Agda.TypeChecking.Free.Generic: underConstructor' :: ComputeFree r => ConHead -> Elims -> r -> r
+ Agda.TypeChecking.Free.Generic: underFlexRig :: ComputeFree r => FlexRig -> Reader r (Collect r) -> Reader r (Collect r)
+ Agda.TypeChecking.Free.Generic: underFlexRig' :: ComputeFree r => Maybe (FlexRig -> r -> r)
+ Agda.TypeChecking.Free.Generic: underModality :: ComputeFree r => Modality -> Reader r (Collect r) -> Reader r (Collect r)
+ Agda.TypeChecking.Free.Generic: underModality' :: ComputeFree r => Maybe (Modality -> r -> r)
+ Agda.TypeChecking.Free.Generic: underRelevance :: ComputeFree r => Relevance -> Reader r (Collect r) -> Reader r (Collect r)
+ Agda.TypeChecking.Free.Generic: underRelevance' :: ComputeFree r => Maybe (Relevance -> r -> r)
+ Agda.TypeChecking.Free.Generic: variable :: ComputeFree r => Int -> Reader r (Collect r)
+ Agda.TypeChecking.Free.Generic: variable' :: ComputeFree r => Int -> r -> Collect r
+ Agda.TypeChecking.Free.Generic: }
+ Agda.TypeChecking.Free.Reduce: forceNonDep :: (Reduce a, ForceNotFree a) => a -> ReduceM (IsFree, a)
+ Agda.TypeChecking.Free.Reduce: forceNonDepSort :: Sort -> ReduceM (IsFree, Sort)
+ Agda.TypeChecking.Free.Reduce: nonFreeVars :: IntMap IsFree -> VarSet
+ Agda.TypeChecking.Implicit: implicitCheckedArgs :: Int -> (Hiding -> ArgName -> Bool) -> Type -> TCM ([Named_ CheckedArg], Type)
+ Agda.TypeChecking.Implicit: makeLockConstraint :: Type -> Term -> TCM (Maybe (Abs Constraint))
+ Agda.TypeChecking.Implicit: noHeadConstraint :: CheckedArg -> TCM Elim
+ Agda.TypeChecking.Implicit: noHeadConstraints :: [CheckedArg] -> TCM [Elim]
+ Agda.TypeChecking.Irrelevance: checkAllIrrelevanceAllowed :: (Traversable f, LensRelevance a) => f a -> TCM ()
+ Agda.TypeChecking.Irrelevance: checkIrrelevanceAllowed :: LensRelevance a => a -> TCM ()
+ Agda.TypeChecking.Irrelevance: isDefSing :: (PureTCM m, MonadBlock m) => Nat -> Nat -> Type -> m DefSing
+ Agda.TypeChecking.Irrelevance: isDefSing' :: (PureTCM m, MonadBlock m) => Nat -> Nat -> Dom Type -> m DefSing
+ Agda.TypeChecking.Irrelevance: isPatternVar :: Nat -> Nat -> Nat -> Bool
+ Agda.TypeChecking.Level: instance Agda.TypeChecking.Free.Generic.Free t => Agda.TypeChecking.Free.Generic.Free (Agda.TypeChecking.Level.SingleLevel' t)
+ Agda.TypeChecking.MetaVars: allRewDoms :: Tele (Dom Type) -> [RewDom]
+ Agda.TypeChecking.MetaVars: isRewPi :: Term -> Bool
+ Agda.TypeChecking.MetaVars: rewConstrained :: Tele (Dom Type) -> TCM VarSet
+ Agda.TypeChecking.MetaVars.Mention: instance (Agda.TypeChecking.MetaVars.Mention.MentionsMeta a, Agda.TypeChecking.MetaVars.Mention.MentionsMeta b, Agda.TypeChecking.MetaVars.Mention.MentionsMeta c, Agda.TypeChecking.MetaVars.Mention.MentionsMeta d) => Agda.TypeChecking.MetaVars.Mention.MentionsMeta (a, b, c, d)
+ Agda.TypeChecking.MetaVars.Mention: instance Agda.TypeChecking.MetaVars.Mention.MentionsMeta Agda.Syntax.Internal.LocalEquation
+ Agda.TypeChecking.MetaVars.Mention: instance Agda.TypeChecking.MetaVars.Mention.MentionsMeta t => Agda.TypeChecking.MetaVars.Mention.MentionsMeta (Agda.Syntax.Internal.BlockedDepCheck t)
+ Agda.TypeChecking.MetaVars.Occurs: instance Agda.Syntax.Common.LensModality Agda.TypeChecking.MetaVars.Occurs.OccursCxt
+ Agda.TypeChecking.MetaVars.Occurs: instance Agda.Syntax.Common.LensQuantity Agda.TypeChecking.MetaVars.Occurs.OccursCxt
+ Agda.TypeChecking.MetaVars.Occurs: instance Agda.Syntax.Common.LensRelevance Agda.TypeChecking.MetaVars.Occurs.OccursCxt
+ Agda.TypeChecking.MetaVars.Occurs: instance Agda.TypeChecking.Free.Base.LensFlexRig Agda.TypeChecking.MetaVars.Occurs.OccursCxt ()
+ Agda.TypeChecking.Monad.Base: ($dmgetSessionState) :: forall (t :: (Type -> Type) -> Type -> Type) (n :: Type -> Type). (ReadTCState m, MonadTrans t, ReadTCState n, t n ~ m) => m SessionState
+ Agda.TypeChecking.Monad.Base: CannotGeneralizeEtaExpandable :: QName -> Type -> TypeError
+ Agda.TypeChecking.Monad.Base: CannotGenerateTransportLocalRewrite :: QName -> TypeError
+ Agda.TypeChecking.Monad.Base: CheckLocalRewriteConstraint :: LocalEquation -> Maybe (Closure Call) -> Call
+ Agda.TypeChecking.Monad.Base: ClashingAbstractName :: AbstractName -> ClashingName
+ Agda.TypeChecking.Monad.Base: ClashingQName :: QName -> ClashingName
+ Agda.TypeChecking.Monad.Base: ColdEnv :: ModuleName -> !Maybe Int -> Maybe FileId -> [(ModuleName, Nat)] -> [TopLevelModuleName] -> !Maybe MutualId -> !TerminationCheck () -> !CoverageCheck -> !WhereClause_ -> !Maybe ProblemId -> !AbstractMode -> Range -> Range -> IPClause -> Maybe (Closure Call) -> !HighlightingLevel -> !HighlightingMethod -> !ExpandHidden -> !Simplification -> !ReduceDefs -> !Int -> !UnquoteFlags -> !Int -> [QName] -> !DoGeneralize -> !Map QName GeneralizedValue -> !Maybe BackendName -> !Maybe OpaqueId -> !Maybe String -> ColdEnv
+ Agda.TypeChecking.Monad.Base: ConversionError_ :: ConversionError -> TypeError
+ Agda.TypeChecking.Monad.Base: CopatternsNotAllowed :: NotAValidLetBinding
+ Agda.TypeChecking.Monad.Base: DefinitionBeforeDeclaration :: AbstractName -> Warning
+ Agda.TypeChecking.Monad.Base: ErasedMatchesDisabledDependent :: ErasedDatatypeReason
+ Agda.TypeChecking.Monad.Base: ErasedMatchesDisabledEmpty :: ErasedDatatypeReason
+ Agda.TypeChecking.Monad.Base: ErasedMatchesDisabledNonDependent :: ErasedDatatypeReason
+ Agda.TypeChecking.Monad.Base: EscapingVariable :: Closure Term -> UnquoteError
+ Agda.TypeChecking.Monad.Base: EtaEquality :: !HasEta -> !EtaProvenance -> EtaEquality
+ Agda.TypeChecking.Monad.Base: EtaFromDirective :: EtaProvenance
+ Agda.TypeChecking.Monad.Base: EtaFromOption :: EtaProvenance
+ Agda.TypeChecking.Monad.Base: EtaFromPragma :: EtaProvenance
+ Agda.TypeChecking.Monad.Base: EtaPragmaVsNoEtaEquality :: TypeError
+ Agda.TypeChecking.Monad.Base: Flags64 :: Word64 -> Flags64
+ Agda.TypeChecking.Monad.Base: GeneralizationFailed :: Doc -> TypeError
+ Agda.TypeChecking.Monad.Base: GeneralizationPrepruneErrorCyclicDependencies :: Closure MetaId -> TypeError
+ Agda.TypeChecking.Monad.Base: GeneralizationPrepruneErrorFailedToInstantiate :: Closure MetaId -> TypeError
+ Agda.TypeChecking.Monad.Base: GeneralizationPrepruneErrorRefinedContext :: Closure MetaId -> TypeError
+ Agda.TypeChecking.Monad.Base: GlobalRewrite :: a -> RewriteSource' a
+ Agda.TypeChecking.Monad.Base: GlobalRewriteRule :: QName -> Telescope -> QName -> PElims -> Term -> Type -> Bool -> TopLevelModuleName -> GlobalRewriteRule
+ Agda.TypeChecking.Monad.Base: IgnoringRew :: String -> RewriteAnn -> Warning
+ Agda.TypeChecking.Monad.Base: IlltypedRewriteRule :: Doc -> TypeError
+ Agda.TypeChecking.Monad.Base: InferredLocalRewrite :: MetaId -> Term -> Warning
+ Agda.TypeChecking.Monad.Base: LocalRewrite :: Context -> Maybe Name -> Type -> RewriteSource' a
+ Agda.TypeChecking.Monad.Base: LocalRewriteOutsideTelescope :: IllegalRewriteRuleReason
+ Agda.TypeChecking.Monad.Base: LocalRewriteRuleMap :: HashMap QName [Open RewriteRule] -> IntMap [Open RewriteRule] -> LocalRewriteRuleMap
+ Agda.TypeChecking.Monad.Base: MissingBindingsForTelescopeVariables :: List1 Text -> TypeError
+ Agda.TypeChecking.Monad.Base: ModalEnv :: !Relevance -> !Quantity -> !LetBindings -> !AllowedReductions -> ModalEnv
+ Agda.TypeChecking.Monad.Base: ModuleCheckpointsSection :: !ModuleCheckpoints -> !Set ModuleName -> {-# UNPACK #-} !CheckpointId -> ModuleCheckpoints
+ Agda.TypeChecking.Monad.Base: ModuleCheckpointsTop :: ModuleCheckpoints
+ Agda.TypeChecking.Monad.Base: NamedWhereModuleUnderWith :: TypeError
+ Agda.TypeChecking.Monad.Base: NeedOptionIrrelevance :: TypeError
+ Agda.TypeChecking.Monad.Base: NoAxiom :: IsAxiom
+ Agda.TypeChecking.Monad.Base: PathCons :: IsPathCons
+ Agda.TypeChecking.Monad.Base: PointCons :: IsPathCons
+ Agda.TypeChecking.Monad.Base: PostColdState :: !Flags64 -> !HighlightingInfo -> !DisambiguatedNames -> !InteractionPoints -> !Signature -> !DisplayForms -> !BackendForeignCode -> !Maybe (Pair ModuleName TopLevelModuleName) -> !Set QName -> !Set QName -> !ConcreteNames -> !Statistics -> !Set TCWarning -> !MutualBlocks -> !BuiltinThings -> !MutualId -> !Int -> !NameId -> !OpaqueId -> !Set QName -> !Map OpaqueId OpaqueBlock -> !Map QName OpaqueId -> PostColdState
+ Agda.TypeChecking.Monad.Base: PostMetaState :: !MetaId -> !ProblemId -> !LocalMetaStore -> !LocalMetaStore -> !Constraints -> !Constraints -> !Set QName -> PostMetaState
+ Agda.TypeChecking.Monad.Base: PostNamesCheckpoints :: !ModuleCheckpoints -> !CheckpointId -> PostNamesCheckpoints
+ Agda.TypeChecking.Monad.Base: ReduceM# :: (ReduceEnv -> a) -> ReduceM a
+ Agda.TypeChecking.Monad.Base: RewConstraint :: LocalEquation -> Constraint
+ Agda.TypeChecking.Monad.Base: RewriteNoMatchReductions :: AllowedReduction
+ Agda.TypeChecking.Monad.Base: SessionState :: [Backend] -> !FileDictWithBuiltins -> !ModuleToSourceId -> InteractionOutputCallback -> SessionState
+ Agda.TypeChecking.Monad.Base: ShouldBeEtaRecordPattern :: Warning
+ Agda.TypeChecking.Monad.Base: Statistics :: !HashMap String (Sum Word64) -> !HashMap String (Max Word64) -> Statistics
+ Agda.TypeChecking.Monad.Base: TCContext :: !Context -> !CheckpointId -> LocalRewriteRuleMap -> Map CheckpointId Substitution -> !Maybe QName -> TCContext
+ Agda.TypeChecking.Monad.Base: TCM# :: (MutVar# RealWorld TCState -> TCEnv -> m a) -> TCMT (m :: Type -> Type) a
+ Agda.TypeChecking.Monad.Base: TrustedBuiltin :: BuiltinId -> TypeError
+ Agda.TypeChecking.Monad.Base: TrustedPrimitive :: QName -> TypeError
+ Agda.TypeChecking.Monad.Base: UnguardedEtaRecord :: QName -> TypeError
+ Agda.TypeChecking.Monad.Base: UnguardedEtaRecordW :: QName -> Warning
+ Agda.TypeChecking.Monad.Base: UnifyVarInRewrite :: Telescope -> Type -> Int -> Term -> UnificationFailure
+ Agda.TypeChecking.Monad.Base: UnifyVarInRewriteEta :: Telescope -> Int -> UnificationFailure
+ Agda.TypeChecking.Monad.Base: UnknownJSPrimitive :: String -> Warning
+ Agda.TypeChecking.Monad.Base: UnusedImports :: ModuleName -> Maybe (List1 ImportedName) -> Warning
+ Agda.TypeChecking.Monad.Base: UserError :: Doc -> TypeError
+ Agda.TypeChecking.Monad.Base: VariablesBoundInSingleton :: VarSet -> IllegalRewriteRuleReason
+ Agda.TypeChecking.Monad.Base: WrongNamedArgumentInLHS :: Hiding -> ArgName -> [ArgName] -> TypeError
+ Agda.TypeChecking.Monad.Base: YesAxiom :: IsAxiom
+ Agda.TypeChecking.Monad.Base: [_conPathCons] :: ConstructorData -> !IsPathCons
+ Agda.TypeChecking.Monad.Base: [_dataHIT] :: DatatypeData -> !IsHIT
+ Agda.TypeChecking.Monad.Base: [_dataPositivityCheck] :: DatatypeData -> PositivityCheck
+ Agda.TypeChecking.Monad.Base: [_datarecKind] :: DataOrRecSigData -> !DataOrRecord_
+ Agda.TypeChecking.Monad.Base: [_recPositivityCheck] :: RecordData -> PositivityCheck
+ Agda.TypeChecking.Monad.Base: [defCopatternLHS'] :: Definition -> Bool
+ Agda.TypeChecking.Monad.Base: [defHeadedRews] :: LocalRewriteRuleMap -> HashMap QName [Open RewriteRule]
+ Agda.TypeChecking.Monad.Base: [defMightContainMetas] :: Definition -> !Bool
+ Agda.TypeChecking.Monad.Base: [envChasePrefix] :: ColdEnv -> !Maybe String
+ Agda.TypeChecking.Monad.Base: [envColdEnv] :: TCEnv -> !ColdEnv
+ Agda.TypeChecking.Monad.Base: [envFlags] :: TCEnv -> !Flags64
+ Agda.TypeChecking.Monad.Base: [envImportStack] :: ColdEnv -> [TopLevelModuleName]
+ Agda.TypeChecking.Monad.Base: [envLocalRewriteRules] :: TCContext -> LocalRewriteRuleMap
+ Agda.TypeChecking.Monad.Base: [envModalEnv] :: TCEnv -> !ModalEnv
+ Agda.TypeChecking.Monad.Base: [envTCContext] :: TCEnv -> !TCContext
+ Agda.TypeChecking.Monad.Base: [etaProvenance] :: EtaEquality -> !EtaProvenance
+ Agda.TypeChecking.Monad.Base: [grContext] :: GlobalRewriteRule -> Telescope
+ Agda.TypeChecking.Monad.Base: [grFromClause] :: GlobalRewriteRule -> Bool
+ Agda.TypeChecking.Monad.Base: [grHead] :: GlobalRewriteRule -> QName
+ Agda.TypeChecking.Monad.Base: [grName] :: GlobalRewriteRule -> QName
+ Agda.TypeChecking.Monad.Base: [grPats] :: GlobalRewriteRule -> PElims
+ Agda.TypeChecking.Monad.Base: [grRHS] :: GlobalRewriteRule -> Term
+ Agda.TypeChecking.Monad.Base: [grTopModule] :: GlobalRewriteRule -> TopLevelModuleName
+ Agda.TypeChecking.Monad.Base: [grType] :: GlobalRewriteRule -> Type
+ Agda.TypeChecking.Monad.Base: [letAxiom] :: LetBinding -> IsAxiom
+ Agda.TypeChecking.Monad.Base: [miIsBuiltin] :: ModuleInfo -> !Maybe IsBuiltinModule
+ Agda.TypeChecking.Monad.Base: [miSourceFile] :: ModuleInfo -> SourceFile
+ Agda.TypeChecking.Monad.Base: [redSess] :: ReduceEnv -> !SessionState
+ Agda.TypeChecking.Monad.Base: [stPostColdState] :: PostScopeState -> !PostColdState
+ Agda.TypeChecking.Monad.Base: [stPostFlags] :: PostColdState -> !Flags64
+ Agda.TypeChecking.Monad.Base: [stPostMetaState] :: PostScopeState -> !PostMetaState
+ Agda.TypeChecking.Monad.Base: [stPostNamesCheckpoints] :: PostScopeState -> !PostNamesCheckpoints
+ Agda.TypeChecking.Monad.Base: [stPreFileId] :: PreScopeState -> !Maybe FileId
+ Agda.TypeChecking.Monad.Base: [stPreUnusedImportsState] :: PreScopeState -> !UnusedImportsState
+ Agda.TypeChecking.Monad.Base: [stSessionInteractionOutputCallback] :: SessionState -> InteractionOutputCallback
+ Agda.TypeChecking.Monad.Base: [stSessionModuleToSourceId] :: SessionState -> !ModuleToSourceId
+ Agda.TypeChecking.Monad.Base: [statMaxes] :: Statistics -> !HashMap String (Max Word64)
+ Agda.TypeChecking.Monad.Base: [statTicks] :: Statistics -> !HashMap String (Sum Word64)
+ Agda.TypeChecking.Monad.Base: [unTCM#] :: TCMT (m :: Type -> Type) a -> MutVar# RealWorld TCState -> TCEnv -> m a
+ Agda.TypeChecking.Monad.Base: [varHeadedRews] :: LocalRewriteRuleMap -> IntMap [Open RewriteRule]
+ Agda.TypeChecking.Monad.Base: anyRewritingOption :: HasOptions m => m Bool
+ Agda.TypeChecking.Monad.Base: clashingQName :: ClashingName -> QName
+ Agda.TypeChecking.Monad.Base: class ReadTCState m => ModifySession (m :: Type -> Type)
+ Agda.TypeChecking.Monad.Base: conPathCons :: Defn -> IsPathCons
+ Agda.TypeChecking.Monad.Base: data ClashingName
+ Agda.TypeChecking.Monad.Base: data ColdEnv
+ Agda.TypeChecking.Monad.Base: data EtaProvenance
+ Agda.TypeChecking.Monad.Base: data GlobalRewriteRule
+ Agda.TypeChecking.Monad.Base: data IsAxiom
+ Agda.TypeChecking.Monad.Base: data IsPathCons
+ Agda.TypeChecking.Monad.Base: data LocalRewriteRuleMap
+ Agda.TypeChecking.Monad.Base: data ModalEnv
+ Agda.TypeChecking.Monad.Base: data ModuleCheckpoints
+ Agda.TypeChecking.Monad.Base: data PostColdState
+ Agda.TypeChecking.Monad.Base: data PostMetaState
+ Agda.TypeChecking.Monad.Base: data PostNamesCheckpoints
+ Agda.TypeChecking.Monad.Base: data RewriteSource' a
+ Agda.TypeChecking.Monad.Base: data SessionState
+ Agda.TypeChecking.Monad.Base: data Statistics
+ Agda.TypeChecking.Monad.Base: data TCContext
+ Agda.TypeChecking.Monad.Base: dataHIT :: Defn -> IsHIT
+ Agda.TypeChecking.Monad.Base: dataPositivityCheck :: Defn -> PositivityCheck
+ Agda.TypeChecking.Monad.Base: datarecKind :: Defn -> DataOrRecord_
+ Agda.TypeChecking.Monad.Base: defCopyClause :: Definition -> Maybe Term
+ Agda.TypeChecking.Monad.Base: defCopyOrClauses :: Definition -> Either Term ([Clause], Maybe CompiledClauses)
+ Agda.TypeChecking.Monad.Base: eChasePrefix :: Lens' TCEnv (Maybe String)
+ Agda.TypeChecking.Monad.Base: eClause :: Lens' TCEnv IPClause
+ Agda.TypeChecking.Monad.Base: eCurrentOpaqueId :: Lens' TCEnv (Maybe OpaqueId)
+ Agda.TypeChecking.Monad.Base: eImplPrimitiveImporting :: Lens' TCEnv Bool
+ Agda.TypeChecking.Monad.Base: eImportStack :: Lens' TCEnv [TopLevelModuleName]
+ Agda.TypeChecking.Monad.Base: eLocalRewriteRules :: Lens' TCEnv LocalRewriteRuleMap
+ Agda.TypeChecking.Monad.Base: ePureConversion :: Lens' TCEnv Bool
+ Agda.TypeChecking.Monad.Base: eQuantityZeroHardCompile :: Lens' TCEnv Quantity
+ Agda.TypeChecking.Monad.Base: eSyntacticEqualityFuel :: Lens' TCEnv (Maybe Int)
+ Agda.TypeChecking.Monad.Base: eUnquoteProblem :: Lens' TCEnv (Maybe ProblemId)
+ Agda.TypeChecking.Monad.Base: envAssignMetas :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: envCallByNeed :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: envCompareBlocked :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: envConflComputingOverlap :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: envCurrentlyElaborating :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: envDisplayFormsEnabled :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: envFoldLetBindings :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: envHardCompileTimeMode :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: envImplPrimitiveImporting :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: envInsideDotPattern :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: envIsDebugPrinting :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: envMakeCase :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: envPrintDomainFreePi :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: envPrintMetasBare :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: envPureConversion :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: envReconstructed :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: envSolvingConstraints :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: envSplitOnStrict :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: envWorkingOnTypes :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: generalizeConstructorName :: String
+ Agda.TypeChecking.Monad.Base: generalizeRecordName :: String
+ Agda.TypeChecking.Monad.Base: getFlag :: Int -> Flags64 -> Bool
+ Agda.TypeChecking.Monad.Base: getSessionState :: ReadTCState m => m SessionState
+ Agda.TypeChecking.Monad.Base: grHasProjectionPattern :: GlobalRewriteRule -> Bool
+ Agda.TypeChecking.Monad.Base: ifImpureConv :: TCM a -> TCM a -> TCM a
+ Agda.TypeChecking.Monad.Base: initColdEnv :: ColdEnv
+ Agda.TypeChecking.Monad.Base: initEnvFlags :: Flags64
+ Agda.TypeChecking.Monad.Base: initModalEnv :: ModalEnv
+ Agda.TypeChecking.Monad.Base: initPostColdState :: PostColdState
+ Agda.TypeChecking.Monad.Base: initPostFlags :: Flags64
+ Agda.TypeChecking.Monad.Base: initPostMetaState :: PostMetaState
+ Agda.TypeChecking.Monad.Base: initPostNamesCheckpoints :: PostNamesCheckpoints
+ Agda.TypeChecking.Monad.Base: initTCContext :: TCContext
+ Agda.TypeChecking.Monad.Base: instance (Control.Monad.IO.Class.MonadIO m, Control.Monad.Catch.MonadMask m) => Agda.TypeChecking.Monad.Base.ModifySession (Agda.TypeChecking.Monad.Base.TCMT m)
+ Agda.TypeChecking.Monad.Base: instance (Control.Monad.IO.Class.MonadIO m, GHC.Base.Monoid a) => GHC.Base.Monoid (Agda.TypeChecking.Monad.Base.TCMT m a)
+ Agda.TypeChecking.Monad.Base: instance (GHC.Base.Monoid w, Agda.TypeChecking.Monad.Base.MonadReduce m) => Agda.TypeChecking.Monad.Base.MonadReduce (Agda.Utils.StrictWriter.WriterT w m)
+ Agda.TypeChecking.Monad.Base: instance (GHC.Base.Monoid w, Agda.TypeChecking.Monad.Base.MonadTCEnv m) => Agda.TypeChecking.Monad.Base.MonadTCEnv (Agda.Utils.StrictWriter.WriterT w m)
+ Agda.TypeChecking.Monad.Base: instance (GHC.Base.Monoid w, Agda.TypeChecking.Monad.Base.MonadTCM tcm) => Agda.TypeChecking.Monad.Base.MonadTCM (Agda.Utils.StrictWriter.WriterT w tcm)
+ Agda.TypeChecking.Monad.Base: instance (GHC.Base.Monoid w, Agda.TypeChecking.Monad.Base.MonadTCState m) => Agda.TypeChecking.Monad.Base.MonadTCState (Agda.Utils.StrictWriter.WriterT w m)
+ Agda.TypeChecking.Monad.Base: instance (GHC.Base.Monoid w, Agda.TypeChecking.Monad.Base.ReadTCState m) => Agda.TypeChecking.Monad.Base.ReadTCState (Agda.Utils.StrictWriter.WriterT w m)
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Common.LensIsAbstract Agda.TypeChecking.Monad.Base.MetaVariable
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Common.Pretty.Pretty Agda.TypeChecking.Monad.Base.ModuleCheckpoints
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Common.Pretty.Pretty a => Agda.Syntax.Common.Pretty.Pretty (Agda.Syntax.Common.DataOrRecord' a)
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Common.Pretty.Pretty a => Agda.Syntax.Common.Pretty.Pretty (Agda.TypeChecking.Monad.Base.Types.IsWithFunction a)
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Internal.Generic.TermLike Agda.Syntax.Internal.LocalEquation
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Internal.Generic.TermLike Agda.Syntax.Internal.NLPSort
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Internal.Generic.TermLike Agda.Syntax.Internal.NLPType
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Internal.Generic.TermLike Agda.Syntax.Internal.NLPat
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Internal.MetaVars.AllMetas Agda.Syntax.Internal.NLPSort
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Internal.MetaVars.AllMetas Agda.Syntax.Internal.NLPType
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Internal.MetaVars.AllMetas Agda.Syntax.Internal.NLPat
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Internal.MetaVars.AllMetas Agda.TypeChecking.Monad.Base.PrincipalArgTypeMetas
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Position.KillRange (Agda.TypeChecking.Monad.Base.Closure a)
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Position.KillRange Agda.TypeChecking.Monad.Base.GlobalRewriteRule
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Position.KillRange Agda.TypeChecking.Monad.Base.GlobalRewriteRuleMap
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Position.KillRange Agda.TypeChecking.Monad.Base.IsPathCons
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Position.KillRange a => Agda.Syntax.Position.KillRange (Agda.TypeChecking.Monad.Base.Types.IsWithFunction a)
+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Free.Generic.Free Agda.TypeChecking.Monad.Base.Candidate
+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Free.Generic.Free Agda.TypeChecking.Monad.Base.CompareAs
+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Free.Generic.Free Agda.TypeChecking.Monad.Base.Constraint
+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.FreshName Agda.Syntax.Concrete.Name.Name
+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.ModifySession m => Agda.TypeChecking.Monad.Base.ModifySession (Control.Monad.Trans.Maybe.MaybeT m)
+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.ModifySession m => Agda.TypeChecking.Monad.Base.ModifySession (Control.Monad.Trans.State.Lazy.StateT s m)
+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.MonadBlock m => Agda.TypeChecking.Monad.Base.MonadBlock (Agda.Utils.StrictReader.ReaderT e m)
+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.MonadReduce m => Agda.TypeChecking.Monad.Base.MonadReduce (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.MonadReduce m => Agda.TypeChecking.Monad.Base.MonadReduce (Agda.Utils.StrictState.StateT w m)
+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.MonadTCEnv m => Agda.TypeChecking.Monad.Base.MonadTCEnv (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.MonadTCEnv m => Agda.TypeChecking.Monad.Base.MonadTCEnv (Agda.Utils.StrictState.StateT s m)
+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.MonadTCM tcm => Agda.TypeChecking.Monad.Base.MonadTCM (Agda.Utils.StrictReader.ReaderT r tcm)
+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.MonadTCM tcm => Agda.TypeChecking.Monad.Base.MonadTCM (Agda.Utils.StrictState.StateT s tcm)
+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.MonadTCState m => Agda.TypeChecking.Monad.Base.MonadTCState (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.MonadTCState m => Agda.TypeChecking.Monad.Base.MonadTCState (Agda.Utils.StrictState.StateT s m)
+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.ReadTCState m => Agda.TypeChecking.Monad.Base.ReadTCState (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.ReadTCState m => Agda.TypeChecking.Monad.Base.ReadTCState (Agda.Utils.StrictState.StateT s m)
+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.ExpandCase.ExpandCase (Agda.TypeChecking.Monad.Base.TCM a)
+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.ExpandCase.ExpandCase a => Agda.Utils.ExpandCase.ExpandCase (Agda.TypeChecking.Monad.Base.ReduceM a)
+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.FileId.MonadFileId m => Agda.Utils.FileId.MonadFileId (Agda.TypeChecking.Monad.Base.BlockT m)
+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.Null.Null Agda.TypeChecking.Monad.Base.LocalRewriteRuleMap
+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.Null.Null Agda.TypeChecking.Monad.Base.Statistics
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.Syntax.Scope.Base.OpenedModule
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.Syntax.Scope.Base.UnusedImportsState
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.ClashingName
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.ColdEnv
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.EtaProvenance
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.Flags64
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.GlobalRewriteRule
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.IsAxiom
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.IsPathCons
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.LocalRewriteRuleMap
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.ModalEnv
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.ModuleCheckpoints
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.PostColdState
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.PostMetaState
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.PostNamesCheckpoints
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.SerialisableRewriteSource
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.SessionState
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.Statistics
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.TCContext
+ Agda.TypeChecking.Monad.Base: instance Control.Monad.Error.Class.MonadError Agda.TypeChecking.Monad.Base.TCErr Agda.TypeChecking.Monad.Base.TCM
+ Agda.TypeChecking.Monad.Base: instance Control.Monad.Fail.MonadFail Agda.TypeChecking.Monad.Base.TCM
+ Agda.TypeChecking.Monad.Base: instance GHC.Base.Functor Agda.TypeChecking.Monad.Base.RewriteSource'
+ Agda.TypeChecking.Monad.Base: instance GHC.Base.Monoid Agda.TypeChecking.Monad.Base.Statistics
+ Agda.TypeChecking.Monad.Base: instance GHC.Base.Semigroup Agda.TypeChecking.Monad.Base.Statistics
+ Agda.TypeChecking.Monad.Base: instance GHC.Classes.Eq Agda.TypeChecking.Monad.Base.EtaProvenance
+ Agda.TypeChecking.Monad.Base: instance GHC.Classes.Eq Agda.TypeChecking.Monad.Base.Flags64
+ Agda.TypeChecking.Monad.Base: instance GHC.Classes.Eq Agda.TypeChecking.Monad.Base.IsAxiom
+ Agda.TypeChecking.Monad.Base: instance GHC.Classes.Eq Agda.TypeChecking.Monad.Base.IsPathCons
+ Agda.TypeChecking.Monad.Base: instance GHC.Classes.Eq Agda.TypeChecking.Monad.Base.Statistics
+ Agda.TypeChecking.Monad.Base: instance GHC.Classes.Ord Agda.TypeChecking.Monad.Base.EtaProvenance
+ Agda.TypeChecking.Monad.Base: instance GHC.Enum.Bounded Agda.TypeChecking.Monad.Base.EtaProvenance
+ Agda.TypeChecking.Monad.Base: instance GHC.Enum.Enum Agda.TypeChecking.Monad.Base.EtaProvenance
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic (Agda.TypeChecking.Monad.Base.RewriteSource' a)
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.ClashingName
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.ColdEnv
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.EtaProvenance
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.Flags64
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.GlobalRewriteRule
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.IsAxiom
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.IsPathCons
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.LocalRewriteRuleMap
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.ModalEnv
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.ModuleCheckpoints
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.PostColdState
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.PostMetaState
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.PostNamesCheckpoints
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.SessionState
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.Statistics
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.TCContext
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.Call
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.CheckedTarget
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.ClashingName
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.EtaProvenance
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.GlobalRewriteRule
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.IsAxiom
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.IsPathCons
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.LocalRewriteRuleMap
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.Statistics
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show a => GHC.Show.Show (Agda.TypeChecking.Monad.Base.RewriteSource' a)
+ Agda.TypeChecking.Monad.Base: isLocalRewrite :: RewriteSource -> Bool
+ Agda.TypeChecking.Monad.Base: lensCurrentModule :: Lens' PostScopeState (Maybe (Pair ModuleName TopLevelModuleName))
+ Agda.TypeChecking.Monad.Base: lensDataOrRecSig :: Lens' Defn DataOrRecSigData
+ Agda.TypeChecking.Monad.Base: lensInteractionOutputCallback :: Lens' SessionState InteractionOutputCallback
+ Agda.TypeChecking.Monad.Base: lensModuleToSource :: Lens' SessionState ModuleToSource
+ Agda.TypeChecking.Monad.Base: lensPreFileId :: Lens' PreScopeState (Maybe FileId)
+ Agda.TypeChecking.Monad.Base: lensUnusedImportsState :: Lens' PreScopeState UnusedImportsState
+ Agda.TypeChecking.Monad.Base: localRewritingOption :: HasOptions m => m Bool
+ Agda.TypeChecking.Monad.Base: lrewsDefHeaded :: Lens' LocalRewriteRuleMap (HashMap QName [Open RewriteRule])
+ Agda.TypeChecking.Monad.Base: lrewsVarHeaded :: Lens' LocalRewriteRuleMap (IntMap [Open RewriteRule])
+ Agda.TypeChecking.Monad.Base: mkEnvFlag :: Int -> Lens' TCEnv Bool
+ Agda.TypeChecking.Monad.Base: mkFlag :: Int -> Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: mkPostFlag :: Int -> Lens' PostScopeState Bool
+ Agda.TypeChecking.Monad.Base: modifySession :: ModifySession m => Lens' SessionState a -> (a -> a) -> m ()
+ Agda.TypeChecking.Monad.Base: newtype Flags64
+ Agda.TypeChecking.Monad.Base: pattern ReduceM :: (ReduceEnv -> a) -> ReduceM a
+ Agda.TypeChecking.Monad.Base: pattern TCM :: (IORef TCState -> TCEnv -> m a) -> TCMT m a
+ Agda.TypeChecking.Monad.Base: recPositivityCheck :: Defn -> PositivityCheck
+ Agda.TypeChecking.Monad.Base: rewritingOption :: HasOptions m => m Bool
+ Agda.TypeChecking.Monad.Base: setFlag :: Int -> Bool -> Flags64 -> Flags64
+ Agda.TypeChecking.Monad.Base: setSession :: ModifySession m => Lens' SessionState a -> a -> m ()
+ Agda.TypeChecking.Monad.Base: stFileId :: Lens' TCState (Maybe FileId)
+ Agda.TypeChecking.Monad.Base: stImportedModulesAndTransitive :: Lens' TCState (ImportedModules, ImportedModules)
+ Agda.TypeChecking.Monad.Base: stPostAreWeCaching :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: stPostConsideringInstance :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: stPostDirty :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: stPostInstanceHack :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: stPostInstantiateBlocking :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: stPostPostponeInstanceSearch :: Lens' Flags64 Bool
+ Agda.TypeChecking.Monad.Base: stUnusedImportsState :: Lens' TCState UnusedImportsState
+ Agda.TypeChecking.Monad.Base: stWarningSet :: Lens' TCState (Set WarningName)
+ Agda.TypeChecking.Monad.Base: stateSessionLens :: ModifySession m => Lens' SessionState a -> (a -> (r, a)) -> m r
+ Agda.TypeChecking.Monad.Base: stateSessionLensM :: ModifySession m => Lens' SessionState a -> (a -> m (r, a)) -> m r
+ Agda.TypeChecking.Monad.Base: type GlobalRewriteRuleMap = HashMap QName GlobalRewriteRules
+ Agda.TypeChecking.Monad.Base: type GlobalRewriteRules = [GlobalRewriteRule]
+ Agda.TypeChecking.Monad.Base: type RewriteSource = RewriteSource' Definition
+ Agda.TypeChecking.Monad.Base: type SerialisableRewriteSource = RewriteSource' QName
+ Agda.TypeChecking.Monad.Base: unTCM :: TCMT m a -> IORef TCState -> TCEnv -> m a
+ Agda.TypeChecking.Monad.Base: useSession :: ReadTCState m => Lens' SessionState a -> m a
+ Agda.TypeChecking.Monad.Base.Types: Context :: [a] -> Context' a
+ Agda.TypeChecking.Monad.Base.Types: IsAgdaPrimitive :: IsBuiltinModule
+ Agda.TypeChecking.Monad.Base.Types: IsAgdaPrimitiveCubical :: IsBuiltinModule
+ Agda.TypeChecking.Monad.Base.Types: NoWithFunction :: IsWithFunction a
+ Agda.TypeChecking.Monad.Base.Types: TopLevelModuleNameWithSourceFile :: TopLevelModuleName -> SourceFile -> TopLevelModuleNameWithSourceFile
+ Agda.TypeChecking.Monad.Base.Types: WithFunction :: !a -> IsWithFunction a
+ Agda.TypeChecking.Monad.Base.Types: [cxEntries] :: Context' a -> [a]
+ Agda.TypeChecking.Monad.Base.Types: [fileModuleName] :: TopLevelModuleNameWithSourceFile -> TopLevelModuleName
+ Agda.TypeChecking.Monad.Base.Types: [fileModuleSourceFile] :: TopLevelModuleNameWithSourceFile -> SourceFile
+ Agda.TypeChecking.Monad.Base.Types: cxDrop :: Nat -> Context -> Context
+ Agda.TypeChecking.Monad.Base.Types: cxLookup :: Nat -> Context -> Maybe ContextEntry
+ Agda.TypeChecking.Monad.Base.Types: cxPrepend :: [ContextEntry] -> Context -> Context
+ Agda.TypeChecking.Monad.Base.Types: cxSplitAt :: Nat -> Context -> ([ContextEntry], Context)
+ Agda.TypeChecking.Monad.Base.Types: cxTake :: Nat -> Context -> [ContextEntry]
+ Agda.TypeChecking.Monad.Base.Types: cxWithIndex :: (Nat -> ContextEntry -> a) -> Context -> [a]
+ Agda.TypeChecking.Monad.Base.Types: data IsWithFunction a
+ Agda.TypeChecking.Monad.Base.Types: data TopLevelModuleNameWithSourceFile
+ Agda.TypeChecking.Monad.Base.Types: instance Agda.Utils.Null.Null (Agda.TypeChecking.Monad.Base.Types.Context' a)
+ Agda.TypeChecking.Monad.Base.Types: instance Agda.Utils.Null.Null (Agda.TypeChecking.Monad.Base.Types.IsWithFunction a)
+ Agda.TypeChecking.Monad.Base.Types: instance Agda.Utils.Size.Sized (Agda.TypeChecking.Monad.Base.Types.Context' a)
+ Agda.TypeChecking.Monad.Base.Types: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.Types.Context
+ Agda.TypeChecking.Monad.Base.Types: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.Types.TopLevelModuleNameWithSourceFile
+ Agda.TypeChecking.Monad.Base.Types: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.TypeChecking.Monad.Base.Types.IsWithFunction a)
+ Agda.TypeChecking.Monad.Base.Types: instance Data.Foldable.Foldable Agda.TypeChecking.Monad.Base.Types.Context'
+ Agda.TypeChecking.Monad.Base.Types: instance Data.Foldable.Foldable Agda.TypeChecking.Monad.Base.Types.IsWithFunction
+ Agda.TypeChecking.Monad.Base.Types: instance Data.Traversable.Traversable Agda.TypeChecking.Monad.Base.Types.Context'
+ Agda.TypeChecking.Monad.Base.Types: instance Data.Traversable.Traversable Agda.TypeChecking.Monad.Base.Types.IsWithFunction
+ Agda.TypeChecking.Monad.Base.Types: instance GHC.Base.Functor Agda.TypeChecking.Monad.Base.Types.Context'
+ Agda.TypeChecking.Monad.Base.Types: instance GHC.Base.Functor Agda.TypeChecking.Monad.Base.Types.IsWithFunction
+ Agda.TypeChecking.Monad.Base.Types: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.TypeChecking.Monad.Base.Types.IsWithFunction a)
+ Agda.TypeChecking.Monad.Base.Types: instance GHC.Generics.Generic (Agda.TypeChecking.Monad.Base.Types.Context' a)
+ Agda.TypeChecking.Monad.Base.Types: instance GHC.Generics.Generic (Agda.TypeChecking.Monad.Base.Types.IsWithFunction a)
+ Agda.TypeChecking.Monad.Base.Types: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.Types.TopLevelModuleNameWithSourceFile
+ Agda.TypeChecking.Monad.Base.Types: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.Types.TopLevelModuleNameWithSourceFile
+ Agda.TypeChecking.Monad.Base.Types: instance GHC.Show.Show a => GHC.Show.Show (Agda.TypeChecking.Monad.Base.Types.Context' a)
+ Agda.TypeChecking.Monad.Base.Types: instance GHC.Show.Show a => GHC.Show.Show (Agda.TypeChecking.Monad.Base.Types.IsWithFunction a)
+ Agda.TypeChecking.Monad.Base.Types: isPrimitiveModule :: IsBuiltinModule -> Bool
+ Agda.TypeChecking.Monad.Base.Types: newtype Context' a
+ Agda.TypeChecking.Monad.Base.Types: pattern CxEmpty :: Context
+ Agda.TypeChecking.Monad.Base.Types: pattern CxExtend :: ContextEntry -> Context -> Context
+ Agda.TypeChecking.Monad.Base.Types: pattern CxExtendVar :: Name -> Dom Type -> Context -> Context
+ Agda.TypeChecking.Monad.Benchmark: instance Agda.Syntax.Common.Pretty.Pretty Agda.TypeChecking.Monad.Benchmark.ModuleThroughput
+ Agda.TypeChecking.Monad.Builtin: constructorFormer :: HasBuiltins m => m (Term -> Term)
+ Agda.TypeChecking.Monad.Builtin: instance (Agda.TypeChecking.Monad.Builtin.HasBuiltins m, GHC.Base.Monoid w) => Agda.TypeChecking.Monad.Builtin.HasBuiltins (Agda.Utils.StrictWriter.WriterT w m)
+ Agda.TypeChecking.Monad.Builtin: instance Agda.TypeChecking.Monad.Builtin.HasBuiltins m => Agda.TypeChecking.Monad.Builtin.HasBuiltins (Agda.Utils.StrictReader.ReaderT e m)
+ Agda.TypeChecking.Monad.Builtin: instance Agda.TypeChecking.Monad.Builtin.HasBuiltins m => Agda.TypeChecking.Monad.Builtin.HasBuiltins (Agda.Utils.StrictState.StateT s m)
+ Agda.TypeChecking.Monad.Builtin: primQuotientConstructor :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term
+ Agda.TypeChecking.Monad.Caching: cachingStartsTEST :: TCM ()
+ Agda.TypeChecking.Monad.Constraints: instance Agda.TypeChecking.Monad.Constraints.MonadConstraint m => Agda.TypeChecking.Monad.Constraints.MonadConstraint (Agda.Utils.StrictReader.ReaderT e m)
+ Agda.TypeChecking.Monad.Constraints: isProblemSolved'' :: ProblemId -> TCM Bool
+ Agda.TypeChecking.Monad.Constraints: modifyConstraints :: MonadConstraint m => (Constraints -> Constraints) -> (Constraints -> Constraints) -> m ()
+ Agda.TypeChecking.Monad.Context: ($dmaddLocalRewrite) :: forall (n :: Type -> Type) (t :: (Type -> Type) -> Type -> Type) a. (MonadAddContext m, MonadAddContext n, MonadTransControl t, t n ~ m) => RewriteRule -> m a -> m a
+ Agda.TypeChecking.Monad.Context: addLetAxiom :: MonadWarning m => ArgInfo -> Origin -> Name -> Term -> Type -> m a -> m a
+ Agda.TypeChecking.Monad.Context: addLocalRewrite :: MonadAddContext m => RewriteRule -> m a -> m a
+ Agda.TypeChecking.Monad.Context: addRewDom :: MonadAddContext m => RewDom -> m a -> m a
+ Agda.TypeChecking.Monad.Context: codomainSortOldM :: (ReadTCState m, MonadAddContext m) => Dom Type -> Sort -> BlockedDepCheck Sort -> (Sort -> m a) -> m a
+ Agda.TypeChecking.Monad.Context: defaultAddLocalRewrite :: (MonadTCEnv m, ReadTCState m) => RewriteRule -> m a -> m a
+ Agda.TypeChecking.Monad.Context: extendReduceEnv :: String -> Dom Type -> ReduceEnv -> ReduceEnv
+ Agda.TypeChecking.Monad.Context: getModuleCheckpoint :: ModuleName -> ModuleCheckpoints -> Maybe CheckpointId
+ Agda.TypeChecking.Monad.Context: illegalRule :: forall (m :: Type -> Type) a. MonadWarning m => RewriteSource -> IllegalRewriteRuleReason -> MaybeT m a
+ Agda.TypeChecking.Monad.Context: inLargeEnoughContext :: (ReadTCState m, MonadAddContext m, Free a) => a -> m b -> m b
+ Agda.TypeChecking.Monad.Context: instance (GHC.Base.Monoid w, Agda.TypeChecking.Monad.Context.MonadAddContext m) => Agda.TypeChecking.Monad.Context.MonadAddContext (Agda.Utils.StrictWriter.WriterT w m)
+ Agda.TypeChecking.Monad.Context: instance Agda.TypeChecking.Monad.Context.AddContext (Agda.Utils.List1.List1 (Agda.Syntax.Internal.Dom Agda.Syntax.Abstract.Name.Name), Agda.Syntax.Internal.Type)
+ Agda.TypeChecking.Monad.Context: instance Agda.TypeChecking.Monad.Context.AddContext ([Agda.Syntax.Internal.Dom Agda.Syntax.Abstract.Name.Name], Agda.Syntax.Internal.Type)
+ Agda.TypeChecking.Monad.Context: instance Agda.TypeChecking.Monad.Context.AddContext Agda.TypeChecking.Monad.Base.Types.Context
+ Agda.TypeChecking.Monad.Context: instance Agda.TypeChecking.Monad.Context.MonadAddContext m => Agda.TypeChecking.Monad.Context.MonadAddContext (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.TypeChecking.Monad.Context: instance Agda.TypeChecking.Monad.Context.MonadAddContext m => Agda.TypeChecking.Monad.Context.MonadAddContext (Agda.Utils.StrictState.StateT r m)
+ Agda.TypeChecking.Monad.Context: setAllModuleCheckpoints :: MonadTCState m => CheckpointId -> m ()
+ Agda.TypeChecking.Monad.Context: setModuleCheckpoint :: MonadTCState m => ModuleName -> CheckpointId -> m ()
+ Agda.TypeChecking.Monad.Context: underAbsReduceM :: Dom Type -> Abs a -> (a -> ReduceM b) -> ReduceM b
+ Agda.TypeChecking.Monad.Context: underAbsReduceM_ :: Abs a -> (a -> ReduceM b) -> ReduceM b
+ Agda.TypeChecking.Monad.Context: unsafeRule :: forall (m :: Type -> Type). MonadWarning m => RewriteSource -> IllegalRewriteRuleReason -> MaybeT m ()
+ Agda.TypeChecking.Monad.Context: unwindModuleCheckpointsOnto :: MonadTCState m => CheckpointId -> ModuleCheckpoints -> m ()
+ Agda.TypeChecking.Monad.Context: updateLocalRewriteHeads :: Substitution -> LocalRewriteRuleMap -> LocalRewriteRuleMap
+ Agda.TypeChecking.Monad.Context: withoutModuleCheckpoints :: ReadTCState m => m a -> m a
+ Agda.TypeChecking.Monad.Debug: alwaysTraceSDoc :: MonadDebug m => VerboseKey -> VerboseLevel -> TCM Doc -> m a -> m a
+ Agda.TypeChecking.Monad.Debug: alwaysTraceSLn :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m a -> m a
+ Agda.TypeChecking.Monad.Debug: formatDebugMessageTCM :: VerboseKey -> VerboseLevel -> TCM Doc -> TCM Doc
+ Agda.TypeChecking.Monad.Debug: getVerbosityLevel :: MonadDebug m => VerboseKey -> m VerboseLevel
+ Agda.TypeChecking.Monad.Debug: instance (Agda.TypeChecking.Monad.Debug.MonadDebug m, GHC.Base.Monoid w) => Agda.TypeChecking.Monad.Debug.MonadDebug (Agda.Utils.StrictWriter.WriterT w m)
+ Agda.TypeChecking.Monad.Debug: instance Agda.TypeChecking.Monad.Debug.MonadDebug m => Agda.TypeChecking.Monad.Debug.MonadDebug (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.TypeChecking.Monad.Debug: instance Agda.TypeChecking.Monad.Debug.MonadDebug m => Agda.TypeChecking.Monad.Debug.MonadDebug (Agda.Utils.StrictState.StateT s m)
+ Agda.TypeChecking.Monad.Debug: traceDebugMessageTCM :: VerboseKey -> VerboseLevel -> Doc -> TCM a -> TCM a
+ Agda.TypeChecking.Monad.Debug: verboseBracketTCM :: VerboseKey -> VerboseLevel -> String -> TCM a -> TCM a
+ Agda.TypeChecking.Monad.Imports: locallyAddImport :: TopLevelModuleName -> TCM () -> TCM ()
+ Agda.TypeChecking.Monad.MetaVars: instance Agda.TypeChecking.Monad.MetaVars.MonadMetaSolver m => Agda.TypeChecking.Monad.MetaVars.MonadMetaSolver (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.TypeChecking.Monad.MetaVars: setInteractionRange :: (MonadInteractionPoints m, MonadDebug m) => Range -> InteractionId -> m ()
+ Agda.TypeChecking.Monad.MetaVars: unfreeze_ :: MetaVariable -> MetaVariable
+ Agda.TypeChecking.Monad.Modality: addRewConstraint :: MonadConstraint tcm => LocalEquation -> tcm ()
+ Agda.TypeChecking.Monad.Modality: applyDomToContext :: Dom e -> TCM a -> TCM a
+ Agda.TypeChecking.Monad.Modality: applyDomToContext' :: RewDom' Term -> TCM ()
+ Agda.TypeChecking.Monad.Modality: applyModalityToContext' :: Modality -> TCEnv -> TCEnv
+ Agda.TypeChecking.Monad.Modality: applyModalityToContextOnly' :: Modality -> TCEnv -> TCEnv
+ Agda.TypeChecking.Monad.Modality: applyModalityToJudgementOnly' :: Modality -> TCEnv -> TCEnv
+ Agda.TypeChecking.Monad.Open: tryGetOpenRew :: MonadTCEnv m => (Substitution -> m RewriteRule) -> Open RewriteRule -> m RewriteRule
+ Agda.TypeChecking.Monad.Options: isIrrelevanceEnabled :: HasOptions m => m Bool
+ Agda.TypeChecking.Monad.Pure: instance (Agda.TypeChecking.Monad.Pure.PureTCM m, GHC.Base.Monoid w) => Agda.TypeChecking.Monad.Pure.PureTCM (Agda.Utils.StrictWriter.WriterT w m)
+ Agda.TypeChecking.Monad.Pure: instance Agda.TypeChecking.Monad.Pure.PureTCM m => Agda.TypeChecking.Monad.Pure.PureTCM (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.TypeChecking.Monad.Pure: instance Agda.TypeChecking.Monad.Pure.PureTCM m => Agda.TypeChecking.Monad.Pure.PureTCM (Agda.Utils.StrictState.StateT s m)
+ Agda.TypeChecking.Monad.Signature: ($dmgetGlobalRewriteRulesFor) :: forall (n :: Type -> Type) (t :: (Type -> Type) -> Type -> Type). (HasConstInfo m, HasConstInfo n, MonadTrans t, m ~ t n) => QName -> m GlobalRewriteRules
+ Agda.TypeChecking.Monad.Signature: ($dmgetLocalRewriteRulesFor) :: forall (n :: Type -> Type) (t :: (Type -> Type) -> Type -> Type). (HasConstInfo m, HasConstInfo n, MonadTrans t, m ~ t n) => RewriteHead -> m RewriteRules
+ Agda.TypeChecking.Monad.Signature: addSection' :: ModuleName -> Telescope -> TCM ()
+ Agda.TypeChecking.Monad.Signature: defCopatternLHS :: HasConstInfo m => QName -> Definition -> m Bool
+ Agda.TypeChecking.Monad.Signature: defaultGetGlobalRewriteRulesFor :: (ReadTCState m, MonadTCEnv m) => QName -> m GlobalRewriteRules
+ Agda.TypeChecking.Monad.Signature: defaultGetLocalRewriteRulesFor :: (ReadTCState m, MonadTCEnv m, MonadDebug m, HasOptions m) => RewriteHead -> m RewriteRules
+ Agda.TypeChecking.Monad.Signature: getAllRewriteRulesForDefHead :: (HasConstInfo m, ReadTCState m) => QName -> m RewriteRules
+ Agda.TypeChecking.Monad.Signature: getAllRewriteRulesForVarHead :: HasConstInfo m => Nat -> m RewriteRules
+ Agda.TypeChecking.Monad.Signature: getArgOccurrences :: ReadTCState m => QName -> m [Occurrence]
+ Agda.TypeChecking.Monad.Signature: getFilteredGlobalRewriteRulesFor :: ReadTCState m => Bool -> QName -> m GlobalRewriteRules
+ Agda.TypeChecking.Monad.Signature: getGlobalRewriteRulesFor :: HasConstInfo m => QName -> m GlobalRewriteRules
+ Agda.TypeChecking.Monad.Signature: getLocalRewriteRulesFor :: HasConstInfo m => RewriteHead -> m RewriteRules
+ Agda.TypeChecking.Monad.Signature: instance (GHC.Base.Monoid w, Agda.TypeChecking.Monad.Signature.HasConstInfo m) => Agda.TypeChecking.Monad.Signature.HasConstInfo (Agda.Utils.StrictWriter.WriterT w m)
+ Agda.TypeChecking.Monad.Signature: instance Agda.TypeChecking.Monad.Signature.HasConstInfo Agda.TypeChecking.Monad.Base.TCM
+ Agda.TypeChecking.Monad.Signature: instance Agda.TypeChecking.Monad.Signature.HasConstInfo m => Agda.TypeChecking.Monad.Signature.HasConstInfo (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.TypeChecking.Monad.Signature: instance Agda.TypeChecking.Monad.Signature.HasConstInfo m => Agda.TypeChecking.Monad.Signature.HasConstInfo (Agda.Utils.StrictState.StateT s m)
+ Agda.TypeChecking.Monad.Signature: isProperProjection_ :: Projection -> Bool
+ Agda.TypeChecking.Monad.Signature: justTheRule :: GlobalRewriteRule -> Maybe RewriteRule
+ Agda.TypeChecking.Monad.Signature: normalizeCopyBody :: Definition -> TCM Definition
+ Agda.TypeChecking.Monad.Signature: rewUsesCopatterns :: HasConstInfo m => RewriteHead -> m Bool
+ Agda.TypeChecking.Monad.State: currentModuleIsBuiltinModuleWithSafePostulates :: ReadTCState m => m Bool
+ Agda.TypeChecking.Monad.State: evalWithScope :: ReadTCState m => ScopeInfo -> m a -> m a
+ Agda.TypeChecking.Monad.State: instance (Control.Monad.IO.Class.MonadIO m, Control.Monad.Catch.MonadMask m) => Agda.Utils.FileId.MonadFileId (Agda.TypeChecking.Monad.Base.TCMT m)
+ Agda.TypeChecking.Monad.State: instance Agda.Utils.FileId.MonadFileId Agda.TypeChecking.Monad.Base.ReduceM
+ Agda.TypeChecking.Monad.State: modifyGlobalSignature :: MonadTCState m => (Signature -> Signature) -> m ()
+ Agda.TypeChecking.Monad.State: putTCPreservingStats :: TCState -> TCM ()
+ Agda.TypeChecking.Monad.State: recomputeInverseScope :: MonadTCState m => m ()
+ Agda.TypeChecking.Monad.State: setMatchableSymbols' :: QName -> [QName] -> Definitions -> Definitions
+ Agda.TypeChecking.Monad.State: topLevelModuleNameWithSourceFileCompleter :: ReadTCState m => m (TopLevelModuleName -> TopLevelModuleNameWithSourceFile)
+ Agda.TypeChecking.Monad.State: updateDefsForRewrites :: QName -> GlobalRewriteRules -> [QName] -> Definitions -> Definitions
+ Agda.TypeChecking.Monad.Statistics: ($dmtickMax) :: forall (n :: Type -> Type) (t :: (Type -> Type) -> Type -> Type). (MonadStatistics m, MonadStatistics n, MonadTrans t, t n ~ m) => String -> Word64 -> m ()
+ Agda.TypeChecking.Monad.Statistics: ($dmtickN) :: forall (n :: Type -> Type) (t :: (Type -> Type) -> Type -> Type). (MonadStatistics m, MonadStatistics n, MonadTrans t, t n ~ m) => String -> Word64 -> m ()
+ Agda.TypeChecking.Monad.Statistics: instance Agda.TypeChecking.Monad.Statistics.MonadStatistics m => Agda.TypeChecking.Monad.Statistics.MonadStatistics (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.TypeChecking.Monad.Trace: instance (Agda.TypeChecking.Monad.Trace.MonadTrace m, GHC.Base.Monoid w) => Agda.TypeChecking.Monad.Trace.MonadTrace (Agda.Utils.StrictWriter.WriterT w m)
+ Agda.TypeChecking.Monad.Trace: instance Agda.TypeChecking.Monad.Trace.MonadTrace m => Agda.TypeChecking.Monad.Trace.MonadTrace (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.TypeChecking.Monad.Trace: instance Agda.TypeChecking.Monad.Trace.MonadTrace m => Agda.TypeChecking.Monad.Trace.MonadTrace (Agda.Utils.StrictState.StateT s m)
+ Agda.TypeChecking.Names: instance (Agda.TypeChecking.Monad.Builtin.HasBuiltins m, Agda.TypeChecking.Monad.Signature.HasConstInfo m, Agda.TypeChecking.Monad.Context.MonadAddContext m, Agda.Utils.FileId.MonadFileId m, Agda.TypeChecking.Monad.Base.MonadReduce m) => Agda.TypeChecking.Monad.Pure.PureTCM (Agda.TypeChecking.Names.NamesT m)
+ Agda.TypeChecking.Names: instance Agda.Utils.FileId.MonadFileId m => Agda.Utils.FileId.MonadFileId (Agda.TypeChecking.Names.NamesT m)
+ Agda.TypeChecking.Patterns.Match: instance Agda.Syntax.Common.Pretty.Pretty a => Agda.Syntax.Common.Pretty.Pretty (Agda.TypeChecking.Patterns.Match.Match a)
+ Agda.TypeChecking.Patterns.Match: instance GHC.Show.Show Agda.TypeChecking.Patterns.Match.OnlyLazy
+ Agda.TypeChecking.Patterns.Match: instance GHC.Show.Show a => GHC.Show.Show (Agda.TypeChecking.Patterns.Match.Match a)
+ Agda.TypeChecking.Positivity: hasDefinition :: Defn -> Bool
+ Agda.TypeChecking.Positivity: instance Agda.Syntax.Common.Pretty.Pretty a => Agda.TypeChecking.Pretty.PrettyTCMWithNode (Agda.TypeChecking.Positivity.Occurrence.Edge a)
+ Agda.TypeChecking.Positivity: instance Agda.TypeChecking.Pretty.PrettyTCM (Data.Sequence.Internal.Seq Agda.TypeChecking.Positivity.Warnings.OccursWhere)
+ Agda.TypeChecking.Positivity: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Positivity.Occurrence.Node
+ Agda.TypeChecking.Positivity: isDatatype :: Definition -> Maybe (PositivityCheck, DataOrRecord)
+ Agda.TypeChecking.Positivity: preprocessBlock :: [QName] -> TCM (Maybe [(QName, Int, Maybe (PositivityCheck, DataOrRecord), Bool)])
+ Agda.TypeChecking.Positivity.Occurrence: ArgNode :: QName -> Int -> Node
+ Agda.TypeChecking.Positivity.Occurrence: DefNode :: QName -> Node
+ Agda.TypeChecking.Positivity.Occurrence: Edge :: !Occurrence -> !a -> Edge a
+ Agda.TypeChecking.Positivity.Occurrence: InIndex :: !OccursPath -> OccursPath
+ Agda.TypeChecking.Positivity.Occurrence: InSort :: !OccursPath -> OccursPath
+ Agda.TypeChecking.Positivity.Occurrence: MutDefArg :: !OccursPath -> !QName -> !Nat -> OccursPath
+ Agda.TypeChecking.Positivity.Occurrence: Root :: OccursPath
+ Agda.TypeChecking.Positivity.Occurrence: data Edge a
+ Agda.TypeChecking.Positivity.Occurrence: data Node
+ Agda.TypeChecking.Positivity.Occurrence: data OccursPath
+ Agda.TypeChecking.Positivity.Occurrence: instance Agda.Syntax.Common.Pretty.Pretty Agda.TypeChecking.Positivity.Occurrence.Node
+ Agda.TypeChecking.Positivity.Occurrence: instance Agda.Syntax.Common.Pretty.Pretty Agda.TypeChecking.Positivity.Occurrence.OccursPath
+ Agda.TypeChecking.Positivity.Occurrence: instance Control.DeepSeq.NFData Agda.TypeChecking.Positivity.Occurrence.OccursPath
+ Agda.TypeChecking.Positivity.Occurrence: instance Data.Hashable.Class.Hashable Agda.TypeChecking.Positivity.Occurrence.Node
+ Agda.TypeChecking.Positivity.Occurrence: instance GHC.Base.Functor Agda.TypeChecking.Positivity.Occurrence.Edge
+ Agda.TypeChecking.Positivity.Occurrence: instance GHC.Base.Monoid a => Agda.Utils.SemiRing.SemiRing (Agda.TypeChecking.Positivity.Occurrence.Edge a)
+ Agda.TypeChecking.Positivity.Occurrence: instance GHC.Classes.Eq Agda.TypeChecking.Positivity.Occurrence.Node
+ Agda.TypeChecking.Positivity.Occurrence: instance GHC.Classes.Eq Agda.TypeChecking.Positivity.Occurrence.OccursPath
+ Agda.TypeChecking.Positivity.Occurrence: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.TypeChecking.Positivity.Occurrence.Edge a)
+ Agda.TypeChecking.Positivity.Occurrence: instance GHC.Classes.Ord Agda.TypeChecking.Positivity.Occurrence.Node
+ Agda.TypeChecking.Positivity.Occurrence: instance GHC.Classes.Ord a => GHC.Classes.Ord (Agda.TypeChecking.Positivity.Occurrence.Edge a)
+ Agda.TypeChecking.Positivity.Occurrence: instance GHC.Show.Show Agda.TypeChecking.Positivity.Occurrence.Node
+ Agda.TypeChecking.Positivity.Occurrence: instance GHC.Show.Show Agda.TypeChecking.Positivity.Occurrence.OccursPath
+ Agda.TypeChecking.Positivity.Occurrence: instance GHC.Show.Show a => GHC.Show.Show (Agda.TypeChecking.Positivity.Occurrence.Edge a)
+ Agda.TypeChecking.Positivity.Occurrence: mergeEdges :: Edge a -> Edge a -> Edge a
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: Edge :: !Occurrence -> !a -> Edge a
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: adjacencyList :: OccGraph -> IO [(Node, Node, Edge OccursWhere)]
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: buildOccurrenceGraph :: [QName] -> TCM (OccGraph, Mutuals)
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: data Edge a
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: data Node
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: fromGenericGraph :: Graph Node (Edge a) -> OccGraph
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance (Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences a, Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences b) => Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences (a, b)
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance (Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences x, Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences a) => Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences (Agda.TypeChecking.Telescope.Boundary' x a)
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences Agda.Syntax.Internal.Clause
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences Agda.Syntax.Internal.Level
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences Agda.Syntax.Internal.PlusLevel
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences Agda.Syntax.Internal.Sort
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences Agda.Syntax.Internal.Term
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences Agda.Syntax.Internal.Type
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences Agda.TypeChecking.Positivity.OccurrenceAnalysis.TypedTerm
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences GHC.Types.Int
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences a => Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences (Agda.Syntax.Common.Arg a)
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences a => Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences (Agda.Syntax.Internal.Abs a)
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences a => Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences (Agda.Syntax.Internal.Dom a)
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences a => Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences (Agda.Syntax.Internal.Elim.Elim' a)
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences a => Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences (Agda.Syntax.Internal.Tele a)
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences a => Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences (GHC.Maybe.Maybe a)
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences a => Agda.TypeChecking.Positivity.OccurrenceAnalysis.ComputeOccurrences [a]
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance Agda.TypeChecking.Pretty.PrettyTCMWithNode (Agda.TypeChecking.Positivity.Occurrence.Edge Agda.TypeChecking.Positivity.Occurrence.OccursWhere)
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance Data.Hashable.Class.Hashable Agda.TypeChecking.Positivity.OccurrenceAnalysis.Seen
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance GHC.Classes.Eq Agda.TypeChecking.Positivity.OccurrenceAnalysis.Seen
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance GHC.Exception.Type.Exception Agda.TypeChecking.Positivity.Occurrence.Occurrence
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance GHC.Show.Show Agda.TypeChecking.Positivity.OccurrenceAnalysis.DefArgInEnv
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: instance GHC.Show.Show Agda.TypeChecking.Positivity.OccurrenceAnalysis.Seen
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: lookupNode :: Node -> NodeMap v -> (v -> IO a) -> IO a -> IO a
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: pattern ArgNode :: () => QName -> Int -> Node
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: stronglyConnComp :: OccGraph -> IO [SCC Node]
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: toGenericGraph :: OccGraph -> Graph Node (Edge OccursWhere)
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: transitiveOccurrence :: OccGraph -> Node -> Node -> IO Occurrence
+ Agda.TypeChecking.Positivity.OccurrenceAnalysis: type OccGraph = NodeMap NodeMap Edge OccursWhere
+ Agda.TypeChecking.Positivity.Warnings: ConArgType :: QName -> Where
+ Agda.TypeChecking.Positivity.Warnings: ConEndpoint :: QName -> Where
+ Agda.TypeChecking.Positivity.Warnings: DefArg :: QName -> Nat -> Where
+ Agda.TypeChecking.Positivity.Warnings: InClause :: Nat -> Where
+ Agda.TypeChecking.Positivity.Warnings: InDefOf :: QName -> Where
+ Agda.TypeChecking.Positivity.Warnings: InIndex :: Where
+ Agda.TypeChecking.Positivity.Warnings: InSort :: Where
+ Agda.TypeChecking.Positivity.Warnings: IndArgType :: QName -> Where
+ Agda.TypeChecking.Positivity.Warnings: LeftOfArrow :: Where
+ Agda.TypeChecking.Positivity.Warnings: Matched :: Where
+ Agda.TypeChecking.Positivity.Warnings: MetaArg :: Where
+ Agda.TypeChecking.Positivity.Warnings: OccursWhere :: Range -> Seq Where -> Seq Where -> OccursWhere
+ Agda.TypeChecking.Positivity.Warnings: UnderInf :: Where
+ Agda.TypeChecking.Positivity.Warnings: VarArg :: Occurrence -> Nat -> Where
+ Agda.TypeChecking.Positivity.Warnings: boundToEverySome :: Map Occurrence [(Occurrence -> Bool, Occurrence -> Bool)]
+ Agda.TypeChecking.Positivity.Warnings: data OccursWhere
+ Agda.TypeChecking.Positivity.Warnings: data Where
+ Agda.TypeChecking.Positivity.Warnings: instance Agda.Syntax.Common.Pretty.Pretty Agda.TypeChecking.Positivity.Warnings.OccursWhere
+ Agda.TypeChecking.Positivity.Warnings: instance Agda.Syntax.Common.Pretty.Pretty Agda.TypeChecking.Positivity.Warnings.Where
+ Agda.TypeChecking.Positivity.Warnings: instance Agda.Utils.Null.Null Agda.TypeChecking.Positivity.Warnings.OccursWhere
+ Agda.TypeChecking.Positivity.Warnings: instance Control.DeepSeq.NFData Agda.TypeChecking.Positivity.Warnings.OccursWhere
+ Agda.TypeChecking.Positivity.Warnings: instance Control.DeepSeq.NFData Agda.TypeChecking.Positivity.Warnings.Where
+ Agda.TypeChecking.Positivity.Warnings: instance GHC.Classes.Eq Agda.TypeChecking.Positivity.Warnings.OccursWhere
+ Agda.TypeChecking.Positivity.Warnings: instance GHC.Classes.Eq Agda.TypeChecking.Positivity.Warnings.Where
+ Agda.TypeChecking.Positivity.Warnings: instance GHC.Classes.Ord Agda.TypeChecking.Positivity.Warnings.OccursWhere
+ Agda.TypeChecking.Positivity.Warnings: instance GHC.Classes.Ord Agda.TypeChecking.Positivity.Warnings.Where
+ Agda.TypeChecking.Positivity.Warnings: instance GHC.Generics.Generic Agda.TypeChecking.Positivity.Warnings.OccursWhere
+ Agda.TypeChecking.Positivity.Warnings: instance GHC.Generics.Generic Agda.TypeChecking.Positivity.Warnings.Where
+ Agda.TypeChecking.Positivity.Warnings: instance GHC.Show.Show Agda.TypeChecking.Positivity.Warnings.OccursWhere
+ Agda.TypeChecking.Positivity.Warnings: instance GHC.Show.Show Agda.TypeChecking.Positivity.Warnings.Where
+ Agda.TypeChecking.Positivity.Warnings: productOfEdgesInBoundedWalk :: (SemiRing e, Ord n) => (e -> Occurrence) -> Graph n e -> n -> n -> Occurrence -> Maybe e
+ Agda.TypeChecking.Pretty: defnToNameKind :: Defn -> NameKind
+ Agda.TypeChecking.Pretty: githubIssue :: Applicative m => Int -> m Doc
+ Agda.TypeChecking.Pretty: hlArgument :: Functor m => m Doc -> m Doc
+ Agda.TypeChecking.Pretty: hlBound :: Functor m => m Doc -> m Doc
+ Agda.TypeChecking.Pretty: hlComment :: Functor m => m Doc -> m Doc
+ Agda.TypeChecking.Pretty: hlConstructor :: Functor m => Induction -> m Doc -> m Doc
+ Agda.TypeChecking.Pretty: hlDatatype :: Functor m => m Doc -> m Doc
+ Agda.TypeChecking.Pretty: hlField :: Functor m => m Doc -> m Doc
+ Agda.TypeChecking.Pretty: hlFunction :: Functor m => m Doc -> m Doc
+ Agda.TypeChecking.Pretty: hlGeneralizable :: Functor m => m Doc -> m Doc
+ Agda.TypeChecking.Pretty: hlHole :: Functor m => m Doc -> m Doc
+ Agda.TypeChecking.Pretty: hlKeyword :: Functor m => m Doc -> m Doc
+ Agda.TypeChecking.Pretty: hlMacro :: Functor m => m Doc -> m Doc
+ Agda.TypeChecking.Pretty: hlModule :: Functor m => m Doc -> m Doc
+ Agda.TypeChecking.Pretty: hlNumber :: Functor m => m Doc -> m Doc
+ Agda.TypeChecking.Pretty: hlPostulate :: Functor m => m Doc -> m Doc
+ Agda.TypeChecking.Pretty: hlPragma :: Functor m => m Doc -> m Doc
+ Agda.TypeChecking.Pretty: hlPrimitive :: Functor m => m Doc -> m Doc
+ Agda.TypeChecking.Pretty: hlPrimitiveType :: Functor m => m Doc -> m Doc
+ Agda.TypeChecking.Pretty: hlRecord :: Functor m => m Doc -> m Doc
+ Agda.TypeChecking.Pretty: hlString :: Functor m => m Doc -> m Doc
+ Agda.TypeChecking.Pretty: hlSymbol :: Functor m => m Doc -> m Doc
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM (Agda.Syntax.Internal.Elim.Elim' Agda.Syntax.Internal.NLPat)
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM (Agda.Syntax.Internal.Type' Agda.Syntax.Internal.NLPat)
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Syntax.Abstract.Name.AbstractName
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Syntax.Common.Cohesion
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Syntax.Internal.LocalEquation
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Syntax.Internal.NLPSort
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Syntax.Internal.NLPType
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Syntax.Internal.NLPat
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Syntax.Internal.RewDom
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Syntax.Internal.RewriteHead
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Syntax.Internal.RewriteRule
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Free.Base.MetaSet
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Monad.Base.GlobalRewriteRule
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Monad.Base.Types.Context
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM a => Agda.TypeChecking.Pretty.PrettyTCM (Agda.TypeChecking.Free.Base.FlexRig' a)
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM a => Agda.TypeChecking.Pretty.PrettyTCM (Agda.TypeChecking.Free.Base.VarMap' a)
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM a => Agda.TypeChecking.Pretty.PrettyTCM (Agda.TypeChecking.Free.Base.VarOcc' a)
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM a => Agda.TypeChecking.Pretty.PrettyTCM (Agda.TypeChecking.Monad.Base.Types.IsWithFunction a)
+ Agda.TypeChecking.Pretty: url :: Applicative m => String -> m Doc
+ Agda.TypeChecking.Pretty.Warning: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Syntax.Common.DataOrRecord_
+ Agda.TypeChecking.Pretty.Warning: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Monad.Base.RewriteSource
+ Agda.TypeChecking.Pretty.Warning: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Monad.Base.SerialisableRewriteSource
+ Agda.TypeChecking.Primitive: primQrec :: TCM PrimFun
+ Agda.TypeChecking.Primitive: primRewriteNoMatch :: TCM PrimitiveImpl
+ Agda.TypeChecking.Primitive.Base: lookupPossiblyTrustedPrimitiveFunction :: PrimitiveId -> TCM (Maybe Type, PrimFun)
+ Agda.TypeChecking.ProjectionLike: KeepLoneProjectionLike :: LoneProjectionLikeToLambda
+ Agda.TypeChecking.ProjectionLike: LoneProjectionLikeToLambda :: LoneProjectionLikeToLambda
+ Agda.TypeChecking.ProjectionLike: data LoneProjectionLikeToLambda
+ Agda.TypeChecking.ProjectionLike: instance GHC.Classes.Eq Agda.TypeChecking.ProjectionLike.LoneProjectionLikeToLambda
+ Agda.TypeChecking.Records: instance Agda.TypeChecking.Records.NormaliseProjP a => Agda.TypeChecking.Records.NormaliseProjP (x, a)
+ Agda.TypeChecking.Reduce: appDefE0 :: QName -> Definition -> Term -> 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: instance (Agda.TypeChecking.Free.Generic.Free a, Agda.TypeChecking.Reduce.InstantiateFull a) => Agda.TypeChecking.Reduce.InstantiateFull (Agda.Syntax.Internal.BlockedDepCheck a)
+ Agda.TypeChecking.Reduce: instance (Agda.TypeChecking.Free.Generic.Free a, Agda.TypeChecking.Reduce.Normalise a) => Agda.TypeChecking.Reduce.Normalise (Agda.Syntax.Internal.BlockedDepCheck a)
+ Agda.TypeChecking.Reduce: instance (Agda.TypeChecking.Free.Generic.Free a, Agda.TypeChecking.Reduce.Simplify a) => Agda.TypeChecking.Reduce.Simplify (Agda.Syntax.Internal.BlockedDepCheck a)
+ Agda.TypeChecking.Reduce: instance (Agda.TypeChecking.Reduce.Normalise a, Agda.TypeChecking.Reduce.Normalise b, Agda.TypeChecking.Reduce.Normalise c, Agda.TypeChecking.Reduce.Normalise d) => Agda.TypeChecking.Reduce.Normalise (a, b, c, d)
+ Agda.TypeChecking.Reduce: instance (Agda.TypeChecking.Reduce.Reduce a, Agda.TypeChecking.Free.Generic.Free a) => Agda.TypeChecking.Reduce.Reduce (Agda.Syntax.Internal.BlockedDepCheck a)
+ Agda.TypeChecking.Reduce: instance (Agda.TypeChecking.Reduce.Simplify a, Agda.TypeChecking.Reduce.Simplify b, Agda.TypeChecking.Reduce.Simplify c, Agda.TypeChecking.Reduce.Simplify d) => Agda.TypeChecking.Reduce.Simplify (a, b, c, d)
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Instantiate Agda.Syntax.Internal.LocalEquation
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Instantiate Agda.Syntax.Internal.RewDom
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Instantiate Agda.Syntax.Internal.RewriteRule
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Instantiate Agda.TypeChecking.Monad.Base.ProblemConstraint
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Instantiate e => Agda.TypeChecking.Reduce.Instantiate (Agda.Syntax.Internal.Dom e)
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull Agda.Syntax.Internal.LocalEquation
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull Agda.Syntax.Internal.NLPSort
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull Agda.Syntax.Internal.NLPType
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull Agda.Syntax.Internal.NLPat
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull Agda.Syntax.Internal.RewDom
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull Agda.Syntax.Internal.RewriteRule
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull Agda.TypeChecking.Monad.Base.GlobalRewriteRule
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull Agda.TypeChecking.Monad.Base.Types.Context
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull a => Agda.TypeChecking.Reduce.InstantiateFull [a]
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull e => Agda.TypeChecking.Reduce.InstantiateFull (Agda.Syntax.Internal.Dom e)
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.IsMeta (Agda.Syntax.Internal.Sort' a)
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Normalise Agda.Syntax.Internal.LocalEquation
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Reduce Agda.Syntax.Internal.LocalEquation
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Reduce Agda.TypeChecking.Monad.Base.ProblemConstraint
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Simplify Agda.Syntax.Internal.LocalEquation
+ Agda.TypeChecking.Reduce: reduceDefCopies :: Term -> TCM Term
+ Agda.TypeChecking.Reduce.Fast: instance Agda.Syntax.Common.Pretty.Pretty (Agda.TypeChecking.Reduce.Fast.ControlStack s)
+ Agda.TypeChecking.Reduce.Fast: instance Agda.Syntax.Common.Pretty.Pretty (Agda.TypeChecking.Reduce.Fast.Eval s)
+ Agda.TypeChecking.Reduce.Fast: instance Agda.Syntax.Common.Pretty.Pretty (Agda.TypeChecking.Reduce.Fast.Match s)
+ Agda.TypeChecking.Reduce.Fast: instance Agda.Utils.Zipper.Zipper (Agda.TypeChecking.Reduce.Fast.ElimZipper (Agda.TypeChecking.Reduce.Fast.Pointer s))
+ Agda.TypeChecking.Rewriting: checkEquationValid :: RewriteSource -> RewriteAnn -> Type -> TCM (Maybe LocalEquation)
+ Agda.TypeChecking.Rewriting: checkIsRewriteRelation :: RewriteSource -> Type -> MaybeT TCM LocalEquation
+ Agda.TypeChecking.Rewriting: checkLocalRewriteRule :: RewriteSource -> LocalEquation -> TCM (Maybe RewriteRule)
+ Agda.TypeChecking.Rewriting: checkRewConstraint :: LocalEquation -> TCM ()
+ Agda.TypeChecking.Rewriting: checkRewriteRule' :: LocalEquation -> RewriteSource -> MaybeT TCM RewriteRule
+ Agda.TypeChecking.Rewriting.Clause: instance Agda.TypeChecking.Rewriting.Clause.ToNLPat (Agda.Syntax.Common.Arg Agda.Syntax.Internal.DeBruijnPattern) (Agda.Syntax.Internal.Elim.Elim' Agda.Syntax.Internal.NLPat)
+ Agda.TypeChecking.Rewriting.Clause: instance Agda.TypeChecking.Rewriting.Clause.ToNLPat (Agda.Syntax.Common.NamedArg Agda.Syntax.Internal.DeBruijnPattern) (Agda.Syntax.Internal.Elim.Elim' Agda.Syntax.Internal.NLPat)
+ Agda.TypeChecking.Rewriting.Confluence: instance (Agda.TypeChecking.Substitute.Class.Subst a, Agda.TypeChecking.Rewriting.Confluence.ParallelReduce a) => Agda.TypeChecking.Rewriting.Confluence.ParallelReduce (Agda.Syntax.Internal.Abs a)
+ Agda.TypeChecking.Rewriting.NonLinMatch: getLocalHeadType :: PureTCM m => Term -> m (Maybe (Maybe QName, Type))
+ Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.TypeChecking.Rewriting.NonLinMatch.Match Agda.Syntax.Internal.NLPSort Agda.Syntax.Internal.Sort
+ Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.TypeChecking.Rewriting.NonLinMatch.Match Agda.Syntax.Internal.NLPType Agda.Syntax.Internal.Type
+ Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.TypeChecking.Rewriting.NonLinMatch.Match Agda.Syntax.Internal.NLPat Agda.Syntax.Internal.Level
+ Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.TypeChecking.Rewriting.NonLinMatch.Match Agda.Syntax.Internal.NLPat Agda.Syntax.Internal.Term
+ Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.TypeChecking.Rewriting.NonLinMatch.Match [Agda.Syntax.Internal.Elim.Elim' Agda.Syntax.Internal.NLPat] Agda.Syntax.Internal.Elims
+ Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.Utils.FileId.MonadFileId Agda.TypeChecking.Rewriting.NonLinMatch.NLM
+ Agda.TypeChecking.Rewriting.NonLinPattern: ($dmnlPatVarsUnder) :: forall p (f :: Type -> Type). (NLPatVars a, NLPatVars p, Foldable f, Functor f, a ~ f p) => Int -> a -> PatVars
+ Agda.TypeChecking.Rewriting.NonLinPattern: PatVars :: VarSet -> VarSet -> PatVars
+ Agda.TypeChecking.Rewriting.NonLinPattern: [maybeSingPatVars] :: PatVars -> VarSet
+ Agda.TypeChecking.Rewriting.NonLinPattern: [neverSingPatVars] :: PatVars -> VarSet
+ Agda.TypeChecking.Rewriting.NonLinPattern: data PatVars
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.GetMatchables Agda.Syntax.Internal.NLPSort
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.GetMatchables Agda.Syntax.Internal.NLPType
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.GetMatchables Agda.Syntax.Internal.NLPat
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.GetMatchables Agda.TypeChecking.Monad.Base.GlobalRewriteRule
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.NLPatToTerm Agda.Syntax.Internal.NLPSort Agda.Syntax.Internal.Sort
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.NLPatToTerm Agda.Syntax.Internal.NLPType Agda.Syntax.Internal.Type
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.NLPatToTerm Agda.Syntax.Internal.NLPat Agda.Syntax.Internal.Level
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.NLPatToTerm Agda.Syntax.Internal.NLPat Agda.Syntax.Internal.Term
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.NLPatVars Agda.Syntax.Internal.NLPSort
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.NLPatVars Agda.Syntax.Internal.NLPType
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.NLPatVars Agda.Syntax.Internal.NLPat
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.NLPatVars Agda.Syntax.Internal.PElims
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.NLPatVars a => Agda.TypeChecking.Rewriting.NonLinPattern.NLPatVars (Agda.Syntax.Common.Arg a)
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.NLPatVars a => Agda.TypeChecking.Rewriting.NonLinPattern.NLPatVars (Agda.Syntax.Internal.Dom a)
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.NLPatVars a => Agda.TypeChecking.Rewriting.NonLinPattern.NLPatVars (Agda.Syntax.Internal.Elim.Elim' a)
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.PatternFrom Agda.Syntax.Internal.Elims Agda.Syntax.Internal.PElims
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.PatternFrom Agda.Syntax.Internal.Level Agda.Syntax.Internal.NLPat
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.PatternFrom Agda.Syntax.Internal.Sort Agda.Syntax.Internal.NLPSort
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.PatternFrom Agda.Syntax.Internal.Term Agda.Syntax.Internal.NLPat
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.PatternFrom Agda.Syntax.Internal.Type Agda.Syntax.Internal.NLPType
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.Utils.Null.Null Agda.TypeChecking.Rewriting.NonLinPattern.PatVars
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.Utils.Singleton.Singleton (Agda.Syntax.Internal.DefSing, GHC.Types.Int) Agda.TypeChecking.Rewriting.NonLinPattern.PatVars
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance GHC.Base.Monoid Agda.TypeChecking.Rewriting.NonLinPattern.PatVars
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance GHC.Base.Semigroup Agda.TypeChecking.Rewriting.NonLinPattern.PatVars
+ Agda.TypeChecking.Rewriting.NonLinPattern: instance GHC.Classes.Eq Agda.TypeChecking.Rewriting.NonLinPattern.PatVars
+ Agda.TypeChecking.Rules.Data: checkNoLocalRewrites :: QName -> TCM ()
+ Agda.TypeChecking.Rules.Data: checkNoLocalRewrites' :: QName -> Tele (Dom Type) -> TCM ()
+ Agda.TypeChecking.Rules.Decl: addRewConstraints :: Telescope -> TCM Telescope
+ Agda.TypeChecking.Rules.Def: WithFunctionProblemData :: QName -> QName -> Type -> Telescope -> Telescope -> Telescope -> List1 (Arg (Term, EqualityView)) -> Type -> [NamedArg DeBruijnPattern] -> Nat -> Permutation -> Permutation -> Permutation -> List1 Clause -> Substitution -> Map Name LetBinding -> WithFunctionProblemData
+ Agda.TypeChecking.Rules.Def: class HasLHSCores a
+ Agda.TypeChecking.Rules.Def: data WithFunctionProblemData
+ Agda.TypeChecking.Rules.Def: instance Agda.TypeChecking.Rules.Def.HasLHSCores Agda.Syntax.Abstract.Clause
+ Agda.TypeChecking.Rules.Def: instance Agda.TypeChecking.Rules.Def.HasLHSCores Agda.Syntax.Abstract.LHS
+ Agda.TypeChecking.Rules.Def: instance Agda.TypeChecking.Rules.Def.HasLHSCores Agda.Syntax.Abstract.RHS
+ Agda.TypeChecking.Rules.Def: type WithFunctionProblem = IsWithFunction WithFunctionProblemData
+ Agda.TypeChecking.Rules.LHS: ClauseLHS :: QName -> LetOrClause
+ Agda.TypeChecking.Rules.LHS: LetLHS :: LetOrClause
+ Agda.TypeChecking.Rules.LHS: buildLHSSubstitutions :: Context -> NAPs -> IsWithFunction (Arity, Substitution) -> (Substitution, Substitution)
+ Agda.TypeChecking.Rules.LHS: checkAbsurdPattern :: AbsurdPattern -> TCM ()
+ Agda.TypeChecking.Rules.LHS: data LetOrClause
+ Agda.TypeChecking.Rules.LHS.Problem: [_lhsMatchPrio] :: LHSState a -> !MatchPrio
+ Agda.TypeChecking.Rules.LHS.Problem: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Syntax.Internal.MatchPrio
+ Agda.TypeChecking.Rules.LHS.Unify: CantTransport :: Closure (Abs Type) -> NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify: CantTransport' :: Closure Type -> NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: CantTransport :: Closure (Abs Type) -> NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: CantTransport' :: Closure Type -> NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: DEtaExpandVar :: FlexibleVar Int -> QName -> Args -> DigestedUnifyStep
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: DSolution :: Int -> Dom Type -> FlexibleVar Int -> Term -> Either () () -> DigestedUnifyStep
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: DUnificationStep :: UnifyState -> DigestedUnifyStep -> UnifyOutput -> DigestedUnifyLogEntry
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: data DigestedUnifyLogEntry
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: data DigestedUnifyStep
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: digestUnifyLog :: UnifyLog -> Either NoLeftInv DigestedUnifyLog
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Rules.LHS.Unify.LeftInverse.DigestedUnifyStep
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: type DigestedUnifyLog = [(DigestedUnifyLogEntry, UnifyState)]
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [unifySolutionPerm] :: UnifyOutput -> Maybe Permutation
+ Agda.TypeChecking.Rules.LHS.Unify.Types: tellUnifySolutionPerm :: MonadWriter UnifyOutput m => Permutation -> m ()
+ Agda.TypeChecking.Rules.Record.Cubical: addCompositionForRecord :: QName -> EtaEquality -> ConHead -> Telescope -> [Arg QName] -> Telescope -> Type -> TCM ()
+ Agda.TypeChecking.Rules.Term: ModTelData :: ModTelOrigin
+ Agda.TypeChecking.Rules.Term: ModTelNotData :: ModTelOrigin
+ Agda.TypeChecking.Rules.Term: appViewM :: Expr -> TCM AppView
+ Agda.TypeChecking.Rules.Term: data ModTelOrigin
+ Agda.TypeChecking.Rules.Term: guessRecordType :: Comparison -> Expr -> [Name] -> Type -> TCM Term
+ Agda.TypeChecking.Rules.Term: instance GHC.Classes.Eq Agda.TypeChecking.Rules.Term.ModTelOrigin
+ Agda.TypeChecking.Rules.Term: instance GHC.Show.Show Agda.TypeChecking.Rules.Term.ModTelOrigin
+ Agda.TypeChecking.Rules.Term: userOmittedModalities :: List1 (NamedArg Name) -> TCM Bool
+ Agda.TypeChecking.Serialise: deserializeHashes :: ByteString -> IO (Maybe (Hash, Hash))
+ Agda.TypeChecking.Serialise: deserializeInterface :: ByteString -> MaybeT TCM Encoded
+ Agda.TypeChecking.Serialise: type Encoded = (Word32, Array Node, Array String, Array Text, Array Text, Array Integer, Array VarSet, Array Double)
+ Agda.TypeChecking.Serialise: type InterfacePrefix = (Hash, Hash, Word64)
+ Agda.TypeChecking.Serialise.Base: Decode :: !IOArray MemoEntry -> !Compact -> !Array Node -> !Array String -> !Array Text -> !Array Text -> !Array Integer -> !Array VarSet -> !Array Double -> !HashTableLL AbsolutePath AbsolutePath -> !IORef ModuleToSource -> !List1 AbsolutePath -> Decode
+ Agda.TypeChecking.Serialise.Base: NameIdR :: {-# UNPACK #-} !NameId -> !Range -> NameIdR
+ Agda.TypeChecking.Serialise.Base: [arena] :: Decode -> !Compact
+ Agda.TypeChecking.Serialise.Base: [doubleA] :: Decode -> !Array Double
+ Agda.TypeChecking.Serialise.Base: [filePathMemo] :: Decode -> !HashTableLL AbsolutePath AbsolutePath
+ Agda.TypeChecking.Serialise.Base: [integerA] :: Decode -> !Array Integer
+ Agda.TypeChecking.Serialise.Base: [lTextA] :: Decode -> !Array Text
+ Agda.TypeChecking.Serialise.Base: [nidBindingSite] :: NameIdR -> !Range
+ Agda.TypeChecking.Serialise.Base: [nidNameId] :: NameIdR -> {-# UNPACK #-} !NameId
+ Agda.TypeChecking.Serialise.Base: [nodeA] :: Decode -> !Array Node
+ Agda.TypeChecking.Serialise.Base: [sTextA] :: Decode -> !Array Text
+ Agda.TypeChecking.Serialise.Base: [stringA] :: Decode -> !Array String
+ Agda.TypeChecking.Serialise.Base: [varSetA] :: Decode -> !Array VarSet
+ Agda.TypeChecking.Serialise.Base: [varSetC] :: Dict -> !FreshAndReuse
+ Agda.TypeChecking.Serialise.Base: [varSetD] :: Dict -> !HashTableLU VarSet Word32
+ Agda.TypeChecking.Serialise.Base: bumpFresh :: FreshAndReuse -> IO Word32
+ Agda.TypeChecking.Serialise.Base: bumpReuse :: FreshAndReuse -> IO ()
+ Agda.TypeChecking.Serialise.Base: cacheVar :: Int -> Maybe Word32
+ Agda.TypeChecking.Serialise.Base: data Decode
+ Agda.TypeChecking.Serialise.Base: data NameIdR
+ Agda.TypeChecking.Serialise.Base: getFresh :: FreshAndReuse -> IO Word32
+ Agda.TypeChecking.Serialise.Base: getReuse :: FreshAndReuse -> IO Word32
+ Agda.TypeChecking.Serialise.Base: icodeLText :: Text -> S Word32
+ Agda.TypeChecking.Serialise.Base: icodeSText :: Text -> S Word32
+ Agda.TypeChecking.Serialise.Base: icodeVarSet :: VarSet -> S Word32
+ Agda.TypeChecking.Serialise.Base: instance Agda.TypeChecking.Serialise.Base.ICODE (a -> b -> c -> d -> e -> t) ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc 'Agda.Utils.TypeLevel.Zero)))))
+ Agda.TypeChecking.Serialise.Base: instance Agda.TypeChecking.Serialise.Base.ICODE (a -> b -> c -> d -> t) ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc 'Agda.Utils.TypeLevel.Zero))))
+ Agda.TypeChecking.Serialise.Base: instance Agda.TypeChecking.Serialise.Base.ICODE (a -> b -> c -> t) ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc 'Agda.Utils.TypeLevel.Zero)))
+ Agda.TypeChecking.Serialise.Base: instance Agda.TypeChecking.Serialise.Base.ICODE (a -> b -> t) ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc 'Agda.Utils.TypeLevel.Zero))
+ Agda.TypeChecking.Serialise.Base: instance Agda.TypeChecking.Serialise.Base.ICODE (a -> t) ('Agda.Utils.TypeLevel.Suc 'Agda.Utils.TypeLevel.Zero)
+ Agda.TypeChecking.Serialise.Base: instance Agda.TypeChecking.Serialise.Base.ICODE t 'Agda.Utils.TypeLevel.Zero
+ Agda.TypeChecking.Serialise.Base: instance Agda.TypeChecking.Serialise.Base.ICODE t n => Agda.TypeChecking.Serialise.Base.ICODE (a -> b -> c -> d -> e -> f -> t) ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc n))))))
+ Agda.TypeChecking.Serialise.Base: instance Agda.TypeChecking.Serialise.Base.VALU (a -> b -> c -> d -> e -> t) ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc 'Agda.Utils.TypeLevel.Zero)))))
+ Agda.TypeChecking.Serialise.Base: instance Agda.TypeChecking.Serialise.Base.VALU (a -> b -> c -> d -> t) ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc 'Agda.Utils.TypeLevel.Zero))))
+ Agda.TypeChecking.Serialise.Base: instance Agda.TypeChecking.Serialise.Base.VALU (a -> b -> c -> t) ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc 'Agda.Utils.TypeLevel.Zero)))
+ Agda.TypeChecking.Serialise.Base: instance Agda.TypeChecking.Serialise.Base.VALU (a -> b -> t) ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc 'Agda.Utils.TypeLevel.Zero))
+ Agda.TypeChecking.Serialise.Base: instance Agda.TypeChecking.Serialise.Base.VALU (a -> t) ('Agda.Utils.TypeLevel.Suc 'Agda.Utils.TypeLevel.Zero)
+ Agda.TypeChecking.Serialise.Base: instance Agda.TypeChecking.Serialise.Base.VALU t 'Agda.Utils.TypeLevel.Zero
+ Agda.TypeChecking.Serialise.Base: instance Agda.TypeChecking.Serialise.Base.VALU t n => Agda.TypeChecking.Serialise.Base.VALU (a -> b -> c -> d -> e -> f -> t) ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc ('Agda.Utils.TypeLevel.Suc n))))))
+ Agda.TypeChecking.Serialise.Base: instance Data.Hashable.Class.Hashable Agda.TypeChecking.Serialise.Base.NameIdR
+ Agda.TypeChecking.Serialise.Base: instance GHC.Classes.Eq Agda.TypeChecking.Serialise.Base.NameIdR
+ Agda.TypeChecking.Serialise.Base: instance GHC.Generics.Generic Agda.TypeChecking.Serialise.Base.NameIdR
+ Agda.TypeChecking.Serialise.Base: malformedIO :: IO a
+ Agda.TypeChecking.Serialise.Base: nameIdR :: Name -> NameIdR
+ Agda.TypeChecking.Serialise.Base: type FreshAndReuse = IOArray Word32
+ Agda.TypeChecking.Serialise.Base: uncacheVar :: Word32 -> Maybe Term
+ Agda.TypeChecking.Serialise.Base: varRangeStart :: Word32
+ Agda.TypeChecking.Serialise.Instances.Abstract: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Abstract.Name.AbstractModule
+ Agda.TypeChecking.Serialise.Instances.Abstract: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Abstract.Name.AbstractName
+ Agda.TypeChecking.Serialise.Instances.Abstract: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Abstract.Name.KindOfName
+ Agda.TypeChecking.Serialise.Instances.Abstract: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Abstract.Name.NameMetadata
+ Agda.TypeChecking.Serialise.Instances.Abstract: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Abstract.Name.WhyInScope
+ Agda.TypeChecking.Serialise.Instances.Abstract: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Abstract.PatternSynDefn
+ Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Common.AllowedErasedMatches
+ Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Common.AllowedErasedMatchesIndexed
+ Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Common.AllowedErasedMatchesWithDefaults
+ Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Common.PositivityCheck
+ Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Common.RewriteAnn
+ Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Syntax.Common.DataOrRecord' a)
+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Interaction.Library.Base.LibDepNode
+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Interaction.Library.Base.LibFilePos
+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Interaction.Options.ProfileOptions.ProfileOption
+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Interaction.Options.ProfileOptions.ProfileOptions
+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Parser.Monad.OpenBracket
+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.TypeChecking.Monad.Base.SerialisableRewriteSource
+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.TypeChecking.Monad.Base.Types.Context
+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.TypeChecking.Monad.Base.Types.ContextEntry
+ Agda.TypeChecking.Serialise.Instances.General: Cons :: a -> b -> !KVS a b -> KVS a b
+ Agda.TypeChecking.Serialise.Instances.General: Nil :: KVS a b
+ Agda.TypeChecking.Serialise.Instances.General: data KVS a b
+ Agda.TypeChecking.Serialise.Instances.General: icodeList :: EmbPrj a => [a] -> S Node
+ Agda.TypeChecking.Serialise.Instances.General: icodeListPair :: (EmbPrj k, EmbPrj v) => KVS k v -> S Node
+ Agda.TypeChecking.Serialise.Instances.General: instance (Agda.TypeChecking.Serialise.Base.EmbPrj a, Agda.TypeChecking.Serialise.Base.EmbPrj b) => Agda.TypeChecking.Serialise.Base.EmbPrj (Data.Either.Either a b)
+ Agda.TypeChecking.Serialise.Instances.General: instance (Agda.TypeChecking.Serialise.Base.EmbPrj a, Agda.TypeChecking.Serialise.Base.EmbPrj b) => Agda.TypeChecking.Serialise.Base.EmbPrj (Data.Strict.Tuple.Pair a b)
+ Agda.TypeChecking.Serialise.Instances.General: instance (Agda.TypeChecking.Serialise.Base.EmbPrj a, Agda.TypeChecking.Serialise.Base.EmbPrj b) => Agda.TypeChecking.Serialise.Base.EmbPrj (a, b)
+ Agda.TypeChecking.Serialise.Instances.General: instance (Agda.TypeChecking.Serialise.Base.EmbPrj a, Agda.TypeChecking.Serialise.Base.EmbPrj b, Agda.TypeChecking.Serialise.Base.EmbPrj c) => Agda.TypeChecking.Serialise.Base.EmbPrj (a, b, c)
+ Agda.TypeChecking.Serialise.Instances.General: instance (Agda.TypeChecking.Serialise.Base.EmbPrj a, Data.Typeable.Internal.Typeable b) => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Utils.WithDefault.WithDefault' a b)
+ Agda.TypeChecking.Serialise.Instances.General: instance (Agda.TypeChecking.Serialise.Base.EmbPrj k, Agda.TypeChecking.Serialise.Base.EmbPrj v, Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Utils.BiMap.Tag v)) => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Utils.BiMap.BiMap k v)
+ Agda.TypeChecking.Serialise.Instances.General: instance (Data.Hashable.Class.Hashable a, Agda.TypeChecking.Serialise.Base.EmbPrj a) => Agda.TypeChecking.Serialise.Base.EmbPrj (Data.HashSet.Internal.HashSet a)
+ Agda.TypeChecking.Serialise.Instances.General: instance (Data.Hashable.Class.Hashable k, Agda.TypeChecking.Serialise.Base.EmbPrj k, Agda.TypeChecking.Serialise.Base.EmbPrj v) => Agda.TypeChecking.Serialise.Base.EmbPrj (Data.HashMap.Internal.HashMap k v)
+ Agda.TypeChecking.Serialise.Instances.General: instance (GHC.Classes.Ord a, Agda.TypeChecking.Serialise.Base.EmbPrj a, Agda.TypeChecking.Serialise.Base.EmbPrj b) => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Utils.Trie.Trie a b)
+ Agda.TypeChecking.Serialise.Instances.General: instance (GHC.Classes.Ord a, Agda.TypeChecking.Serialise.Base.EmbPrj a, Agda.TypeChecking.Serialise.Base.EmbPrj b) => Agda.TypeChecking.Serialise.Base.EmbPrj (Data.Map.Internal.Map a b)
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj ()
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Utils.VarSet.VarSet
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj Data.IntSet.Internal.IntSet
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj Data.Text.Internal.Lazy.Text
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj Data.Text.Internal.Text
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj GHC.Base.String
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj GHC.Base.Void
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj GHC.Int.Int32
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj GHC.Num.Integer.Integer
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj GHC.Types.Bool
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj GHC.Types.Char
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj GHC.Types.Double
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj GHC.Types.Int
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj GHC.Word.Word32
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj GHC.Word.Word64
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Utils.DocTree.DocTree a)
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Utils.List1.List1 a)
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Utils.List2.List2 a)
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Utils.Set1.Set1 a)
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Data.Sequence.Internal.Seq a)
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Data.Set.Internal.Set a)
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Data.Strict.Maybe.Maybe a)
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Data.Tree.Tree a)
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (GHC.Maybe.Maybe a)
+ Agda.TypeChecking.Serialise.Instances.General: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj [a]
+ Agda.TypeChecking.Serialise.Instances.General: instance Data.Typeable.Internal.Typeable a => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Utils.SmallSet.SmallSet a)
+ Agda.TypeChecking.Serialise.Instances.General: valueList :: EmbPrj a => Node -> R [a]
+ Agda.TypeChecking.Serialise.Instances.General: valueListPair :: (EmbPrj k, EmbPrj v) => Node -> R [(k, v)]
+ Agda.TypeChecking.Serialise.Instances.Highlighting: Cons :: !Int -> !Int -> a -> !KVS a -> KVS a
+ Agda.TypeChecking.Serialise.Instances.Highlighting: Nil :: KVS a
+ Agda.TypeChecking.Serialise.Instances.Highlighting: data KVS a
+ Agda.TypeChecking.Serialise.Instances.Highlighting: icodRM :: EmbPrj a => KVS a -> S Node
+ Agda.TypeChecking.Serialise.Instances.Highlighting: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Utils.Range.Range
+ Agda.TypeChecking.Serialise.Instances.Highlighting: toAscList' :: RangeMap a -> KVS a
+ Agda.TypeChecking.Serialise.Instances.Highlighting: valueRM :: EmbPrj a => Node -> R [(Int, PairInt a)]
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Common.IsHIT
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Internal.ClauseRecursive
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Internal.DefSing
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Internal.DummyTermKind
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Internal.LitPatternInfo
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Internal.LocalEquation
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Internal.MatchPrio
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Internal.NLPSort
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Internal.NLPType
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Internal.NLPat
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Internal.RewDom
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Internal.RewriteHead
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Internal.RewriteRule
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.TypeChecking.Monad.Base.EtaProvenance
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.TypeChecking.Monad.Base.GlobalRewriteRule
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.TypeChecking.Monad.Base.IsPathCons
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Syntax.Internal.BlockedDepCheck a)
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.TypeChecking.Monad.Base.Types.IsWithFunction a)
+ Agda.TypeChecking.Serialise.Node: N0 :: Node
+ Agda.TypeChecking.Serialise.Node: N1# :: !Word32 -> Node
+ Agda.TypeChecking.Serialise.Node: N2# :: !Word64 -> Node
+ Agda.TypeChecking.Serialise.Node: N3# :: !Word64 -> !Word32 -> Node
+ Agda.TypeChecking.Serialise.Node: N4# :: !Word64 -> !Word64 -> Node
+ Agda.TypeChecking.Serialise.Node: N5# :: !Word64 -> !Word64 -> !Word32 -> Node
+ Agda.TypeChecking.Serialise.Node: N6# :: !Word64 -> !Word64 -> !Word64 -> !Node -> Node
+ Agda.TypeChecking.Serialise.Node: data Node
+ Agda.TypeChecking.Serialise.Node: instance Agda.Utils.Serialize.Serialize Agda.TypeChecking.Serialise.Node.Node
+ Agda.TypeChecking.Serialise.Node: instance Data.Hashable.Class.Hashable Agda.TypeChecking.Serialise.Node.Node
+ Agda.TypeChecking.Serialise.Node: instance GHC.Classes.Eq Agda.TypeChecking.Serialise.Node.Node
+ Agda.TypeChecking.Serialise.Node: instance GHC.Show.Show Agda.TypeChecking.Serialise.Node.Node
+ Agda.TypeChecking.Serialise.Node: pattern N1 :: Word32 -> Node
+ Agda.TypeChecking.Serialise.Node: pattern N2 :: Word32 -> Word32 -> Node
+ Agda.TypeChecking.Serialise.Node: pattern N3 :: Word32 -> Word32 -> Word32 -> Node
+ Agda.TypeChecking.Serialise.Node: pattern N4 :: Word32 -> Word32 -> Word32 -> Word32 -> Node
+ Agda.TypeChecking.Serialise.Node: pattern N5 :: Word32 -> Word32 -> Word32 -> Word32 -> Word32 -> Node
+ Agda.TypeChecking.Serialise.Node: pattern N6 :: Word32 -> Word32 -> Word32 -> Word32 -> Word32 -> Word32 -> Node -> Node
+ Agda.TypeChecking.Substitute: AnySub :: (forall a. DeBruijn a => Substitution' a) -> AnySubstitution
+ Agda.TypeChecking.Substitute: CodomainNormalised :: IsCodomainNormalised
+ Agda.TypeChecking.Substitute: CodomainNotNormalised :: IsCodomainNormalised
+ Agda.TypeChecking.Substitute: [getSub] :: AnySubstitution -> forall a. DeBruijn a => Substitution' a
+ Agda.TypeChecking.Substitute: applySubstLocalRewrite :: DeBruijn a => Substitution' a -> RewriteRule -> Maybe RewriteRule
+ Agda.TypeChecking.Substitute: data AnySubstitution
+ Agda.TypeChecking.Substitute: data IsCodomainNormalised
+ Agda.TypeChecking.Substitute: domNameFromNamedArgName :: NamedArg Name -> Dom Name
+ Agda.TypeChecking.Substitute: funSortM :: HasOptions m => Sort -> Sort -> m Sort
+ Agda.TypeChecking.Substitute: funSortM' :: HasOptions m => Sort -> Sort -> m (Either Blocker Sort)
+ Agda.TypeChecking.Substitute: instance (Agda.TypeChecking.Substitute.Class.Subst a, Agda.TypeChecking.Substitute.Class.Subst b, Agda.TypeChecking.Substitute.Class.SubstArg a GHC.Types.~ Agda.TypeChecking.Substitute.Class.SubstArg b) => Agda.TypeChecking.Substitute.Class.Subst (Agda.Syntax.Internal.Type'' a b)
+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Abstract Agda.TypeChecking.Monad.Base.GlobalRewriteRule
+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Apply Agda.TypeChecking.Monad.Base.GlobalRewriteRule
+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.NLPSort
+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.NLPType
+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.NLPat
+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.RewriteHead
+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Monad.Base.GlobalRewriteRule
+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst a => Agda.TypeChecking.Substitute.Class.Subst (Agda.Syntax.Internal.LocalEquation' a)
+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst a => Agda.TypeChecking.Substitute.Class.Subst (Agda.Syntax.Internal.RewDom' a)
+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst a => Agda.TypeChecking.Substitute.Class.Subst (Agda.Syntax.Internal.Sort' a)
+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.DeBruijn.DeBruijn Agda.Syntax.Internal.NLPat
+ Agda.TypeChecking.Substitute: instance GHC.Classes.Eq (Agda.Syntax.Internal.DomInfo Agda.Syntax.Internal.Term)
+ Agda.TypeChecking.Substitute: instance GHC.Classes.Eq Agda.Syntax.Internal.DefSing
+ Agda.TypeChecking.Substitute: instance GHC.Classes.Eq Agda.Syntax.Internal.LocalEquation
+ Agda.TypeChecking.Substitute: instance GHC.Classes.Eq Agda.Syntax.Internal.NLPSort
+ Agda.TypeChecking.Substitute: instance GHC.Classes.Eq Agda.Syntax.Internal.NLPType
+ Agda.TypeChecking.Substitute: instance GHC.Classes.Eq Agda.Syntax.Internal.NLPat
+ Agda.TypeChecking.Substitute: instance GHC.Classes.Eq Agda.Syntax.Internal.RewDom
+ Agda.TypeChecking.Substitute: instance GHC.Classes.Eq Agda.Syntax.Internal.RewriteRule
+ Agda.TypeChecking.Substitute: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.Syntax.Internal.BlockedDepCheck a)
+ Agda.TypeChecking.Substitute: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.Syntax.Internal.Elim.Elim' a)
+ Agda.TypeChecking.Substitute: instance GHC.Classes.Ord (Agda.Syntax.Internal.DomInfo Agda.Syntax.Internal.Term)
+ Agda.TypeChecking.Substitute: instance GHC.Classes.Ord Agda.Syntax.Internal.DefSing
+ Agda.TypeChecking.Substitute: instance GHC.Classes.Ord Agda.Syntax.Internal.LocalEquation
+ Agda.TypeChecking.Substitute: instance GHC.Classes.Ord Agda.Syntax.Internal.NLPSort
+ Agda.TypeChecking.Substitute: instance GHC.Classes.Ord Agda.Syntax.Internal.NLPType
+ Agda.TypeChecking.Substitute: instance GHC.Classes.Ord Agda.Syntax.Internal.NLPat
+ Agda.TypeChecking.Substitute: instance GHC.Classes.Ord Agda.Syntax.Internal.RewDom
+ Agda.TypeChecking.Substitute: instance GHC.Classes.Ord Agda.Syntax.Internal.RewriteHead
+ Agda.TypeChecking.Substitute: instance GHC.Classes.Ord Agda.Syntax.Internal.RewriteRule
+ Agda.TypeChecking.Substitute: instance GHC.Classes.Ord a => GHC.Classes.Ord (Agda.Syntax.Internal.BlockedDepCheck a)
+ Agda.TypeChecking.Substitute: instance GHC.Classes.Ord a => GHC.Classes.Ord (Agda.Syntax.Internal.Elim.Elim' a)
+ Agda.TypeChecking.Substitute: lookupSVar :: EndoSubst a => Substitution' a -> Nat -> Maybe Nat
+ Agda.TypeChecking.Substitute: piSortB :: Dom Term -> Sort -> Abs Sort -> Either Blocker Sort
+ Agda.TypeChecking.Substitute: piSortB' :: BlockedDepCheck Sort -> Dom Term -> Sort -> Abs Sort -> Either Blocker Sort
+ Agda.TypeChecking.Substitute: piSortB'' :: Dom Term -> Sort -> Abs Sort -> FlexRig -> IsCodomainNormalised -> Either Blocker Sort
+ Agda.TypeChecking.Substitute: piSortM :: HasOptions m => Dom Term -> Sort -> Abs Sort -> m Sort
+ Agda.TypeChecking.Substitute: piSortM' :: HasOptions m => BlockedDepCheck Sort -> Dom Term -> Sort -> Abs Sort -> m Sort
+ Agda.TypeChecking.Substitute: piSortM'' :: HasOptions m => BlockedDepCheck Sort -> Dom Term -> Sort -> Abs Sort -> Either Blocker Sort -> m Sort
+ Agda.TypeChecking.Substitute: toRenOn :: DeBruijn a => VarSet -> Substitution' a -> Maybe AnySubstitution
+ Agda.TypeChecking.Substitute.Class: instance Agda.TypeChecking.Substitute.DeBruijn.DeBruijn t => Agda.TypeChecking.Substitute.Class.Subst (Agda.Syntax.Internal.NoSubst t a)
+ Agda.TypeChecking.Substitute.Class: lookupS' :: EndoSubst a => Nat -> Substitution' a -> Nat -> a
+ Agda.TypeChecking.Substitute.Class: type WeakSubst a = SubstWith Nat a
+ Agda.TypeChecking.Substitute.DeBruijn: instance Agda.TypeChecking.Substitute.DeBruijn.DeBruijn Agda.Syntax.Common.Nat
+ Agda.TypeChecking.SyntacticEquality: instance Agda.TypeChecking.SyntacticEquality.SynEq a => Agda.TypeChecking.SyntacticEquality.SynEq (Agda.Syntax.Internal.BlockedDepCheck a)
+ Agda.TypeChecking.Telescope: flattenRevTel :: TermSubst a => Tele (Dom a) -> [Dom a]
+ Agda.TypeChecking.Telescope: safeTelViewUpTo' :: forall (m :: Type -> Type). (MonadReduce m, MonadAddContext m) => Int -> (Dom Type -> Bool) -> Type -> MaybeT m TelView
+ Agda.TypeChecking.With: elemConForms :: ConHead -> AmbiguousQName -> TCM Bool
+ Agda.Utils.Atomic: data Atomic a
+ Agda.Utils.Atomic: instance Control.DeepSeq.NFData (Agda.Utils.Atomic.Atomic a)
+ Agda.Utils.Atomic: instance GHC.Classes.Eq (Agda.Utils.Atomic.Atomic a)
+ Agda.Utils.Atomic: modifyAtomic :: (MonadIO m, MonadMask m) => Atomic a -> (a -> m (a, b)) -> m b
+ Agda.Utils.Atomic: newAtomic :: MonadIO m => a -> m (Atomic a)
+ Agda.Utils.Atomic: readAtomic :: MonadIO m => Atomic a -> m a
+ Agda.Utils.Atomic: withAtomic :: (MonadIO m, MonadMask m) => Atomic a -> (a -> m ()) -> m ()
+ Agda.Utils.Benchmark: instance Agda.Utils.Benchmark.MonadBench m => Agda.Utils.Benchmark.MonadBench (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.Utils.Benchmark: instance Control.DeepSeq.NFData (Agda.Utils.Benchmark.BenchmarkOn a)
+ Agda.Utils.BinTree: data BinTree a
+ Agda.Utils.BinTree: instance Agda.Utils.Null.Null (Agda.Utils.BinTree.BinTree a)
+ Agda.Utils.BinTree: instance Agda.Utils.Singleton.Singleton a (Agda.Utils.BinTree.BinTree a)
+ Agda.Utils.BinTree: instance Data.Foldable.Foldable Agda.Utils.BinTree.BinTree
+ Agda.Utils.BinTree: instance Data.Traversable.Traversable Agda.Utils.BinTree.BinTree
+ Agda.Utils.BinTree: instance GHC.Base.Functor Agda.Utils.BinTree.BinTree
+ Agda.Utils.BinTree: instance GHC.Base.Monoid (Agda.Utils.BinTree.BinTree a)
+ Agda.Utils.BinTree: instance GHC.Base.Semigroup (Agda.Utils.BinTree.BinTree a)
+ Agda.Utils.BinTree: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.Utils.BinTree.BinTree a)
+ Agda.Utils.BinTree: instance GHC.Classes.Ord a => GHC.Classes.Ord (Agda.Utils.BinTree.BinTree a)
+ Agda.Utils.BinTree: instance GHC.Show.Show a => GHC.Show.Show (Agda.Utils.BinTree.BinTree a)
+ Agda.Utils.BinTree: prependToList :: BinTree a -> [a] -> [a]
+ Agda.Utils.BinTree: toList :: BinTree a -> [a]
+ Agda.Utils.BinTree1: data BinTree1 a
+ Agda.Utils.BinTree1: instance Agda.Utils.Singleton.Singleton a (Agda.Utils.BinTree1.BinTree1 a)
+ Agda.Utils.BinTree1: instance Data.Foldable.Foldable Agda.Utils.BinTree1.BinTree1
+ Agda.Utils.BinTree1: instance Data.Traversable.Traversable Agda.Utils.BinTree1.BinTree1
+ Agda.Utils.BinTree1: instance GHC.Base.Functor Agda.Utils.BinTree1.BinTree1
+ Agda.Utils.BinTree1: instance GHC.Base.Semigroup (Agda.Utils.BinTree1.BinTree1 a)
+ Agda.Utils.BinTree1: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.Utils.BinTree1.BinTree1 a)
+ Agda.Utils.BinTree1: instance GHC.Classes.Ord a => GHC.Classes.Ord (Agda.Utils.BinTree1.BinTree1 a)
+ Agda.Utils.BinTree1: instance GHC.Show.Show a => GHC.Show.Show (Agda.Utils.BinTree1.BinTree1 a)
+ Agda.Utils.BinTree1: prependToList :: BinTree1 a -> [a] -> [a]
+ Agda.Utils.BinTree1: toList :: BinTree1 a -> [a]
+ Agda.Utils.BinTree1: toList1 :: BinTree1 a -> List1 a
+ Agda.Utils.ByteArray: byteArrayDisjoint# :: ByteArray# -> ByteArray# -> Int#
+ Agda.Utils.ByteArray: byteArrayFoldlBits# :: (a -> Int -> a) -> a -> ByteArray# -> a
+ Agda.Utils.ByteArray: byteArrayFoldlBitsStrict# :: (a -> Int -> a) -> a -> ByteArray# -> a
+ Agda.Utils.ByteArray: byteArrayFoldrBits# :: (Int -> a -> a) -> a -> ByteArray# -> a
+ Agda.Utils.ByteArray: byteArrayFoldrBitsStrict# :: (Int -> a -> a) -> a -> ByteArray# -> a
+ Agda.Utils.ByteArray: byteArrayIsSubsetOf# :: ByteArray# -> ByteArray# -> Int#
+ Agda.Utils.ByteArray: byteArrayOnes# :: Int# -> ByteArray#
+ Agda.Utils.CompactRegion: Compact :: Compact# -> Compact
+ Agda.Utils.CompactRegion: add :: Compact -> a -> IO a
+ Agda.Utils.CompactRegion: compactWithSharing :: a -> IO a
+ Agda.Utils.CompactRegion: data Compact
+ Agda.Utils.CompactRegion: instance Control.DeepSeq.NFData Agda.Utils.CompactRegion.Compact
+ Agda.Utils.CompactRegion: new :: Word -> IO Compact
+ Agda.Utils.CompressedTrie: Trie :: !Maybe v -> !Map (List1 k) (Trie k v) -> Trie k v
+ Agda.Utils.CompressedTrie: [trieBranches] :: Trie k v -> !Map (List1 k) (Trie k v)
+ Agda.Utils.CompressedTrie: [trieValue] :: Trie k v -> !Maybe v
+ Agda.Utils.CompressedTrie: compress :: Ord k => Trie k v -> Trie k v
+ Agda.Utils.CompressedTrie: data Trie k v
+ Agda.Utils.CompressedTrie: instance (Control.DeepSeq.NFData k, Control.DeepSeq.NFData v) => Control.DeepSeq.NFData (Agda.Utils.CompressedTrie.Trie k v)
+ Agda.Utils.CompressedTrie: instance (GHC.Classes.Eq v, GHC.Classes.Eq k) => GHC.Classes.Eq (Agda.Utils.CompressedTrie.Trie k v)
+ Agda.Utils.CompressedTrie: instance (GHC.Show.Show v, GHC.Show.Show k) => GHC.Show.Show (Agda.Utils.CompressedTrie.Trie k v)
+ Agda.Utils.CompressedTrie: instance Agda.Utils.Null.Null (Agda.Utils.CompressedTrie.Trie k v)
+ Agda.Utils.CompressedTrie: instance Agda.Utils.Singleton.Singleton ([k], v) (Agda.Utils.CompressedTrie.Trie k v)
+ Agda.Utils.CompressedTrie: instance Data.Foldable.Foldable (Agda.Utils.CompressedTrie.Trie k)
+ Agda.Utils.CompressedTrie: instance GHC.Base.Functor (Agda.Utils.CompressedTrie.Trie k)
+ Agda.Utils.CompressedTrie: isSingleBranch :: Trie k v -> Maybe (List1 k, Trie k v)
+ Agda.Utils.CompressedTrie: root :: v -> Trie k v
+ Agda.Utils.CompressedTrie: singleBranch :: List1 k -> Trie k v -> (List1 k, Trie k v)
+ Agda.Utils.CompressedTrie: singleton :: [k] -> v -> Trie k v
+ Agda.Utils.CompressedTrie: singleton1 :: List1 k -> v -> Trie k v
+ Agda.Utils.CompressedTrie: size :: Trie k v -> Int
+ Agda.Utils.CompressedTrie: sizeWithLeaves :: Trie k v -> Int
+ Agda.Utils.CompressedTrie: substLeaves :: (Maybe v -> Trie k v) -> Trie k v -> Trie k v
+ Agda.Utils.CompressedTrie: toAscList :: Ord k => Trie k v -> [([k], v)]
+ Agda.Utils.CompressedTrie: toList :: Ord k => Trie k v -> [([k], v)]
+ Agda.Utils.CompressedTrie: truncate :: Int -> Trie k v -> Trie k v
+ Agda.Utils.CompressedTrie: truncateSize :: (Trie k v -> Int) -> Int -> Trie k v -> Trie k v
+ Agda.Utils.CompressedTrie: truncateSizeWithLeaves :: Int -> Trie k v -> Trie k v
+ Agda.Utils.CompressedTrie: uncompress :: Ord k => Trie k v -> Trie k v
+ Agda.Utils.DocTree: Node :: ann -> [DocTree ann] -> DocTree ann
+ Agda.Utils.DocTree: Text :: Text -> DocTree ann
+ Agda.Utils.DocTree: data DocTree ann
+ Agda.Utils.DocTree: instance Agda.Utils.Null.Null (Agda.Utils.DocTree.DocTree ann)
+ Agda.Utils.DocTree: instance Agda.Utils.Null.Null ann => Agda.Utils.Null.Null (Agda.Utils.DocTree.Item ann)
+ Agda.Utils.DocTree: instance Agda.Utils.Null.Null ann => Agda.Utils.Null.Null (Agda.Utils.DocTree.St ann)
+ Agda.Utils.DocTree: instance Control.DeepSeq.NFData ann => Control.DeepSeq.NFData (Agda.Utils.DocTree.DocTree ann)
+ Agda.Utils.DocTree: instance GHC.Generics.Generic (Agda.Utils.DocTree.DocTree ann)
+ Agda.Utils.DocTree: instance GHC.Show.Show ann => GHC.Show.Show (Agda.Utils.DocTree.DocTree ann)
+ Agda.Utils.DocTree: prettyDocTree :: DocTree ann -> Doc ann
+ Agda.Utils.DocTree: renderToTree :: Null ann => Doc ann -> DocTree ann
+ Agda.Utils.DocTree: renderToTree' :: Null ann => Width -> Fill -> Doc ann -> DocTree ann
+ Agda.Utils.DocTree: renderTree' :: forall ann t. Monoid t => (Text -> t) -> (ann -> t -> t) -> DocTree ann -> t
+ Agda.Utils.DocTree: treeToText :: (ann -> Text -> Text) -> DocTree ann -> Text
+ Agda.Utils.DocTree: treeToTextNoAnn :: DocTree ann -> Text
+ Agda.Utils.DocTree: treeToTextWithAnn :: (Monoid ann, Null ann) => DocTree ann -> (Text, RangeMap ann)
+ Agda.Utils.ExpandCase: ($dmexpand) :: (ExpandCase a, Result a ~ a) => ((a -> Result a) -> Result a) -> a
+ Agda.Utils.ExpandCase: class ExpandCase a where {
+ Agda.Utils.ExpandCase: expand :: ExpandCase a => ((a -> Result a) -> Result a) -> a
+ Agda.Utils.ExpandCase: instance Agda.Utils.ExpandCase.ExpandCase ()
+ Agda.Utils.ExpandCase: instance Agda.Utils.ExpandCase.ExpandCase (Data.Semigroup.Internal.Endo a)
+ Agda.Utils.ExpandCase: instance Agda.Utils.ExpandCase.ExpandCase (Data.Strict.Tuple.Pair a b)
+ Agda.Utils.ExpandCase: instance Agda.Utils.ExpandCase.ExpandCase (GHC.Maybe.Maybe a)
+ Agda.Utils.ExpandCase: instance Agda.Utils.ExpandCase.ExpandCase (GHC.Types.IO a)
+ Agda.Utils.ExpandCase: instance Agda.Utils.ExpandCase.ExpandCase Data.Semigroup.Internal.All
+ Agda.Utils.ExpandCase: instance Agda.Utils.ExpandCase.ExpandCase Data.Semigroup.Internal.Any
+ Agda.Utils.ExpandCase: instance Agda.Utils.ExpandCase.ExpandCase GHC.Types.Bool
+ Agda.Utils.ExpandCase: instance Agda.Utils.ExpandCase.ExpandCase GHC.Types.Int
+ Agda.Utils.ExpandCase: instance Agda.Utils.ExpandCase.ExpandCase [a]
+ Agda.Utils.ExpandCase: type Result a;
+ Agda.Utils.ExpandCase: }
+ Agda.Utils.Favorites: instance GHC.Base.Functor Agda.Utils.Favorites.Favorites
+ Agda.Utils.FileId: instance (Agda.Utils.FileId.MonadFileId m, GHC.Base.Monoid w) => Agda.Utils.FileId.MonadFileId (Agda.Utils.StrictWriter.WriterT w m)
+ Agda.Utils.FileId: instance (Agda.Utils.FileId.MonadFileId m, GHC.Base.Monoid w) => Agda.Utils.FileId.MonadFileId (Control.Monad.Trans.Writer.Lazy.WriterT w m)
+ Agda.Utils.FileId: instance Agda.Utils.FileId.MonadFileId m => Agda.Utils.FileId.MonadFileId (Agda.Utils.ListT.ListT m)
+ Agda.Utils.FileId: instance Agda.Utils.FileId.MonadFileId m => Agda.Utils.FileId.MonadFileId (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.Utils.FileId: instance Agda.Utils.FileId.MonadFileId m => Agda.Utils.FileId.MonadFileId (Agda.Utils.StrictState.StateT s m)
+ Agda.Utils.FileId: instance Agda.Utils.FileId.MonadFileId m => Agda.Utils.FileId.MonadFileId (Agda.Utils.Update.ChangeT m)
+ Agda.Utils.FileId: instance Agda.Utils.FileId.MonadFileId m => Agda.Utils.FileId.MonadFileId (Control.Monad.Trans.Identity.IdentityT m)
+ Agda.Utils.FileId: instance Agda.Utils.FileId.MonadFileId m => Agda.Utils.FileId.MonadFileId (Control.Monad.Trans.Maybe.MaybeT m)
+ Agda.Utils.FileName: instance Agda.Utils.Null.Null Agda.Utils.FileName.AbsolutePath
+ Agda.Utils.Function: ($$!) :: (a -> b) -> a -> b
+ Agda.Utils.Function: infixl 9 $$!
+ Agda.Utils.GetOpt: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Utils.GetOpt.ArgDescr a)
+ Agda.Utils.GetOpt: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Utils.GetOpt.OptDescr a)
+ Agda.Utils.Graph.AdjacencyMap.Unidirectional: loops :: Ord n => Graph n e -> [(n, e)]
+ Agda.Utils.Graph.AdjacencyMap.Unidirectional: mapLoops :: Ord n => (e -> e) -> Graph n e -> Graph n e
+ Agda.Utils.Hash: combineInt :: Int -> Int -> Int
+ Agda.Utils.Hash: combineWord :: Word -> Word -> Word
+ Agda.Utils.Hash: factor :: Word
+ Agda.Utils.Hash: hashSize :: Int
+ Agda.Utils.HashTable: HashTable :: Dictionary (PrimState IO) ks k vs v -> HashTable (ks :: Type -> Type -> Type) k (vs :: Type -> Type -> Type) v
+ Agda.Utils.HashTable: clone :: forall (ks :: Type -> Type -> Type) k (vs :: Type -> Type -> Type) v. (MVector ks k, MVector vs v) => HashTable ks k vs v -> IO (HashTable ks k vs v)
+ Agda.Utils.HashTable: forAssocs :: forall (ks :: Type -> Type -> Type) k (vs :: Type -> Type -> Type) v. (MVector ks k, MVector vs v) => HashTable ks k vs v -> (k -> v -> IO ()) -> IO ()
+ Agda.Utils.HashTable: forAssocsAccum :: forall (ks :: Type -> Type -> Type) k (vs :: Type -> Type -> Type) v acc. (MVector ks k, MVector vs v) => HashTable ks k vs v -> acc -> (k -> v -> acc -> IO acc) -> IO acc
+ Agda.Utils.HashTable: hasKey :: forall k (ks :: Type -> Type -> Type) (vs :: Type -> Type -> Type) v. (Hashable k, MVector ks k, MVector vs v) => HashTable ks k vs v -> k -> IO Bool
+ Agda.Utils.HashTable: insertingIfAbsent :: forall (ks :: Type -> Type -> Type) k (vs :: Type -> Type -> Type) v a. (Hashable k, MVector ks k, MVector vs v) => HashTable ks k vs v -> k -> (v -> IO a) -> IO v -> (v -> IO a) -> IO a
+ Agda.Utils.HashTable: lookupCPS :: forall a k v (ks :: Type -> Type -> Type) (vs :: Type -> Type -> Type). (MVector ks k, MVector vs v, Hashable k) => k -> HashTable ks k vs v -> (v -> IO a) -> IO a -> IO a
+ Agda.Utils.HashTable: newtype HashTable (ks :: Type -> Type -> Type) k (vs :: Type -> Type -> Type) v
+ Agda.Utils.HashTable: size :: forall (ks :: Type -> Type -> Type) k (vs :: Type -> Type -> Type) v. MVector ks k => HashTable ks k vs v -> IO Int
+ Agda.Utils.HashTable: type HashTableLL k v = HashTable MVector k MVector v
+ Agda.Utils.HashTable: type HashTableLU k v = HashTable MVector k MVector v
+ Agda.Utils.HashTable: type HashTableUL k v = HashTable MVector k MVector v
+ Agda.Utils.HashTable: type HashTableUU k v = HashTable MVector k MVector v
+ Agda.Utils.Haskell.Syntax: qualifiedImport :: ModuleName -> ImportDecl
+ Agda.Utils.IO.Terminal: environmentColor :: IO Bool
+ Agda.Utils.IO.Terminal: stdoutSupportsANSI :: IO Bool
+ Agda.Utils.IORef.Strict: StrictIORef :: IORef a -> IORef a
+ Agda.Utils.IORef.Strict: atomicModifyIORef :: IORef a -> (a -> (a, b)) -> IO b
+ Agda.Utils.IORef.Strict: modifyIORef :: IORef a -> (a -> a) -> IO ()
+ Agda.Utils.IORef.Strict: newIORef :: a -> IO (IORef a)
+ Agda.Utils.IORef.Strict: newtype IORef a
+ Agda.Utils.IORef.Strict: readIORef :: IORef a -> IO a
+ Agda.Utils.IORef.Strict: writeIORef :: IORef a -> a -> IO ()
+ Agda.Utils.IndexMap: append :: IndexMap a -> [a] -> IndexMap a
+ Agda.Utils.IndexMap: data IndexMap a
+ Agda.Utils.IndexMap: fromList :: [a] -> IndexMap a
+ Agda.Utils.IndexMap: index :: Int -> IndexMap a -> a
+ Agda.Utils.IndexMap: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.Utils.IndexMap.IndexMap a)
+ Agda.Utils.IndexMap: instance GHC.Show.Show a => GHC.Show.Show (Agda.Utils.IndexMap.IndexMap a)
+ Agda.Utils.IndexMap: invariant :: IndexMap a -> Bool
+ Agda.Utils.IndexMap: nil :: IndexMap a
+ Agda.Utils.IndexMap: snoc :: IndexMap a -> a -> IndexMap a
+ Agda.Utils.IndexMap: update :: Int -> a -> IndexMap a -> IndexMap a
+ Agda.Utils.IntMap: forWithKey_ :: forall v m. Applicative m => IntMap v -> (Int -> v -> m ()) -> m ()
+ Agda.Utils.Lens: (%%=!) :: MonadState o m => Lens' o i -> (i -> m (i, r)) -> m r
+ Agda.Utils.Lens: (%=!) :: MonadState s m => ASetter s s a b -> (a -> b) -> m ()
+ Agda.Utils.Lens: (%==!) :: MonadState s m => Lens' s a -> (a -> m a) -> m ()
+ Agda.Utils.Lens: (%~!) :: ASetter s t a b -> (a -> b) -> s -> t
+ Agda.Utils.Lens: (%~) :: ASetter s t a b -> (a -> b) -> s -> t
+ Agda.Utils.Lens: (&) :: a -> (a -> b) -> b
+ Agda.Utils.Lens: (.=!) :: MonadState s m => ASetter s s a b -> b -> m ()
+ Agda.Utils.Lens: (.~) :: ASetter s t a b -> b -> s -> t
+ Agda.Utils.Lens: _1 :: Field1 s t a b => Lens s t a b
+ Agda.Utils.Lens: _1' :: Field1 s t a b => Lens s t a b
+ Agda.Utils.Lens: _2 :: Field2 s t a b => Lens s t a b
+ Agda.Utils.Lens: _2' :: Field2 s t a b => Lens s t a b
+ Agda.Utils.Lens: _3 :: Field3 s t a b => Lens s t a b
+ Agda.Utils.Lens: _3' :: Field3 s t a b => Lens s t a b
+ Agda.Utils.Lens: _4 :: Field4 s t a b => Lens s t a b
+ Agda.Utils.Lens: _4' :: Field4 s t a b => Lens s t a b
+ Agda.Utils.Lens: _5 :: Field5 s t a b => Lens s t a b
+ Agda.Utils.Lens: _5' :: Field5 s t a b => Lens s t a b
+ Agda.Utils.Lens: class Field1 s t a b | s -> a, t -> b, s b -> t, t a -> s
+ Agda.Utils.Lens: class Field2 s t a b | s -> a, t -> b, s b -> t, t a -> s
+ Agda.Utils.Lens: class Field3 s t a b | s -> a, t -> b, s b -> t, t a -> s
+ Agda.Utils.Lens: class Field4 s t a b | s -> a, t -> b, s b -> t, t a -> s
+ Agda.Utils.Lens: class Field5 s t a b | s -> a, t -> b, s b -> t, t a -> s
+ Agda.Utils.Lens: infixr 4 %~!
+ Agda.Utils.Lens: instance Agda.Utils.Lens.Field1 (a, b) (a', b) a a'
+ Agda.Utils.Lens: instance Agda.Utils.Lens.Field1 (a, b, c) (a', b, c) a a'
+ Agda.Utils.Lens: instance Agda.Utils.Lens.Field1 (a, b, c, d) (a', b, c, d) a a'
+ Agda.Utils.Lens: instance Agda.Utils.Lens.Field1 (a, b, c, d, e) (a', b, c, d, e) a a'
+ Agda.Utils.Lens: instance Agda.Utils.Lens.Field2 (a, b) (a, b') b b'
+ Agda.Utils.Lens: instance Agda.Utils.Lens.Field2 (a, b, c) (a, b', c) b b'
+ Agda.Utils.Lens: instance Agda.Utils.Lens.Field2 (a, b, c, d) (a, b', c, d) b b'
+ Agda.Utils.Lens: instance Agda.Utils.Lens.Field2 (a, b, c, d, e) (a, b', c, d, e) b b'
+ Agda.Utils.Lens: instance Agda.Utils.Lens.Field3 (a, b, c) (a, b, c') c c'
+ Agda.Utils.Lens: instance Agda.Utils.Lens.Field3 (a, b, c, d) (a, b, c', d) c c'
+ Agda.Utils.Lens: instance Agda.Utils.Lens.Field3 (a, b, c, d, e) (a, b, c', d, e) c c'
+ Agda.Utils.Lens: instance Agda.Utils.Lens.Field4 (a, b, c, d) (a, b, c, d') d d'
+ Agda.Utils.Lens: instance Agda.Utils.Lens.Field4 (a, b, c, d, e) (a, b, c, d', e) d d'
+ Agda.Utils.Lens: instance Agda.Utils.Lens.Field5 (a, b, c, d, e) (a, b, c, d, e') e e'
+ Agda.Utils.Lens: over' :: ASetter s t a b -> (a -> b) -> s -> t
+ Agda.Utils.Lens: set' :: ASetter s t a b -> b -> s -> t
+ Agda.Utils.Lens: type ASetter s t a b = a -> Identity b -> s -> Identity t
+ Agda.Utils.Lens: type Getting r s a = a -> Const r a -> s -> Const r s
+ Agda.Utils.Lens: type Lens' s a = Lens s s a a
+ Agda.Utils.Lens: type Lens s t a b = forall (f :: Type -> Type). Functor f => a -> f b -> s -> f t
+ Agda.Utils.List: (++!) :: [a] -> [a] -> [a]
+ Agda.Utils.List: break' :: (a -> Bool) -> [a] -> ([a], [a])
+ Agda.Utils.List: breakJust :: (a -> Maybe b) -> [a] -> (Prefix a, (b, Suffix a))
+ Agda.Utils.List: catMaybe' :: [Maybe a] -> [a]
+ Agda.Utils.List: concat' :: [[a]] -> [a]
+ Agda.Utils.List: concatMap' :: (a -> [b]) -> [a] -> [b]
+ Agda.Utils.List: filter' :: (a -> Bool) -> [a] -> [a]
+ Agda.Utils.List: findWithIndex' :: (a -> Bool) -> [a] -> b -> (a -> Int -> b) -> b
+ Agda.Utils.List: infixr 5 ++!
+ Agda.Utils.List: initLast' :: [a] -> Maybe ([a], a)
+ Agda.Utils.List: initLast1' :: a -> [a] -> ([a], a)
+ Agda.Utils.List: map' :: (a -> b) -> [a] -> [b]
+ Agda.Utils.List: map'' :: (a -> b) -> [a] -> [b]
+ Agda.Utils.List: mapMaybe' :: (a -> Maybe b) -> [a] -> [b]
+ Agda.Utils.List: partition' :: (a -> Bool) -> [a] -> ([a], [a])
+ Agda.Utils.List: partitionEithers' :: [Either a b] -> ([a], [b])
+ Agda.Utils.List: replicate' :: Int -> a -> [a]
+ Agda.Utils.List: sortOnM :: (Monad m, Ord b) => (a -> m b) -> [a] -> m [a]
+ Agda.Utils.List: splitAt' :: Int -> [a] -> ([a], [a])
+ Agda.Utils.List: take' :: Int -> [a] -> [a]
+ Agda.Utils.List: takeExactly :: forall a n. Integral n => a -> n -> [a] -> [a]
+ Agda.Utils.List: takeWhile' :: (a -> Bool) -> [a] -> [a]
+ Agda.Utils.List: zip' :: [a] -> [b] -> [(a, b)]
+ Agda.Utils.List: zipWith'' :: (a -> b -> c) -> [a] -> [b] -> [c]
+ Agda.Utils.List: zipWithSameLen :: (a -> b -> c) -> [a] -> [b] -> Maybe [c]
+ Agda.Utils.List1: concat' :: [List1 a] -> [a]
+ Agda.Utils.List1: filter' :: (a -> Bool) -> List1 a -> [a]
+ Agda.Utils.List1: map' :: (a -> b) -> List1 a -> List1 b
+ Agda.Utils.List1: snoc1 :: List1 a -> a -> List1 a
+ Agda.Utils.List2: zip :: List2 a -> List2 b -> List2 (a, b)
+ Agda.Utils.List2: zipWith :: (a -> b -> c) -> List2 a -> List2 b -> List2 c
+ Agda.Utils.ListInf: (!!) :: Integral n => ListInf a -> n -> a
+ Agda.Utils.ListInf: append :: [a] -> ListInf a -> ListInf a
+ Agda.Utils.ListInf: cycle :: NonEmpty a -> Infinite a
+ Agda.Utils.ListInf: drop :: Integral n => n -> ListInf a -> ListInf a
+ Agda.Utils.ListInf: head :: Infinite a -> a
+ Agda.Utils.ListInf: infixr 5 :<
+ Agda.Utils.ListInf: iterate :: (a -> a) -> a -> Infinite a
+ Agda.Utils.ListInf: pad :: [a] -> a -> ListInf a
+ Agda.Utils.ListInf: pattern (:<) :: () => a -> Infinite a -> Infinite a
+ Agda.Utils.ListInf: prependList :: [a] -> Infinite a -> Infinite a
+ Agda.Utils.ListInf: repeat :: a -> Infinite a
+ Agda.Utils.ListInf: splitAt :: Integral n => n -> ListInf a -> ([a], ListInf a)
+ Agda.Utils.ListInf: tail :: Infinite a -> Infinite a
+ Agda.Utils.ListInf: take :: Integral n => n -> ListInf a -> [a]
+ Agda.Utils.ListInf: type ListInf = Infinite
+ Agda.Utils.ListInf: upFrom :: Enum n => n -> ListInf n
+ Agda.Utils.ListInf: updateAt :: Integral n => n -> (a -> a) -> ListInf a -> ListInf a
+ Agda.Utils.ListInf: zip :: Infinite a -> Infinite b -> Infinite (a, b)
+ Agda.Utils.ListInf: zipWith :: (a -> b -> c) -> Infinite a -> Infinite b -> Infinite c
+ Agda.Utils.ListT: instance Control.Monad.IO.Class.MonadIO m => Control.Monad.IO.Class.MonadIO (Agda.Utils.ListT.ListT m)
+ Agda.Utils.ListT: instance Control.Monad.Reader.Class.MonadReader r m => Control.Monad.Reader.Class.MonadReader r (Agda.Utils.ListT.ListT m)
+ Agda.Utils.ListT: instance Control.Monad.State.Class.MonadState s m => Control.Monad.State.Class.MonadState s (Agda.Utils.ListT.ListT m)
+ Agda.Utils.ListT: instance GHC.Base.Monad m => GHC.Base.Alternative (Agda.Utils.ListT.ListT m)
+ Agda.Utils.ListT: instance GHC.Base.Monad m => GHC.Base.Applicative (Agda.Utils.ListT.ListT m)
+ Agda.Utils.ListT: instance GHC.Base.Monad m => GHC.Base.Monad (Agda.Utils.ListT.ListT m)
+ Agda.Utils.ListT: instance GHC.Base.Monad m => GHC.Base.MonadPlus (Agda.Utils.ListT.ListT m)
+ Agda.Utils.Map: forGood_ :: forall k v m. Applicative m => Map k v -> (v -> m ()) -> m ()
+ Agda.Utils.Map: forWithKey_ :: forall k v m. Applicative m => Map k v -> (k -> v -> m ()) -> m ()
+ Agda.Utils.Map: insertWithGood :: forall k a c. Ord k => (c -> a -> a -> a) -> c -> k -> a -> Map k a -> Map k a
+ Agda.Utils.Map: isSingleMap :: Map k v -> Maybe (k, v)
+ Agda.Utils.Map: mapKeysMaybe :: Ord k => (k -> Maybe k) -> Map k a -> Map k a
+ Agda.Utils.Map: partitionKeys :: Ord k => Map k a -> Set k -> (Map k a, Map k a)
+ Agda.Utils.Map: partitionMap :: Ord k => Map k a -> Map k b -> (Map k a, Map k a)
+ Agda.Utils.Map1: mapKeysAndValuesMonotonic :: (k -> k) -> (a -> b) -> Map1 k a -> Map1 k b
+ Agda.Utils.Maybe: fromMaybeT :: Monad m => a -> MaybeT m a -> m a
+ Agda.Utils.Maybe: orEmpty :: Null a => Maybe a -> a
+ Agda.Utils.Maybe: predicateToMaybe :: (a -> Bool) -> a -> Maybe a
+ Agda.Utils.Maybe.Unboxable: Maybe# :: (# a | (# #) #) -> Maybe# a
+ Agda.Utils.Maybe.Unboxable: data Maybe# a
+ Agda.Utils.Maybe.Unboxable: pattern Just# :: a -> Maybe# a
+ Agda.Utils.Maybe.Unboxable: pattern Nothing# :: Maybe# a
+ Agda.Utils.Memo: memoUnsafeInt :: (Int -> a) -> Int -> a
+ Agda.Utils.MinimalArray.Lifted: Array :: Array a -> Array a
+ Agda.Utils.MinimalArray.Lifted: [unwrap] :: Array a -> Array a
+ Agda.Utils.MinimalArray.Lifted: fromGHCArray :: Array i e -> Array e
+ Agda.Utils.MinimalArray.Lifted: fromList :: [a] -> Array a
+ Agda.Utils.MinimalArray.Lifted: fromListN :: Int -> [a] -> Array a
+ Agda.Utils.MinimalArray.Lifted: index :: Array a -> Int -> a
+ Agda.Utils.MinimalArray.Lifted: instance Agda.Utils.Serialize.Serialize a => Agda.Utils.Serialize.Serialize (Agda.Utils.MinimalArray.Lifted.Array a)
+ Agda.Utils.MinimalArray.Lifted: instance Data.Foldable.Foldable Agda.Utils.MinimalArray.Lifted.Array
+ Agda.Utils.MinimalArray.Lifted: instance Data.Traversable.Traversable Agda.Utils.MinimalArray.Lifted.Array
+ Agda.Utils.MinimalArray.Lifted: instance GHC.Base.Functor Agda.Utils.MinimalArray.Lifted.Array
+ Agda.Utils.MinimalArray.Lifted: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.Utils.MinimalArray.Lifted.Array a)
+ Agda.Utils.MinimalArray.Lifted: instance GHC.IsList.IsList (Agda.Utils.MinimalArray.Lifted.Array a)
+ Agda.Utils.MinimalArray.Lifted: instance GHC.Show.Show a => GHC.Show.Show (Agda.Utils.MinimalArray.Lifted.Array a)
+ Agda.Utils.MinimalArray.Lifted: newtype Array a
+ Agda.Utils.MinimalArray.Lifted: size :: Array a -> Int
+ Agda.Utils.MinimalArray.Lifted: toList :: Array a -> [a]
+ Agda.Utils.MinimalArray.Lifted: traverseIO' :: (a -> IO b) -> Array a -> IO (Array b)
+ Agda.Utils.MinimalArray.Lifted: unsafeIndex :: Array a -> Int -> a
+ Agda.Utils.MinimalArray.MutableLifted: Array :: MutableArray s a -> Array s a
+ Agda.Utils.MinimalArray.MutableLifted: [unwrap] :: Array s a -> MutableArray s a
+ Agda.Utils.MinimalArray.MutableLifted: freeze :: PrimMonad m => Array (PrimState m) a -> m (Array a)
+ Agda.Utils.MinimalArray.MutableLifted: fromGHCArray :: IOArray i e -> IOArray e
+ Agda.Utils.MinimalArray.MutableLifted: new :: forall a m. PrimMonad m => Int -> a -> m (Array (PrimState m) a)
+ Agda.Utils.MinimalArray.MutableLifted: newtype Array s a
+ Agda.Utils.MinimalArray.MutableLifted: read :: PrimMonad m => Array (PrimState m) a -> Int -> m a
+ Agda.Utils.MinimalArray.MutableLifted: size :: Array s a -> Int
+ Agda.Utils.MinimalArray.MutableLifted: type IOArray a = Array RealWorld a
+ Agda.Utils.MinimalArray.MutableLifted: unsafeFreeze :: PrimMonad m => Array (PrimState m) a -> m (Array a)
+ Agda.Utils.MinimalArray.MutableLifted: unsafeRead :: PrimMonad m => Array (PrimState m) a -> Int -> m a
+ Agda.Utils.MinimalArray.MutableLifted: unsafeWrite :: PrimMonad m => Array (PrimState m) a -> Int -> a -> m ()
+ Agda.Utils.MinimalArray.MutableLifted: write :: PrimMonad m => Array (PrimState m) a -> Int -> a -> m ()
+ Agda.Utils.MinimalArray.MutablePrim: Array :: MutablePrimArray s a -> Array s a
+ Agda.Utils.MinimalArray.MutablePrim: [unwrap] :: Array s a -> MutablePrimArray s a
+ Agda.Utils.MinimalArray.MutablePrim: freeze :: (PrimMonad m, Prim a) => Array (PrimState m) a -> m (Array a)
+ Agda.Utils.MinimalArray.MutablePrim: new :: (PrimMonad m, Prim a) => Int -> m (Array (PrimState m) a)
+ Agda.Utils.MinimalArray.MutablePrim: newtype Array s a
+ Agda.Utils.MinimalArray.MutablePrim: read :: (PrimMonad m, Prim a) => Array (PrimState m) a -> Int -> m a
+ Agda.Utils.MinimalArray.MutablePrim: set :: (PrimMonad m, Prim a) => Array (PrimState m) a -> a -> m ()
+ Agda.Utils.MinimalArray.MutablePrim: size :: (PrimMonad m, Prim a) => Array (PrimState m) a -> m Int
+ Agda.Utils.MinimalArray.MutablePrim: type IOArray a = Array RealWorld a
+ Agda.Utils.MinimalArray.MutablePrim: unsafeFreeze :: PrimMonad m => Array (PrimState m) a -> m (Array a)
+ Agda.Utils.MinimalArray.MutablePrim: unsafeRead :: (PrimMonad m, Prim a) => Array (PrimState m) a -> Int -> m a
+ Agda.Utils.MinimalArray.MutablePrim: unsafeWrite :: (PrimMonad m, Prim a) => Array (PrimState m) a -> Int -> a -> m ()
+ Agda.Utils.MinimalArray.MutablePrim: write :: (PrimMonad m, Prim a) => Array (PrimState m) a -> Int -> a -> m ()
+ Agda.Utils.MinimalArray.Prim: Array :: PrimArray a -> Array a
+ Agda.Utils.MinimalArray.Prim: [unwrap] :: Array a -> PrimArray a
+ Agda.Utils.MinimalArray.Prim: foldl' :: Prim a => (b -> a -> b) -> b -> Array a -> b
+ Agda.Utils.MinimalArray.Prim: foldr' :: Prim a => (a -> b -> b) -> b -> Array a -> b
+ Agda.Utils.MinimalArray.Prim: fromList :: Prim a => [a] -> Array a
+ Agda.Utils.MinimalArray.Prim: fromListN :: Prim a => Int -> [a] -> Array a
+ Agda.Utils.MinimalArray.Prim: index :: Prim a => Array a -> Int -> a
+ Agda.Utils.MinimalArray.Prim: instance (GHC.Classes.Eq a, Data.Primitive.Types.Prim a) => GHC.Classes.Eq (Agda.Utils.MinimalArray.Prim.Array a)
+ Agda.Utils.MinimalArray.Prim: instance (GHC.Show.Show a, Data.Primitive.Types.Prim a) => GHC.Show.Show (Agda.Utils.MinimalArray.Prim.Array a)
+ Agda.Utils.MinimalArray.Prim: instance Data.Primitive.Types.Prim a => GHC.IsList.IsList (Agda.Utils.MinimalArray.Prim.Array a)
+ Agda.Utils.MinimalArray.Prim: map :: (Prim a, Prim b) => (Int -> a -> b) -> Array a -> Array b
+ Agda.Utils.MinimalArray.Prim: newtype Array a
+ Agda.Utils.MinimalArray.Prim: size :: Prim a => Array a -> Int
+ Agda.Utils.MinimalArray.Prim: toList :: Prim a => Array a -> [a]
+ Agda.Utils.MinimalArray.Prim: unsafeIndex :: Prim a => Array a -> Int -> a
+ Agda.Utils.Monad: catchExceptT :: Monad m => ExceptT e m a -> (e -> m a) -> m a
+ Agda.Utils.Monad: findM :: (Foldable f, Monad m) => (a -> m Bool) -> f a -> m (Maybe a)
+ Agda.Utils.Monad: forMGood :: (Monad m, ExpandCase (m [b])) => [a] -> (a -> m b) -> m [b]
+ Agda.Utils.Monad: forMGood_ :: (Monad m, ExpandCase (m ())) => [a] -> (a -> m ()) -> m ()
+ Agda.Utils.Monad: mapMGood :: (Monad m, ExpandCase (m [b])) => (a -> m b) -> [a] -> m [b]
+ Agda.Utils.Monad: mapMGood_ :: (Monad m, ExpandCase (m ())) => (a -> m ()) -> [a] -> m ()
+ Agda.Utils.Monad: rangeM_ :: (Monad m, ExpandCase (m ())) => Int -> Int -> (Int -> m ()) -> m ()
+ Agda.Utils.Monoid: appFwd :: Fwd a -> a -> a
+ Agda.Utils.Monoid: data Fwd a
+ Agda.Utils.Monoid: instance GHC.Base.Monoid (Agda.Utils.Monoid.Fwd a)
+ Agda.Utils.Monoid: instance GHC.Base.Semigroup (Agda.Utils.Monoid.Fwd a)
+ Agda.Utils.Monoid: pattern Fwd :: (a -> a) -> Fwd a
+ Agda.Utils.Null: instance Agda.Utils.Null.Null Agda.Utils.VarSet.VarSet
+ Agda.Utils.Null: instance Agda.Utils.Null.Null GHC.Word.Word32
+ Agda.Utils.Null: instance Agda.Utils.Null.Null GHC.Word.Word64
+ Agda.Utils.Null: instance Agda.Utils.Null.Null a => Agda.Utils.Null.Null (Data.Either.Either e a)
+ Agda.Utils.Permutation: deleteP :: Int -> Permutation -> Permutation
+ Agda.Utils.Permutation: lookupP :: Permutation -> Int -> Maybe Int
+ Agda.Utils.Permutation: lookupRP :: Permutation -> Int -> Maybe Int
+ Agda.Utils.Range: Range :: !Int -> !Int -> Range
+ Agda.Utils.Range: Ranges :: [Range] -> Ranges
+ Agda.Utils.Range: [from] :: Range -> !Int
+ Agda.Utils.Range: [to] :: Range -> !Int
+ Agda.Utils.Range: data Range
+ Agda.Utils.Range: empty :: Null a => a
+ Agda.Utils.Range: instance Agda.Utils.Null.Null Agda.Utils.Range.Range
+ Agda.Utils.Range: instance Control.DeepSeq.NFData Agda.Utils.Range.Range
+ Agda.Utils.Range: instance Control.DeepSeq.NFData Agda.Utils.Range.Ranges
+ Agda.Utils.Range: instance GHC.Classes.Eq Agda.Utils.Range.Range
+ Agda.Utils.Range: instance GHC.Classes.Eq Agda.Utils.Range.Ranges
+ Agda.Utils.Range: instance GHC.Classes.Ord Agda.Utils.Range.Range
+ Agda.Utils.Range: instance GHC.Show.Show Agda.Utils.Range.Range
+ Agda.Utils.Range: instance GHC.Show.Show Agda.Utils.Range.Ranges
+ Agda.Utils.Range: minus :: Ranges -> Ranges -> Ranges
+ Agda.Utils.Range: newtype Ranges
+ Agda.Utils.Range: overlapping :: Range -> Range -> Bool
+ Agda.Utils.Range: overlappings :: Ranges -> Ranges -> Bool
+ Agda.Utils.Range: rangeInvariant :: Range -> Bool
+ Agda.Utils.Range: rangeToPositions :: Range -> [Int]
+ Agda.Utils.Range: rangesInvariant :: Ranges -> Bool
+ Agda.Utils.Range: rangesToPositions :: Ranges -> [Int]
+ Agda.Utils.RangeMap: (:!:) :: !Int -> !a -> PairInt a
+ Agda.Utils.RangeMap: data PairInt a
+ Agda.Utils.Serialize: Get :: (Addr# -> Addr# -> RW -> (# Addr#, RW, a #)) -> Get a
+ Agda.Utils.Serialize: Put :: (Addr# -> RW -> (# Addr#, RW #)) -> Put
+ Agda.Utils.Serialize: [unGet] :: Get a -> Addr# -> Addr# -> RW -> (# Addr#, RW, a #)
+ Agda.Utils.Serialize: [unPut] :: Put -> Addr# -> RW -> (# Addr#, RW #)
+ Agda.Utils.Serialize: class Serialize a
+ Agda.Utils.Serialize: deserialize :: Serialize a => ByteString -> IO a
+ Agda.Utils.Serialize: deserializePure :: Serialize a => ByteString -> a
+ Agda.Utils.Serialize: ensure :: Int -> (Addr# -> Get a) -> Get a
+ Agda.Utils.Serialize: get :: Serialize a => Get a
+ Agda.Utils.Serialize: getByteArray# :: Int# -> (ByteArray# -> Get a) -> Get a
+ Agda.Utils.Serialize: instance (Agda.Utils.Serialize.Serialize a, Agda.Utils.Serialize.Serialize b) => Agda.Utils.Serialize.Serialize (a, b)
+ Agda.Utils.Serialize: instance (Agda.Utils.Serialize.Serialize a, Agda.Utils.Serialize.Serialize b, Agda.Utils.Serialize.Serialize c) => Agda.Utils.Serialize.Serialize (a, b, c)
+ Agda.Utils.Serialize: instance (Agda.Utils.Serialize.Serialize a, Agda.Utils.Serialize.Serialize b, Agda.Utils.Serialize.Serialize c, Agda.Utils.Serialize.Serialize d) => Agda.Utils.Serialize.Serialize (a, b, c, d)
+ Agda.Utils.Serialize: instance (Agda.Utils.Serialize.Serialize a, Agda.Utils.Serialize.Serialize b, Agda.Utils.Serialize.Serialize c, Agda.Utils.Serialize.Serialize d, Agda.Utils.Serialize.Serialize e) => Agda.Utils.Serialize.Serialize (a, b, c, d, e)
+ Agda.Utils.Serialize: instance (Agda.Utils.Serialize.Serialize a, Agda.Utils.Serialize.Serialize b, Agda.Utils.Serialize.Serialize c, Agda.Utils.Serialize.Serialize d, Agda.Utils.Serialize.Serialize e, Agda.Utils.Serialize.Serialize f) => Agda.Utils.Serialize.Serialize (a, b, c, d, e, f)
+ Agda.Utils.Serialize: instance (Agda.Utils.Serialize.Serialize a, Agda.Utils.Serialize.Serialize b, Agda.Utils.Serialize.Serialize c, Agda.Utils.Serialize.Serialize d, Agda.Utils.Serialize.Serialize e, Agda.Utils.Serialize.Serialize f, Agda.Utils.Serialize.Serialize g) => Agda.Utils.Serialize.Serialize (a, b, c, d, e, f, g)
+ Agda.Utils.Serialize: instance (Agda.Utils.Serialize.Serialize a, Agda.Utils.Serialize.Serialize b, Agda.Utils.Serialize.Serialize c, Agda.Utils.Serialize.Serialize d, Agda.Utils.Serialize.Serialize e, Agda.Utils.Serialize.Serialize f, Agda.Utils.Serialize.Serialize g, Agda.Utils.Serialize.Serialize h) => Agda.Utils.Serialize.Serialize (a, b, c, d, e, f, g, h)
+ Agda.Utils.Serialize: instance Agda.Utils.Serialize.Serialize ()
+ Agda.Utils.Serialize: instance Agda.Utils.Serialize.Serialize Data.Text.Internal.Lazy.Text
+ Agda.Utils.Serialize: instance Agda.Utils.Serialize.Serialize Data.Text.Internal.Text
+ Agda.Utils.Serialize: instance Agda.Utils.Serialize.Serialize GHC.Num.Integer.Integer
+ Agda.Utils.Serialize: instance Agda.Utils.Serialize.Serialize GHC.Types.Char
+ Agda.Utils.Serialize: instance Agda.Utils.Serialize.Serialize GHC.Types.Double
+ Agda.Utils.Serialize: instance Agda.Utils.Serialize.Serialize GHC.Types.Int
+ Agda.Utils.Serialize: instance Agda.Utils.Serialize.Serialize GHC.Types.Word
+ Agda.Utils.Serialize: instance Agda.Utils.Serialize.Serialize GHC.Word.Word16
+ Agda.Utils.Serialize: instance Agda.Utils.Serialize.Serialize GHC.Word.Word32
+ Agda.Utils.Serialize: instance Agda.Utils.Serialize.Serialize GHC.Word.Word64
+ Agda.Utils.Serialize: instance Agda.Utils.Serialize.Serialize GHC.Word.Word8
+ Agda.Utils.Serialize: instance Agda.Utils.Serialize.Serialize a => Agda.Utils.Serialize.Serialize [a]
+ Agda.Utils.Serialize: instance GHC.Base.Applicative Agda.Utils.Serialize.Get
+ Agda.Utils.Serialize: instance GHC.Base.Functor Agda.Utils.Serialize.Get
+ Agda.Utils.Serialize: instance GHC.Base.Monad Agda.Utils.Serialize.Get
+ Agda.Utils.Serialize: instance GHC.Base.Monoid Agda.Utils.Serialize.Put
+ Agda.Utils.Serialize: instance GHC.Base.Semigroup Agda.Utils.Serialize.Put
+ Agda.Utils.Serialize: newtype Get a
+ Agda.Utils.Serialize: newtype Put
+ Agda.Utils.Serialize: put :: Serialize a => a -> Put
+ Agda.Utils.Serialize: putByteArray# :: ByteArray# -> Int# -> Int# -> Put
+ Agda.Utils.Serialize: serialize :: Serialize a => a -> IO ByteString
+ Agda.Utils.Serialize: serializePure :: Serialize a => a -> ByteString
+ Agda.Utils.Serialize: size :: Serialize a => a -> Int
+ Agda.Utils.Set: lookupKey :: Ord a => a -> Set a -> Maybe a
+ Agda.Utils.Singleton: instance Agda.Utils.Singleton.Singleton (k, a) (Data.Map.NonEmpty.Lazy.Internal.NEMap k a)
+ Agda.Utils.Singleton: instance Agda.Utils.Singleton.Singleton GHC.Types.Int Agda.Utils.VarSet.VarSet
+ Agda.Utils.Singleton: instance Data.Hashable.Class.Hashable k => Agda.Utils.Singleton.Collection (k, a) (Data.HashMap.Internal.HashMap k a)
+ Agda.Utils.Singleton: instance Data.Hashable.Class.Hashable k => Agda.Utils.Singleton.Collection k (Data.HashSet.Internal.HashSet k)
+ Agda.Utils.Size: instance Agda.Utils.Size.Sized (Agda.Utils.Map1.Map1 k a)
+ Agda.Utils.Size: instance Agda.Utils.Size.Sized (Agda.Utils.Set1.Set1 a)
+ Agda.Utils.SmallSet: instance Agda.Utils.Null.Null (Agda.Utils.SmallSet.SmallSet a)
+ Agda.Utils.SmallSet: instance GHC.Base.Monoid (Agda.Utils.SmallSet.SmallSet a)
+ Agda.Utils.SmallSet: instance GHC.Base.Semigroup (Agda.Utils.SmallSet.SmallSet a)
+ Agda.Utils.StrictEndo: Endo :: (a -> a) -> Endo a
+ Agda.Utils.StrictEndo: [appEndo] :: Endo a -> a -> a
+ Agda.Utils.StrictEndo: instance Agda.Utils.ExpandCase.ExpandCase (Agda.Utils.StrictEndo.Endo a)
+ Agda.Utils.StrictEndo: instance GHC.Base.Monoid (Agda.Utils.StrictEndo.Endo a)
+ Agda.Utils.StrictEndo: instance GHC.Base.Semigroup (Agda.Utils.StrictEndo.Endo a)
+ Agda.Utils.StrictEndo: newtype Endo a
+ Agda.Utils.StrictFlipEndo: Endo :: (a -> a) -> Endo a
+ Agda.Utils.StrictFlipEndo: [appEndo] :: Endo a -> a -> a
+ Agda.Utils.StrictFlipEndo: instance Agda.Utils.ExpandCase.ExpandCase (Agda.Utils.StrictFlipEndo.Endo a)
+ Agda.Utils.StrictFlipEndo: instance GHC.Base.Monoid (Agda.Utils.StrictFlipEndo.Endo a)
+ Agda.Utils.StrictFlipEndo: instance GHC.Base.Semigroup (Agda.Utils.StrictFlipEndo.Endo a)
+ Agda.Utils.StrictFlipEndo: newtype Endo a
+ Agda.Utils.StrictReader: Reader :: (r -> a) -> Reader r a
+ Agda.Utils.StrictReader: ReaderT :: (r -> m a) -> ReaderT r (m :: Type -> Type) a
+ Agda.Utils.StrictReader: [runReaderT] :: ReaderT r (m :: Type -> Type) a -> r -> m a
+ Agda.Utils.StrictReader: [runReader] :: Reader r a -> r -> a
+ Agda.Utils.StrictReader: ask :: MonadReader r m => m r
+ Agda.Utils.StrictReader: asks :: MonadReader r m => (r -> a) -> m a
+ Agda.Utils.StrictReader: class Monad m => MonadReader r (m :: Type -> Type) | m -> r
+ Agda.Utils.StrictReader: instance (GHC.Base.Monoid a, GHC.Base.Monad m) => GHC.Base.Monoid (Agda.Utils.StrictReader.ReaderT r m a)
+ Agda.Utils.StrictReader: instance (GHC.Base.Semigroup a, GHC.Base.Monad m) => GHC.Base.Semigroup (Agda.Utils.StrictReader.ReaderT r m a)
+ Agda.Utils.StrictReader: instance Agda.Utils.ExpandCase.ExpandCase (m a) => Agda.Utils.ExpandCase.ExpandCase (Agda.Utils.StrictReader.ReaderT r m a)
+ Agda.Utils.StrictReader: instance Agda.Utils.ExpandCase.ExpandCase a => Agda.Utils.ExpandCase.ExpandCase (Agda.Utils.StrictReader.Reader r a)
+ Agda.Utils.StrictReader: instance Control.Monad.Error.Class.MonadError e m => Control.Monad.Error.Class.MonadError e (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.Utils.StrictReader: instance Control.Monad.Fail.MonadFail m => Control.Monad.Fail.MonadFail (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.Utils.StrictReader: instance Control.Monad.IO.Class.MonadIO m => Control.Monad.IO.Class.MonadIO (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.Utils.StrictReader: instance Control.Monad.Reader.Class.MonadReader r (Agda.Utils.StrictReader.Reader r)
+ Agda.Utils.StrictReader: instance Control.Monad.State.Class.MonadState s m => Control.Monad.State.Class.MonadState s (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.Utils.StrictReader: instance Control.Monad.Trans.Class.MonadTrans (Agda.Utils.StrictReader.ReaderT r)
+ Agda.Utils.StrictReader: instance Control.Monad.Trans.Control.MonadTransControl (Agda.Utils.StrictReader.ReaderT r)
+ Agda.Utils.StrictReader: instance Control.Monad.Writer.Class.MonadWriter w m => Control.Monad.Writer.Class.MonadWriter w (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.Utils.StrictReader: instance GHC.Base.Applicative (Agda.Utils.StrictReader.Reader r)
+ Agda.Utils.StrictReader: instance GHC.Base.Functor (Agda.Utils.StrictReader.Reader r)
+ Agda.Utils.StrictReader: instance GHC.Base.Monad (Agda.Utils.StrictReader.Reader r)
+ Agda.Utils.StrictReader: instance GHC.Base.Monad m => Control.Monad.Reader.Class.MonadReader r (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.Utils.StrictReader: instance GHC.Base.Monad m => GHC.Base.Applicative (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.Utils.StrictReader: instance GHC.Base.Monad m => GHC.Base.Functor (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.Utils.StrictReader: instance GHC.Base.Monad m => GHC.Base.Monad (Agda.Utils.StrictReader.ReaderT r m)
+ Agda.Utils.StrictReader: instance GHC.Base.Monoid a => GHC.Base.Monoid (Agda.Utils.StrictReader.Reader r a)
+ Agda.Utils.StrictReader: instance GHC.Base.Semigroup a => GHC.Base.Semigroup (Agda.Utils.StrictReader.Reader r a)
+ Agda.Utils.StrictReader: local :: MonadReader r m => (r -> r) -> m a -> m a
+ Agda.Utils.StrictReader: newtype Reader r a
+ Agda.Utils.StrictReader: newtype ReaderT r (m :: Type -> Type) a
+ Agda.Utils.StrictReader: reader :: MonadReader r m => (r -> a) -> m a
+ Agda.Utils.StrictState: State :: (s -> (# a, s #)) -> State s a
+ Agda.Utils.StrictState: StateT :: (s -> m (Pair a s)) -> StateT s (m :: Type -> Type) a
+ Agda.Utils.StrictState: [runState#] :: State s a -> s -> (# a, s #)
+ Agda.Utils.StrictState: [runStateT#] :: StateT s (m :: Type -> Type) a -> s -> m (Pair a s)
+ Agda.Utils.StrictState: class Monad m => MonadState s (m :: Type -> Type) | m -> s
+ Agda.Utils.StrictState: evalState :: State s a -> s -> a
+ Agda.Utils.StrictState: evalStateT :: Monad m => StateT s m a -> s -> m a
+ Agda.Utils.StrictState: execState :: State s a -> s -> s
+ Agda.Utils.StrictState: execStateT :: Monad m => StateT s m a -> s -> m s
+ Agda.Utils.StrictState: get :: MonadState s m => m s
+ Agda.Utils.StrictState: gets :: MonadState s m => (s -> a) -> m a
+ Agda.Utils.StrictState: instance Agda.Utils.ExpandCase.ExpandCase (m (Data.Strict.Tuple.Pair a s)) => Agda.Utils.ExpandCase.ExpandCase (Agda.Utils.StrictState.StateT s m a)
+ Agda.Utils.StrictState: instance Control.Monad.Error.Class.MonadError e m => Control.Monad.Error.Class.MonadError e (Agda.Utils.StrictState.StateT s m)
+ Agda.Utils.StrictState: instance Control.Monad.Fail.MonadFail m => Control.Monad.Fail.MonadFail (Agda.Utils.StrictState.StateT s m)
+ Agda.Utils.StrictState: instance Control.Monad.IO.Class.MonadIO m => Control.Monad.IO.Class.MonadIO (Agda.Utils.StrictState.StateT s m)
+ Agda.Utils.StrictState: instance Control.Monad.Reader.Class.MonadReader r m => Control.Monad.Reader.Class.MonadReader r (Agda.Utils.StrictState.StateT s m)
+ Agda.Utils.StrictState: instance Control.Monad.State.Class.MonadState s (Agda.Utils.StrictState.State s)
+ Agda.Utils.StrictState: instance Control.Monad.Trans.Class.MonadTrans (Agda.Utils.StrictState.StateT s)
+ Agda.Utils.StrictState: instance Control.Monad.Trans.Control.MonadTransControl (Agda.Utils.StrictState.StateT s)
+ Agda.Utils.StrictState: instance Control.Monad.Writer.Class.MonadWriter w m => Control.Monad.Writer.Class.MonadWriter w (Agda.Utils.StrictState.StateT s m)
+ Agda.Utils.StrictState: instance GHC.Base.Applicative (Agda.Utils.StrictState.State s)
+ Agda.Utils.StrictState: instance GHC.Base.Functor (Agda.Utils.StrictState.State s)
+ Agda.Utils.StrictState: instance GHC.Base.Functor m => GHC.Base.Functor (Agda.Utils.StrictState.StateT s m)
+ Agda.Utils.StrictState: instance GHC.Base.Monad (Agda.Utils.StrictState.State s)
+ Agda.Utils.StrictState: instance GHC.Base.Monad m => Control.Monad.State.Class.MonadState s (Agda.Utils.StrictState.StateT s m)
+ Agda.Utils.StrictState: instance GHC.Base.Monad m => GHC.Base.Applicative (Agda.Utils.StrictState.StateT s m)
+ Agda.Utils.StrictState: instance GHC.Base.Monad m => GHC.Base.Monad (Agda.Utils.StrictState.StateT s m)
+ Agda.Utils.StrictState: modify :: MonadState s m => (s -> s) -> m ()
+ Agda.Utils.StrictState: newtype State s a
+ Agda.Utils.StrictState: newtype StateT s (m :: Type -> Type) a
+ Agda.Utils.StrictState: put :: MonadState s m => s -> m ()
+ Agda.Utils.StrictState: runState :: State s a -> s -> (a, s)
+ Agda.Utils.StrictState: runStateT :: Monad m => StateT s m a -> s -> m (a, s)
+ Agda.Utils.StrictState: state :: MonadState s m => (s -> (a, s)) -> m a
+ Agda.Utils.StrictState2: State :: (s -> t -> (# a, s, t #)) -> State s t a
+ Agda.Utils.StrictState2: [runState#] :: State s t a -> s -> t -> (# a, s, t #)
+ Agda.Utils.StrictState2: evalState :: State s t a -> (s, t) -> a
+ Agda.Utils.StrictState2: execState :: State s t a -> (s, t) -> (s, t)
+ Agda.Utils.StrictState2: get :: State s t (s, t)
+ Agda.Utils.StrictState2: get1 :: State s t s
+ Agda.Utils.StrictState2: get2 :: State s t t
+ Agda.Utils.StrictState2: gets :: ((s, t) -> a) -> State s t a
+ Agda.Utils.StrictState2: instance GHC.Base.Applicative (Agda.Utils.StrictState2.State s t)
+ Agda.Utils.StrictState2: instance GHC.Base.Functor (Agda.Utils.StrictState2.State s t)
+ Agda.Utils.StrictState2: instance GHC.Base.Monad (Agda.Utils.StrictState2.State s t)
+ Agda.Utils.StrictState2: modify :: ((s, t) -> (s, t)) -> State s t ()
+ Agda.Utils.StrictState2: modify1 :: (s -> s) -> State s t ()
+ Agda.Utils.StrictState2: modify2 :: (t -> t) -> State s t ()
+ Agda.Utils.StrictState2: newtype State s t a
+ Agda.Utils.StrictState2: put :: s -> t -> State s t ()
+ Agda.Utils.StrictState2: put1 :: s -> State s t ()
+ Agda.Utils.StrictState2: put2 :: t -> State s t ()
+ Agda.Utils.StrictState2: runState :: State s t a -> (s, t) -> (a, (s, t))
+ Agda.Utils.StrictWriter: Writer :: State w a -> Writer w a
+ Agda.Utils.StrictWriter: WriterT :: StateT w m a -> WriterT w (m :: Type -> Type) a
+ Agda.Utils.StrictWriter: [unWriterT] :: WriterT w (m :: Type -> Type) a -> StateT w m a
+ Agda.Utils.StrictWriter: [unWriter] :: Writer w a -> State w a
+ Agda.Utils.StrictWriter: censor :: MonadWriter w m => (w -> w) -> m a -> m a
+ Agda.Utils.StrictWriter: class (Monoid w, Monad m) => MonadWriter w (m :: Type -> Type) | m -> w
+ Agda.Utils.StrictWriter: execWriter :: Monoid w => Writer w a -> w
+ Agda.Utils.StrictWriter: execWriterT :: (Monoid w, Monad m) => WriterT w m a -> m w
+ Agda.Utils.StrictWriter: instance (GHC.Base.Monad m, Control.Monad.Error.Class.MonadError e (Agda.Utils.StrictState.StateT w m)) => Control.Monad.Error.Class.MonadError e (Agda.Utils.StrictWriter.WriterT w m)
+ Agda.Utils.StrictWriter: instance (GHC.Base.Monad m, Control.Monad.Reader.Class.MonadReader r (Agda.Utils.StrictState.StateT w m)) => Control.Monad.Reader.Class.MonadReader r (Agda.Utils.StrictWriter.WriterT w m)
+ Agda.Utils.StrictWriter: instance (GHC.Base.Monad m, Control.Monad.State.Class.MonadState s (Agda.Utils.StrictState.StateT w m)) => Control.Monad.State.Class.MonadState s (Agda.Utils.StrictWriter.WriterT w m)
+ Agda.Utils.StrictWriter: instance (GHC.Base.Monoid w, GHC.Base.Monad m) => Control.Monad.Writer.Class.MonadWriter w (Agda.Utils.StrictWriter.WriterT w m)
+ Agda.Utils.StrictWriter: instance Agda.Utils.ExpandCase.ExpandCase (Agda.Utils.StrictState.State w a) => Agda.Utils.ExpandCase.ExpandCase (Agda.Utils.StrictWriter.Writer w a)
+ Agda.Utils.StrictWriter: instance Agda.Utils.ExpandCase.ExpandCase (m (Data.Strict.Tuple.Pair a w)) => Agda.Utils.ExpandCase.ExpandCase (Agda.Utils.StrictWriter.WriterT w m a)
+ Agda.Utils.StrictWriter: instance Control.Monad.IO.Class.MonadIO m => Control.Monad.IO.Class.MonadIO (Agda.Utils.StrictWriter.WriterT w m)
+ Agda.Utils.StrictWriter: instance Control.Monad.Trans.Class.MonadTrans (Agda.Utils.StrictWriter.WriterT w)
+ Agda.Utils.StrictWriter: instance Control.Monad.Trans.Control.MonadTransControl (Agda.Utils.StrictWriter.WriterT w)
+ Agda.Utils.StrictWriter: instance GHC.Base.Applicative (Agda.Utils.StrictWriter.Writer w)
+ Agda.Utils.StrictWriter: instance GHC.Base.Functor (Agda.Utils.StrictWriter.Writer w)
+ Agda.Utils.StrictWriter: instance GHC.Base.Functor m => GHC.Base.Functor (Agda.Utils.StrictWriter.WriterT w m)
+ Agda.Utils.StrictWriter: instance GHC.Base.Monad (Agda.Utils.StrictWriter.Writer w)
+ Agda.Utils.StrictWriter: instance GHC.Base.Monad m => GHC.Base.Applicative (Agda.Utils.StrictWriter.WriterT w m)
+ Agda.Utils.StrictWriter: instance GHC.Base.Monad m => GHC.Base.Monad (Agda.Utils.StrictWriter.WriterT w m)
+ Agda.Utils.StrictWriter: instance GHC.Base.Monoid w => Control.Monad.Writer.Class.MonadWriter w (Agda.Utils.StrictWriter.Writer w)
+ Agda.Utils.StrictWriter: listen :: MonadWriter w m => m a -> m (a, w)
+ Agda.Utils.StrictWriter: newtype Writer w a
+ Agda.Utils.StrictWriter: newtype WriterT w (m :: Type -> Type) a
+ Agda.Utils.StrictWriter: pass :: MonadWriter w m => m (a, w -> w) -> m a
+ Agda.Utils.StrictWriter: runWriter :: Monoid w => Writer w a -> (a, w)
+ Agda.Utils.StrictWriter: runWriterT :: (Monoid w, Monad m) => WriterT w m a -> m (a, w)
+ Agda.Utils.StrictWriter: tell :: MonadWriter w m => w -> m ()
+ Agda.Utils.StrictWriter: writer :: MonadWriter w m => (a, w) -> m a
+ Agda.Utils.Three: mapEither3 :: (a -> Either3 b c d) -> [a] -> ([b], [c], [d])
+ Agda.Utils.Three: mkEither3 :: (Three, a) -> Either3 a a a
+ Agda.Utils.Trie: fromList :: Ord k => [([k], v)] -> Trie k v
+ Agda.Utils.Trie: prefixBy :: [k] -> Trie k v -> Trie k v
+ Agda.Utils.Tuple: (&&&) :: Arrow a => a b c -> a b c' -> a b (c, c')
+ Agda.Utils.Tuple: (***) :: Arrow a => a b c -> a b' c' -> a (b, b') (c, c')
+ Agda.Utils.Tuple: (//) :: a -> b -> (a, b)
+ Agda.Utils.Tuple: first :: Bifunctor p => (a -> b) -> p a c -> p b c
+ Agda.Utils.Tuple: firstM :: Functor m => (a -> m c) -> (a, b) -> m (c, b)
+ Agda.Utils.Tuple: infixr 3 &&&
+ Agda.Utils.Tuple: infixr 4 //
+ Agda.Utils.Tuple: second :: Bifunctor p => (b -> c) -> p a b -> p a c
+ Agda.Utils.Tuple: secondM :: Functor m => (b -> m d) -> (a, b) -> m (a, d)
+ Agda.Utils.Tuple.Strict: (&!&) :: (a -> b) -> (a -> c) -> a -> Pair b c
+ Agda.Utils.Tuple.Strict: infixr 3 &!&
+ Agda.Utils.TypeLevel: Suc :: Nat -> Nat
+ Agda.Utils.TypeLevel: Zero :: Nat
+ Agda.Utils.TypeLevel: data Nat
+ Agda.Utils.TypeLevel: type IsBase t = IsZero Arity t
+ Agda.Utils.TypeLevel: type Not (b :: Bool) = If b 'False 'True
+ Agda.Utils.VarSet: (\\) :: VarSet -> VarSet -> VarSet
+ Agda.Utils.VarSet: VB# :: ByteArray# -> VarSet
+ Agda.Utils.VarSet: VS# :: Word# -> VarSet
+ Agda.Utils.VarSet: complement :: Int -> VarSet -> VarSet
+ Agda.Utils.VarSet: data VarSet
+ Agda.Utils.VarSet: filterGT :: Int -> VarSet -> VarSet
+ Agda.Utils.VarSet: filterLE :: Int -> VarSet -> VarSet
+ Agda.Utils.VarSet: filterLT :: Int -> VarSet -> VarSet
+ Agda.Utils.VarSet: foldl :: (a -> Int -> a) -> a -> VarSet -> a
+ Agda.Utils.VarSet: foldl' :: (Int -> a -> a) -> a -> VarSet -> a
+ Agda.Utils.VarSet: foldr :: (Int -> a -> a) -> a -> VarSet -> a
+ Agda.Utils.VarSet: foldr' :: (Int -> a -> a) -> a -> VarSet -> a
+ Agda.Utils.VarSet: fromDescList :: [Int] -> VarSet
+ Agda.Utils.VarSet: full :: Int -> VarSet
+ Agda.Utils.VarSet: inRange :: Int -> Int -> VarSet -> Bool
+ Agda.Utils.VarSet: inserts :: [Int] -> VarSet -> VarSet
+ Agda.Utils.VarSet: insertsDesc :: [Int] -> VarSet -> VarSet
+ Agda.Utils.VarSet: instance Agda.Utils.Serialize.Serialize Agda.Utils.VarSet.VarSet
+ Agda.Utils.VarSet: instance Control.DeepSeq.NFData Agda.Utils.VarSet.VarSet
+ Agda.Utils.VarSet: instance Data.Hashable.Class.Hashable Agda.Utils.VarSet.VarSet
+ Agda.Utils.VarSet: instance GHC.Base.Monoid Agda.Utils.VarSet.VarSet
+ Agda.Utils.VarSet: instance GHC.Base.Semigroup Agda.Utils.VarSet.VarSet
+ Agda.Utils.VarSet: instance GHC.Classes.Eq Agda.Utils.VarSet.VarSet
+ Agda.Utils.VarSet: instance GHC.Classes.Ord Agda.Utils.VarSet.VarSet
+ Agda.Utils.VarSet: instance GHC.Show.Show Agda.Utils.VarSet.VarSet
+ Agda.Utils.VarSet: lookupMax :: VarSet -> Maybe Int
+ Agda.Utils.VarSet: lookupMin :: VarSet -> Maybe Int
+ Agda.Utils.VarSet: maxView :: VarSet -> Maybe (Int, VarSet)
+ Agda.Utils.VarSet: minView :: VarSet -> Maybe (Int, VarSet)
+ Agda.Utils.VarSet: range :: Int -> Int -> VarSet
+ Agda.Utils.VarSet: size :: VarSet -> Int
+ Agda.Utils.VarSet: split :: Int -> VarSet -> (VarSet, VarSet)
+ Agda.Utils.VarSet: strengthen :: Int -> VarSet -> VarSet
+ Agda.Utils.VarSet: weaken :: Int -> VarSet -> VarSet
+ Agda.Utils.WithDefault: not' :: forall (b :: Bool). WithDefault b -> WithDefault (Not b)
+ Agda.Utils.Word: andNot# :: Word# -> Word# -> Word#
+ Agda.Utils.Word: disjointWord# :: Word# -> Word# -> Int#
+ Agda.Utils.Word: highestBitWord# :: Word# -> Word#
+ Agda.Utils.Word: lowestBitWord# :: Word# -> Word#
+ Agda.Utils.Word: packW64 :: Word32 -> Word32 -> Word64
+ Agda.Utils.Word: splitW64 :: Word64 -> (Word32, Word32)
+ Agda.Utils.Word: uncheckedBitWord# :: Int# -> Word#
+ Agda.Utils.Word: uncheckedClearBitWord# :: Word# -> Int# -> Word#
+ Agda.Utils.Word: uncheckedSetBitWord# :: Word# -> Int# -> Word#
+ Agda.Utils.Word: uncheckedTestBitWord# :: Word# -> Int# -> Int#
+ Agda.Utils.Word: uncheckedWordOnes# :: Int# -> Word#
+ Agda.Utils.Word: wordFoldlBits# :: (a -> Int -> a) -> a -> Word# -> a
+ Agda.Utils.Word: wordFoldlBitsOffset# :: Int# -> (a -> Int -> a) -> a -> Word# -> a
+ Agda.Utils.Word: wordFoldlBitsOffsetStrict# :: Int# -> (a -> Int -> a) -> a -> Word# -> a
+ Agda.Utils.Word: wordFoldlBitsStrict# :: (a -> Int -> a) -> a -> Word# -> a
+ Agda.Utils.Word: wordFoldrBits# :: (Int -> a -> a) -> a -> Word# -> a
+ Agda.Utils.Word: wordFoldrBitsOffset# :: Int# -> (Int -> a -> a) -> a -> Word# -> a
+ Agda.Utils.Word: wordFoldrBitsOffsetStrict# :: Int# -> (Int -> a -> a) -> a -> Word# -> a
+ Agda.Utils.Word: wordFoldrBitsStrict# :: (Int -> a -> a) -> a -> Word# -> a
+ Agda.Utils.Zip: class Zip (f :: Type -> Type) (g :: Type -> Type) (h :: Type -> Type) | f g -> h
+ Agda.Utils.Zip: instance Agda.Utils.Zip.Zip Agda.Utils.List1.List1 Agda.Utils.List1.List1 Agda.Utils.List1.List1
+ Agda.Utils.Zip: instance Agda.Utils.Zip.Zip Agda.Utils.List1.List1 Agda.Utils.List2.List2 Agda.Utils.List1.List1
+ Agda.Utils.Zip: instance Agda.Utils.Zip.Zip Agda.Utils.List1.List1 Agda.Utils.ListInf.ListInf Agda.Utils.List1.List1
+ Agda.Utils.Zip: instance Agda.Utils.Zip.Zip Agda.Utils.List1.List1 [] []
+ Agda.Utils.Zip: instance Agda.Utils.Zip.Zip Agda.Utils.List2.List2 Agda.Utils.List1.List1 Agda.Utils.List1.List1
+ Agda.Utils.Zip: instance Agda.Utils.Zip.Zip Agda.Utils.List2.List2 Agda.Utils.List2.List2 Agda.Utils.List2.List2
+ Agda.Utils.Zip: instance Agda.Utils.Zip.Zip Agda.Utils.List2.List2 Agda.Utils.ListInf.ListInf Agda.Utils.List2.List2
+ Agda.Utils.Zip: instance Agda.Utils.Zip.Zip Agda.Utils.List2.List2 [] []
+ Agda.Utils.Zip: instance Agda.Utils.Zip.Zip Agda.Utils.ListInf.ListInf Agda.Utils.List1.List1 Agda.Utils.List1.List1
+ Agda.Utils.Zip: instance Agda.Utils.Zip.Zip Agda.Utils.ListInf.ListInf Agda.Utils.List2.List2 Agda.Utils.List2.List2
+ Agda.Utils.Zip: instance Agda.Utils.Zip.Zip Agda.Utils.ListInf.ListInf Agda.Utils.ListInf.ListInf Agda.Utils.ListInf.ListInf
+ Agda.Utils.Zip: instance Agda.Utils.Zip.Zip Agda.Utils.ListInf.ListInf [] []
+ Agda.Utils.Zip: instance Agda.Utils.Zip.Zip [] Agda.Utils.List1.List1 []
+ Agda.Utils.Zip: instance Agda.Utils.Zip.Zip [] Agda.Utils.List2.List2 []
+ Agda.Utils.Zip: instance Agda.Utils.Zip.Zip [] Agda.Utils.ListInf.ListInf []
+ Agda.Utils.Zip: instance Agda.Utils.Zip.Zip [] [] []
+ Agda.Utils.Zip: zip :: Zip f g h => f a -> g b -> h (a, b)
+ Agda.Utils.Zip: zipWith :: Zip f g h => (a -> b -> c) -> f a -> g b -> h c
- Agda.Compiler.JS.Compiler: compileAlt :: EnvWithOpts -> TAlt -> TCM (MemberId, Exp)
+ Agda.Compiler.JS.Compiler: compileAlt :: EnvWithOpts -> Int -> TAlt -> Exp -> TCM Exp
- Agda.Compiler.JS.Syntax: Array :: [(Comment, Exp)] -> Exp
+ Agda.Compiler.JS.Syntax: Array :: [Exp] -> Exp
- Agda.Compiler.JS.Syntax: MemberIndex :: Int -> Comment -> MemberId
+ Agda.Compiler.JS.Syntax: MemberIndex :: Int -> MemberId
- Agda.Compiler.MAlonzo.Misc: ($dmaskGHCModuleEnv) :: forall (t :: (Type -> Type) -> Type -> Type) (n :: Type -> Type). (ReadGHCModuleEnv m, MonadTrans t, Monad n, m ~ t n, ReadGHCModuleEnv n) => m GHCModuleEnv
+ Agda.Compiler.MAlonzo.Misc: ($dmaskGHCModuleEnv) :: forall (t :: (Type -> Type) -> Type -> Type) (n :: Type -> Type). (ReadGHCModuleEnv m, MonadTrans t, m ~ t n, ReadGHCModuleEnv n) => m GHCModuleEnv
- Agda.Compiler.MAlonzo.Misc: GHCOptions :: Bool -> FilePath -> [String] -> FilePath -> Bool -> Bool -> GHCOptions
+ Agda.Compiler.MAlonzo.Misc: GHCOptions :: Bool -> FilePath -> [String] -> FilePath -> Bool -> Bool -> Bool -> GHCOptions
- Agda.Compiler.MAlonzo.Misc: hsLet :: Name -> Exp -> Exp -> Exp
+ Agda.Compiler.MAlonzo.Misc: hsLet :: Strictness -> Name -> Exp -> Exp -> Exp
- Agda.Compiler.MAlonzo.Pragmas: foreignHaskell :: Interface -> ([String], [String], [String])
+ Agda.Compiler.MAlonzo.Pragmas: foreignHaskell :: Interface -> (Set GHCPragma, Set GHCImport, [HaskellCode])
- Agda.Compiler.ToTreeless: toTreelessWith :: BuildPipeline -> CCConfig -> QName -> TCM (Maybe TTerm)
+ Agda.Compiler.ToTreeless: toTreelessWith :: CCConfig -> QName -> TCM (Maybe TTerm)
- Agda.Compiler.ToTreeless: type CCConfig = (EvaluationStrategy, CCSubst)
+ Agda.Compiler.ToTreeless: type CCConfig = (EvaluationStrategy, CCSubst, BuildPipeline)
- Agda.Compiler.Treeless.Simplify: simplifyTTerm :: TTerm -> TCM TTerm
+ Agda.Compiler.Treeless.Simplify: simplifyTTerm :: EvaluationStrategy -> TTerm -> TCM TTerm
- Agda.Interaction.Base: Cmd_constraints :: Interaction' range
+ Agda.Interaction.Base: Cmd_constraints :: Rewrite -> Interaction' range
- Agda.Interaction.Base: CommandState :: [InteractionId] -> Maybe CurrentFile -> CommandLineOptions -> !OldInteractionScopes -> !CommandQueue -> CommandState
+ Agda.Interaction.Base: CommandState :: [InteractionId] -> Maybe CurrentFile -> Maybe AbsolutePath -> CommandLineOptions -> !OldInteractionScopes -> !CommandQueue -> CommandState
- Agda.Interaction.BasicOps: elaborate_give :: Rewrite -> UseForce -> InteractionId -> Maybe Range -> Expr -> TCM Expr
+ Agda.Interaction.BasicOps: elaborate_give :: Rewrite -> UseForce -> InteractionId -> Expr -> TCM Expr
- Agda.Interaction.BasicOps: getConstraints :: TCM [OutputForm Expr Expr]
+ Agda.Interaction.BasicOps: getConstraints :: Rewrite -> TCM [OutputForm Expr Expr]
- Agda.Interaction.BasicOps: give :: UseForce -> InteractionId -> Maybe Range -> Expr -> TCM Expr
+ Agda.Interaction.BasicOps: give :: UseForce -> InteractionId -> Expr -> TCM Expr
- Agda.Interaction.BasicOps: give_ :: Bool -> UseForce -> InteractionId -> Maybe Range -> Expr -> TCM Term
+ Agda.Interaction.BasicOps: give_ :: Bool -> UseForce -> InteractionId -> Expr -> TCM Term
- Agda.Interaction.BasicOps: metaHelperType :: Rewrite -> InteractionId -> Range -> String -> TCM (OutputConstraint' Expr Expr)
+ Agda.Interaction.BasicOps: metaHelperType :: Rewrite -> InteractionId -> Range -> String -> TCM (OutputConstraint' Expr Name)
- Agda.Interaction.BasicOps: refine :: UseForce -> InteractionId -> Maybe Range -> Expr -> TCM Expr
+ Agda.Interaction.BasicOps: refine :: UseForce -> InteractionId -> Expr -> TCM Expr
- Agda.Interaction.EmacsCommand: displayRunningInfo :: String -> Lisp String
+ Agda.Interaction.EmacsCommand: displayRunningInfo :: DocTree -> Maybe ModuleToSource -> Lisp String
- Agda.Interaction.FindFile: NotFound :: [AbsolutePath] -> FindError
+ Agda.Interaction.FindFile: NotFound :: List1 AbsolutePath -> FindError
- Agda.Interaction.Highlighting.Emacs: lispifyHighlightingInfo :: HighlightingInfo -> RemoveTokenBasedHighlighting -> HighlightingMethod -> ModuleToSource -> IO (Lisp String)
+ Agda.Interaction.Highlighting.Emacs: lispifyHighlightingInfo :: HighlightingInfo -> RemoveTokenBasedHighlighting -> HighlightingMethod -> ModuleToSource -> Maybe FilePath -> IO (Lisp String)
- Agda.Interaction.Highlighting.HTML.Base: runLogHtmlWith :: Monad m => HtmlLogAction m -> LogHtmlT m a -> m a
+ Agda.Interaction.Highlighting.HTML.Base: runLogHtmlWith :: HtmlLogAction m -> LogHtmlT m a -> m a
- Agda.Interaction.Highlighting.JSON: jsonifyHighlightingInfo :: HighlightingInfo -> RemoveTokenBasedHighlighting -> HighlightingMethod -> ModuleToSource -> IO Value
+ Agda.Interaction.Highlighting.JSON: jsonifyHighlightingInfo :: HighlightingInfo -> RemoveTokenBasedHighlighting -> HighlightingMethod -> ModuleToSource -> Maybe FilePath -> IO Value
- Agda.Interaction.Library: AgdaLibFile :: LibName -> FilePath -> !Int -> [FilePath] -> [LibName] -> OptionsPragma -> AgdaLibFile
+ Agda.Interaction.Library: AgdaLibFile :: LibName -> FilePath -> !Int -> [FilePath] -> [LibName] -> Map LibName LibFilePos -> OptionsPragma -> AgdaLibFile
- Agda.Interaction.Library: getDefaultLibraries :: FilePath -> Bool -> LibM ([LibName], [FilePath])
+ Agda.Interaction.Library: getDefaultLibraries :: FilePath -> Bool -> LibM (Maybe AgdaLibFile, [LibName], [FilePath])
- Agda.Interaction.Library: libraryIncludePaths :: Maybe FilePath -> [AgdaLibFile] -> [LibName] -> LibM [FilePath]
+ Agda.Interaction.Library: libraryIncludePaths :: Maybe FilePath -> Maybe AgdaLibFile -> [AgdaLibFile] -> [LibName] -> LibM [FilePath]
- Agda.Interaction.Library.Base: AgdaLibFile :: LibName -> FilePath -> !Int -> [FilePath] -> [LibName] -> OptionsPragma -> AgdaLibFile
+ Agda.Interaction.Library.Base: AgdaLibFile :: LibName -> FilePath -> !Int -> [FilePath] -> [LibName] -> Map LibName LibFilePos -> OptionsPragma -> AgdaLibFile
- Agda.Interaction.MakeCase: makePatternVarsVisible :: [Nat] -> SplitClause -> SplitClause
+ Agda.Interaction.MakeCase: makePatternVarsVisible :: [Name] -> [Nat] -> SplitClause -> SplitClause
- Agda.Interaction.MakeCase: parseVariables :: QName -> Context -> [AsBinding] -> InteractionId -> Range -> [String] -> TCM [(Int, NameInScope)]
+ Agda.Interaction.MakeCase: parseVariables :: QName -> Context -> [AsBinding] -> InteractionId -> Range -> [String] -> TCM [SplitAction]
- Agda.Interaction.MakeCase: recheckAbstractClause :: Type -> Maybe Substitution -> SpineClause -> TCM (Clause, Context, [AsBinding])
+ Agda.Interaction.MakeCase: recheckAbstractClause :: Type -> IsWithFunction Substitution -> SpineClause -> TCM (Clause, Context, [AsBinding])
- Agda.Interaction.Options: ICOption :: (PragmaOptions -> Bool) -> String -> InfectiveCoinfective -> (PragmaOptions -> PragmaOptions -> Bool) -> (TopLevelModuleName -> Doc) -> InfectiveCoinfectiveOption
+ Agda.Interaction.Options: ICOption :: (PragmaOptions -> Bool) -> String -> InfectiveCoinfective -> (PragmaOptions -> PragmaOptions -> Bool) -> (PragmaOptions -> PragmaOptions -> TopLevelModuleName -> Doc) -> InfectiveCoinfectiveOption
- Agda.Interaction.Options: Options :: String -> Maybe FilePath -> [FilePath] -> [AbsolutePath] -> [LibName] -> Maybe FilePath -> Bool -> Bool -> Integer -> Map ExeName FilePath -> Bool -> Bool -> Maybe PrintAgdaVersion -> Maybe Help -> Bool -> Bool -> Set EmacsModeCommand -> Bool -> Bool -> Bool -> !Bool -> Maybe FilePath -> Bool -> Bool -> Bool -> PragmaOptions -> Bool -> Bool -> DiagnosticsColours -> CommandLineOptions
+ Agda.Interaction.Options: Options :: String -> Maybe FilePath -> [FilePath] -> [AbsolutePath] -> [LibName] -> Maybe FilePath -> Bool -> Bool -> Integer -> Map ExeName FilePath -> Bool -> Bool -> Bool -> Maybe PrintAgdaVersion -> Maybe Help -> Bool -> Bool -> Set EmacsModeCommand -> Bool -> Bool -> Bool -> !Bool -> Maybe FilePath -> Bool -> Bool -> Bool -> Bool -> PragmaOptions -> Bool -> Bool -> DiagnosticsColours -> Bool -> Parallelism -> CommandLineOptions
- Agda.Interaction.Options: PragmaOptions :: WithDefault 'False -> WithDefault 'True -> WithDefault 'False -> WithDefault' UnicodeOrAscii 'True -> !Verbosity -> ProfileOptions -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'True -> WithDefault 'True -> CutOff -> WithDefault 'True -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'True -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'True -> WithDefault 'True -> WithDefault 'False -> WithDefault 'False -> WithDefault 'True -> WithDefault 'True -> WithDefault 'True -> WithDefault 'False -> WithDefault 'True -> WithDefault 'False -> WithDefault 'False -> Maybe Cubical -> WithDefault 'False -> WithDefault 'False -> WithDefault 'True -> WithDefault 'True -> WithDefault 'True -> WithDefault 'True -> Int -> WithDefault 'False -> WithDefault 'True -> Int -> WithDefault 'False -> WithDefault 'False -> !Maybe Int -> WarningMode -> WithDefault 'True -> WithDefault 'True -> WithDefault 'False -> WithDefault 'False -> WithDefault 'True -> WithDefault 'True -> WithDefault 'False -> Maybe ConfluenceCheck -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'True -> WithDefault 'True -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'True -> WithDefault 'False -> PragmaOptions
+ Agda.Interaction.Options: PragmaOptions :: WithDefault 'False -> WithDefault 'True -> WithDefault 'False -> WithDefault' UnicodeOrAscii 'True -> !Verbosity -> ProfileOptions -> WithDefault 'True -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'True -> WithDefault 'True -> CutOff -> WithDefault 'True -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'True -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'True -> WithDefault 'True -> WithDefault 'False -> WithDefault 'False -> WithDefault 'True -> WithDefault 'True -> WithDefault 'True -> WithDefault 'False -> AllowedErasedMatchesWithDefaults -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> Maybe Cubical -> WithDefault 'False -> WithDefault 'False -> WithDefault 'True -> WithDefault 'True -> WithDefault 'True -> WithDefault 'True -> Int -> WithDefault 'False -> WithDefault 'True -> Int -> WithDefault 'False -> WithDefault 'False -> !Maybe Int -> WarningMode -> WithDefault 'True -> WithDefault 'True -> WithDefault 'False -> WithDefault 'False -> WithDefault 'True -> WithDefault 'True -> WithDefault 'False -> Maybe ConfluenceCheck -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'True -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'True -> WithDefault 'True -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'False -> WithDefault 'True -> WithDefault 'False -> WithDefault 'False -> PragmaOptions
- Agda.Interaction.Options: [_optErasedMatches] :: PragmaOptions -> WithDefault 'True
+ Agda.Interaction.Options: [_optErasedMatches] :: PragmaOptions -> AllowedErasedMatchesWithDefaults
- Agda.Interaction.Options: [icOptionWarning] :: InfectiveCoinfectiveOption -> TopLevelModuleName -> Doc
+ Agda.Interaction.Options: [icOptionWarning] :: InfectiveCoinfectiveOption -> PragmaOptions -> PragmaOptions -> TopLevelModuleName -> Doc
- Agda.Interaction.Options: checkOpts :: MonadError OptionError m => CommandLineOptions -> m CommandLineOptions
+ Agda.Interaction.Options: checkOpts :: (MonadError OptionError m, MonadWriter OptionWarnings m) => CommandLineOptions -> m CommandLineOptions
- Agda.Interaction.Options: lensOptErasedMatches :: Functor f => (WithDefault 'True -> f (WithDefault 'True)) -> PragmaOptions -> f PragmaOptions
+ Agda.Interaction.Options: lensOptErasedMatches :: Functor f => (AllowedErasedMatchesWithDefaults -> f AllowedErasedMatchesWithDefaults) -> PragmaOptions -> f PragmaOptions
- Agda.Interaction.Options: lensOptNoUniverseCheck :: Functor f => (WithDefault' Bool 'True -> f (WithDefault' Bool 'True)) -> PragmaOptions -> f PragmaOptions
+ Agda.Interaction.Options: lensOptNoUniverseCheck :: Functor f => (WithDefault 'False -> f (WithDefault 'False)) -> PragmaOptions -> f PragmaOptions
- Agda.Interaction.Options: optErasedMatches :: PragmaOptions -> Bool
+ Agda.Interaction.Options: optErasedMatches :: PragmaOptions -> AllowedErasedMatches
- Agda.Interaction.Response.Base: Goal_HelperFunction :: OutputConstraint' Expr Expr -> GoalDisplayInfo_boot tcErr
+ Agda.Interaction.Response.Base: Goal_HelperFunction :: OutputConstraint' Expr Name -> GoalDisplayInfo_boot tcErr
- Agda.Interaction.Response.Base: Resp_HighlightingInfo :: HighlightingInfo -> RemoveTokenBasedHighlighting -> HighlightingMethod -> ModuleToSource -> Response_boot tcErr tcWarning warningsAndNonFatalErrors
+ Agda.Interaction.Response.Base: Resp_HighlightingInfo :: HighlightingInfo -> RemoveTokenBasedHighlighting -> HighlightingMethod -> ModuleToSource -> Maybe FilePath -> Response_boot tcErr tcWarning warningsAndNonFatalErrors
- Agda.Interaction.Response.Base: Resp_RunningInfo :: Int -> String -> Response_boot tcErr tcWarning warningsAndNonFatalErrors
+ Agda.Interaction.Response.Base: Resp_RunningInfo :: Int -> DocTree -> Response_boot tcErr tcWarning warningsAndNonFatalErrors
- Agda.Syntax.Abstract: DataDef :: DefInfo -> QName -> UniverseCheck -> DataDefParams -> [Constructor] -> Declaration
+ Agda.Syntax.Abstract: DataDef :: DefInfo -> QName -> PositivityCheck -> UniverseCheck -> DataDefParams -> [Constructor] -> Declaration
- Agda.Syntax.Abstract: FunDef :: DefInfo -> QName -> [Clause] -> Declaration
+ Agda.Syntax.Abstract: FunDef :: DefInfo -> QName -> List1 Clause -> Declaration
- Agda.Syntax.Abstract: FunDefS :: [ClauseSpine] -> DeclarationSpine
+ Agda.Syntax.Abstract: FunDefS :: List1 ClauseSpine -> DeclarationSpine
- Agda.Syntax.Abstract: LetPatBind :: LetInfo -> Pattern -> Expr -> LetBinding
+ Agda.Syntax.Abstract: LetPatBind :: LetInfo -> ArgInfo -> Pattern -> Expr -> LetBinding
- Agda.Syntax.Abstract: Mutual :: MutualInfo -> [Declaration] -> Declaration
+ Agda.Syntax.Abstract: Mutual :: MutualInfo -> List1 Declaration -> Declaration
- Agda.Syntax.Abstract: MutualS :: [DeclarationSpine] -> DeclarationSpine
+ Agda.Syntax.Abstract: MutualS :: List1 DeclarationSpine -> DeclarationSpine
- Agda.Syntax.Abstract: RecDef :: DefInfo -> QName -> UniverseCheck -> RecordDirectives -> DataDefParams -> Type -> [Declaration] -> Declaration
+ Agda.Syntax.Abstract: RecDef :: DefInfo -> QName -> PositivityCheck -> UniverseCheck -> ForceRecordEta -> RecordDirectives -> DataDefParams -> Type -> [Declaration] -> Declaration
- Agda.Syntax.Abstract: ScopedDecl :: ScopeInfo -> [Declaration] -> Declaration
+ Agda.Syntax.Abstract: ScopedDecl :: ScopeInfo -> List1 Declaration -> Declaration
- Agda.Syntax.Abstract: ScopedDeclS :: [DeclarationSpine] -> DeclarationSpine
+ Agda.Syntax.Abstract: ScopedDeclS :: List1 DeclarationSpine -> DeclarationSpine
- Agda.Syntax.Abstract.Name: AmbQ :: List1 QName -> AmbiguousQName
+ Agda.Syntax.Abstract.Name: AmbQ :: Map1 NameId AmbQNameEntry -> AmbiguousQName
- Agda.Syntax.Abstract.Name: Name :: !NameId -> Name -> Name -> Range -> Fixity' -> Bool -> Name
+ Agda.Syntax.Abstract.Name: Name :: {-# UNPACK #-} !NameId -> Name -> Name -> Range -> Fixity' -> Bool -> Name
- Agda.Syntax.Abstract.Name: [unAmbQ] :: AmbiguousQName -> List1 QName
+ Agda.Syntax.Abstract.Name: [unAmbQ] :: AmbiguousQName -> Map1 NameId AmbQNameEntry
- Agda.Syntax.Abstract.Pattern: lhsCoreAddChunk :: IsProjP e => LHSCore' e -> LHSPatternView e -> LHSCore' e
+ Agda.Syntax.Abstract.Pattern: lhsCoreAddChunk :: LHSCore' e -> LHSPatternView e -> LHSCore' e
- Agda.Syntax.Abstract.Pattern: lhsPatternView :: IsProjP e => NAPs e -> Maybe (LHSPatternView e, NAPs e)
+ Agda.Syntax.Abstract.Pattern: lhsPatternView :: NAPs e -> Maybe (LHSPatternView e, NAPs e)
- Agda.Syntax.Abstract.Views: deepUnscopeDecl :: Declaration -> [Declaration]
+ Agda.Syntax.Abstract.Views: deepUnscopeDecl :: Declaration -> List1 Declaration
- Agda.Syntax.Abstract.Views: deepUnscopeDecls :: [Declaration] -> [Declaration]
+ Agda.Syntax.Abstract.Views: deepUnscopeDecls :: DeepUnscopeDecls t => t Declaration -> t Declaration
- Agda.Syntax.Abstract.Views: maybeProjTurnPostfix :: Expr -> Maybe Expr
+ Agda.Syntax.Abstract.Views: maybeProjTurnPostfix :: Expr -> Maybe (AmbiguousQName, Expr)
- Agda.Syntax.Abstract.Views: type TraverseExprFn (m :: Type -> Type) a = (Applicative m, Monad m) => Expr -> m Expr -> a -> m a
+ Agda.Syntax.Abstract.Views: type TraverseExprFn (m :: Type -> Type) a = Monad m => Expr -> m Expr -> a -> m a
- Agda.Syntax.Common: Annotation :: Lock -> Annotation
+ Agda.Syntax.Common: Annotation :: Lock -> RewriteAnn -> Annotation
- Agda.Syntax.Common: Irrelevant :: OriginIrrelevant -> Relevance
+ Agda.Syntax.Common: Irrelevant :: !OriginIrrelevant -> Relevance
- Agda.Syntax.Common: IsPattern :: ExprKind
+ Agda.Syntax.Common: IsPattern :: DisplayLHS -> ExprKind
- Agda.Syntax.Common: KnownFVs :: IntSet -> FreeVariables
+ Agda.Syntax.Common: KnownFVs :: !VarSet -> FreeVariables
- Agda.Syntax.Common: Modality :: Relevance -> Quantity -> Cohesion -> PolarityModality -> Modality
+ Agda.Syntax.Common: Modality :: !Relevance -> !Quantity -> !Cohesion -> !PolarityModality -> Modality
- Agda.Syntax.Common: ProblemId :: Nat -> ProblemId
+ Agda.Syntax.Common: ProblemId :: Word64 -> ProblemId
- Agda.Syntax.Common: Relevant :: OriginRelevant -> Relevance
+ Agda.Syntax.Common: Relevant :: !OriginRelevant -> Relevance
- Agda.Syntax.Common: ShapeIrrelevant :: OriginShapeIrrelevant -> Relevance
+ Agda.Syntax.Common: ShapeIrrelevant :: !OriginShapeIrrelevant -> Relevance
- Agda.Syntax.Common: [modCohesion] :: Modality -> Cohesion
+ Agda.Syntax.Common: [modCohesion] :: Modality -> !Cohesion
- Agda.Syntax.Common: [modPolarity] :: Modality -> PolarityModality
+ Agda.Syntax.Common: [modPolarity] :: Modality -> !PolarityModality
- Agda.Syntax.Common: [modQuantity] :: Modality -> Quantity
+ Agda.Syntax.Common: [modQuantity] :: Modality -> !Quantity
- Agda.Syntax.Common: [modRelevance] :: Modality -> Relevance
+ Agda.Syntax.Common: [modRelevance] :: Modality -> !Relevance
- Agda.Syntax.Common.Pretty: annotate :: a -> Doc a -> Doc a
+ Agda.Syntax.Common.Pretty: annotate :: Aspects -> Doc -> Doc
- Agda.Syntax.Concrete: Data :: Range -> Erased -> Name -> [LamBinding] -> Expr -> [TypeSignatureOrInstanceBlock] -> Declaration
+ Agda.Syntax.Concrete: Data :: Range -> Erased -> Name -> Parameters -> Expr -> [TypeSignatureOrInstanceBlock] -> Declaration
- Agda.Syntax.Concrete: DataDef :: Range -> Name -> [LamBinding] -> [TypeSignatureOrInstanceBlock] -> Declaration
+ Agda.Syntax.Concrete: DataDef :: Range -> Name -> Parameters -> [TypeSignatureOrInstanceBlock] -> Declaration
- Agda.Syntax.Concrete: DataSig :: Range -> Erased -> Name -> [LamBinding] -> Expr -> Declaration
+ Agda.Syntax.Concrete: DataSig :: Range -> Erased -> Name -> Parameters -> Expr -> Declaration
- Agda.Syntax.Concrete: DoBlock :: Range -> List1 DoStmt -> Expr
+ Agda.Syntax.Concrete: DoBlock :: KwRange -> Maybe QName -> List1 DoStmt -> Expr
- Agda.Syntax.Concrete: DoOpen :: OpenShortHand
+ Agda.Syntax.Concrete: DoOpen :: KwRange -> OpenShortHand
- Agda.Syntax.Concrete: DotP :: KwRange -> Range -> Expr -> Pattern
+ Agda.Syntax.Concrete: DotP :: KwRange -> Range -> !PossiblyProjectionPattern -> Expr -> Pattern
- Agda.Syntax.Concrete: FunClause :: LHS -> RHS -> WhereClause -> Catchall -> Declaration
+ Agda.Syntax.Concrete: FunClause :: ArgInfo -> LHS -> RHS -> WhereClause -> Catchall -> Declaration
- Agda.Syntax.Concrete: IdiomBrackets :: Range -> [Expr] -> Expr
+ Agda.Syntax.Concrete: IdiomBrackets :: Range -> Maybe QName -> [Expr] -> Expr
- Agda.Syntax.Concrete: Import :: Range -> QName -> Maybe AsName -> !OpenShortHand -> ImportDirective -> Declaration
+ Agda.Syntax.Concrete: Import :: OpenShortHand -> KwRange -> QName -> Either AsName RawOpenArgs -> ImportDirective -> Declaration
- Agda.Syntax.Concrete: KnownIdent :: NameKind -> QName -> Expr
+ Agda.Syntax.Concrete: KnownIdent :: Aspects -> QName -> Expr
- Agda.Syntax.Concrete: KnownOpApp :: NameKind -> Range -> QName -> Set1 Name -> OpAppArgs -> Expr
+ Agda.Syntax.Concrete: KnownOpApp :: Aspects -> Range -> QName -> Set1 Name -> OpAppArgs -> Expr
- Agda.Syntax.Concrete: Mod :: [Pragma] -> [Declaration] -> Module
+ Agda.Syntax.Concrete: Mod :: QName -> [Pragma] -> [Declaration] -> Module
- Agda.Syntax.Concrete: Open :: Range -> QName -> ImportDirective -> Declaration
+ Agda.Syntax.Concrete: Open :: KwRange -> QName -> ImportDirective -> Declaration
- Agda.Syntax.Concrete: Record :: Range -> Erased -> Name -> [RecordDirective] -> [LamBinding] -> Expr -> [Declaration] -> Declaration
+ Agda.Syntax.Concrete: Record :: Range -> Erased -> Name -> [RecordDirective] -> Parameters -> Expr -> [Declaration] -> Declaration
- Agda.Syntax.Concrete: RecordDef :: Range -> Name -> [RecordDirective] -> [LamBinding] -> [Declaration] -> Declaration
+ Agda.Syntax.Concrete: RecordDef :: Range -> Name -> [RecordDirective] -> Parameters -> [Declaration] -> Declaration
- Agda.Syntax.Concrete: RecordSig :: Range -> Erased -> Name -> [LamBinding] -> Expr -> Declaration
+ Agda.Syntax.Concrete: RecordSig :: Range -> Erased -> Name -> Parameters -> Expr -> Declaration
- Agda.Syntax.Concrete: type AsName = AsName' Either Expr Name
+ Agda.Syntax.Concrete: type AsName = AsName' Name
- Agda.Syntax.Concrete.Attribute: type LensAttribute a = (LensRelevance a, LensQuantity a, LensCohesion a, LensModalPolarity a, LensLock a)
+ Agda.Syntax.Concrete.Attribute: type LensAttribute a = (LensRelevance a, LensQuantity a, LensCohesion a, LensModalPolarity a, LensLock a, LensRewriteAnn a)
- Agda.Syntax.Concrete.Definitions: Clause :: Name -> Catchall -> LHS -> RHS -> WhereClause -> [Clause] -> Clause
+ Agda.Syntax.Concrete.Definitions: Clause :: Name -> Catchall -> ArgInfo -> LHS -> RHS -> WhereClause -> [Clause] -> Clause
- Agda.Syntax.Concrete.Definitions: FunDef :: Range -> [Declaration] -> IsAbstract -> IsInstance -> TerminationCheck -> CoverageCheck -> Name -> [Clause] -> NiceDeclaration
+ Agda.Syntax.Concrete.Definitions: FunDef :: Range -> List1 Declaration -> IsAbstract -> IsInstance -> TerminationCheck -> CoverageCheck -> Name -> List1 Clause -> NiceDeclaration
- Agda.Syntax.Concrete.Definitions: NiceDataDef :: Range -> Origin -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [LamBinding] -> [NiceConstructor] -> NiceDeclaration
+ Agda.Syntax.Concrete.Definitions: NiceDataDef :: Range -> Origin -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> DefParameters -> [NiceConstructor] -> NiceDeclaration
- Agda.Syntax.Concrete.Definitions: NiceDataSig :: Range -> Erased -> Access -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [LamBinding] -> Expr -> NiceDeclaration
+ Agda.Syntax.Concrete.Definitions: NiceDataSig :: Range -> Erased -> Access -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> Parameters -> Expr -> NiceDeclaration
- Agda.Syntax.Concrete.Definitions: NiceImport :: Range -> QName -> Maybe AsName -> OpenShortHand -> ImportDirective -> NiceDeclaration
+ Agda.Syntax.Concrete.Definitions: NiceImport :: OpenShortHand -> KwRange -> QName -> Either AsName RawOpenArgs -> ImportDirective -> NiceDeclaration
- Agda.Syntax.Concrete.Definitions: NiceMutual :: KwRange -> TerminationCheck -> CoverageCheck -> PositivityCheck -> [NiceDeclaration] -> NiceDeclaration
+ Agda.Syntax.Concrete.Definitions: NiceMutual :: KwRange -> TerminationCheck -> CoverageCheck -> PositivityCheck -> List1 NiceDeclaration -> NiceDeclaration
- Agda.Syntax.Concrete.Definitions: NiceOpen :: Range -> QName -> ImportDirective -> NiceDeclaration
+ Agda.Syntax.Concrete.Definitions: NiceOpen :: KwRange -> QName -> ImportDirective -> NiceDeclaration
- Agda.Syntax.Concrete.Definitions: NiceRecDef :: Range -> Origin -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [RecordDirective] -> [LamBinding] -> [Declaration] -> NiceDeclaration
+ Agda.Syntax.Concrete.Definitions: NiceRecDef :: Range -> Origin -> IsAbstract -> PositivityCheck -> UniverseCheck -> ForceRecordEta -> Name -> [RecordDirective] -> DefParameters -> [Declaration] -> NiceDeclaration
- Agda.Syntax.Concrete.Definitions: NiceRecSig :: Range -> Erased -> Access -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [LamBinding] -> Expr -> NiceDeclaration
+ Agda.Syntax.Concrete.Definitions: NiceRecSig :: Range -> Erased -> Access -> IsAbstract -> PositivityCheck -> UniverseCheck -> ForceRecordEta -> Name -> Parameters -> Expr -> NiceDeclaration
- Agda.Syntax.Concrete.Definitions.Errors: DuplicateAnonDeclaration :: Range -> DeclarationException'
+ Agda.Syntax.Concrete.Definitions.Errors: DuplicateAnonDeclaration :: Range -> Range -> DeclarationException'
- Agda.Syntax.Concrete.Definitions.Errors: DuplicateDefinition :: Name -> DeclarationException'
+ Agda.Syntax.Concrete.Definitions.Errors: DuplicateDefinition :: Name -> Range -> DeclarationException'
- Agda.Syntax.Concrete.Definitions.Monad: NiceState :: LoneSigs -> TerminationCheck -> PositivityCheck -> UniverseCheck -> Catchall -> CoverageCheck -> NiceWarnings -> NameId -> NiceState
+ Agda.Syntax.Concrete.Definitions.Monad: NiceState :: LoneSigs -> TerminationCheck -> PositivityCheck -> UniverseCheck -> ForceRecordEta -> Catchall -> CoverageCheck -> NiceWarnings -> NameId -> NiceState
- Agda.Syntax.Concrete.Definitions.Monad: loneFuns :: LoneSigs -> [(Name, Name)]
+ Agda.Syntax.Concrete.Definitions.Monad: loneFuns :: LoneSigs -> [(Name, Arg Name)]
- Agda.Syntax.Concrete.Definitions.Types: Clause :: Name -> Catchall -> LHS -> RHS -> WhereClause -> [Clause] -> Clause
+ Agda.Syntax.Concrete.Definitions.Types: Clause :: Name -> Catchall -> ArgInfo -> LHS -> RHS -> WhereClause -> [Clause] -> Clause
- Agda.Syntax.Concrete.Definitions.Types: FunDef :: Range -> [Declaration] -> IsAbstract -> IsInstance -> TerminationCheck -> CoverageCheck -> Name -> [Clause] -> NiceDeclaration
+ Agda.Syntax.Concrete.Definitions.Types: FunDef :: Range -> List1 Declaration -> IsAbstract -> IsInstance -> TerminationCheck -> CoverageCheck -> Name -> List1 Clause -> NiceDeclaration
- Agda.Syntax.Concrete.Definitions.Types: FunName :: TerminationCheck -> CoverageCheck -> DataRecOrFun
+ Agda.Syntax.Concrete.Definitions.Types: FunName :: ArgInfo -> TerminationCheck -> CoverageCheck -> DataRecOrFun
- Agda.Syntax.Concrete.Definitions.Types: InterleavedData :: DeclNum -> NiceDeclaration -> Maybe (DeclNum, List1 [NiceConstructor]) -> InterleavedDecl
+ Agda.Syntax.Concrete.Definitions.Types: InterleavedData :: DeclNum -> NiceDeclaration -> Maybe (DeclNum, List1 (DefParameters, [NiceConstructor])) -> InterleavedDecl
- Agda.Syntax.Concrete.Definitions.Types: InterleavedFun :: DeclNum -> NiceDeclaration -> Maybe (DeclNum, List1 ([Declaration], [Clause])) -> InterleavedDecl
+ Agda.Syntax.Concrete.Definitions.Types: InterleavedFun :: DeclNum -> NiceDeclaration -> Maybe (DeclNum, List1 (List1 Declaration, List1 Clause)) -> InterleavedDecl
- Agda.Syntax.Concrete.Definitions.Types: NiceDataDef :: Range -> Origin -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [LamBinding] -> [NiceConstructor] -> NiceDeclaration
+ Agda.Syntax.Concrete.Definitions.Types: NiceDataDef :: Range -> Origin -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> DefParameters -> [NiceConstructor] -> NiceDeclaration
- Agda.Syntax.Concrete.Definitions.Types: NiceDataSig :: Range -> Erased -> Access -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [LamBinding] -> Expr -> NiceDeclaration
+ Agda.Syntax.Concrete.Definitions.Types: NiceDataSig :: Range -> Erased -> Access -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> Parameters -> Expr -> NiceDeclaration
- Agda.Syntax.Concrete.Definitions.Types: NiceImport :: Range -> QName -> Maybe AsName -> OpenShortHand -> ImportDirective -> NiceDeclaration
+ Agda.Syntax.Concrete.Definitions.Types: NiceImport :: OpenShortHand -> KwRange -> QName -> Either AsName RawOpenArgs -> ImportDirective -> NiceDeclaration
- Agda.Syntax.Concrete.Definitions.Types: NiceMutual :: KwRange -> TerminationCheck -> CoverageCheck -> PositivityCheck -> [NiceDeclaration] -> NiceDeclaration
+ Agda.Syntax.Concrete.Definitions.Types: NiceMutual :: KwRange -> TerminationCheck -> CoverageCheck -> PositivityCheck -> List1 NiceDeclaration -> NiceDeclaration
- Agda.Syntax.Concrete.Definitions.Types: NiceOpen :: Range -> QName -> ImportDirective -> NiceDeclaration
+ Agda.Syntax.Concrete.Definitions.Types: NiceOpen :: KwRange -> QName -> ImportDirective -> NiceDeclaration
- Agda.Syntax.Concrete.Definitions.Types: NiceRecDef :: Range -> Origin -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [RecordDirective] -> [LamBinding] -> [Declaration] -> NiceDeclaration
+ Agda.Syntax.Concrete.Definitions.Types: NiceRecDef :: Range -> Origin -> IsAbstract -> PositivityCheck -> UniverseCheck -> ForceRecordEta -> Name -> [RecordDirective] -> DefParameters -> [Declaration] -> NiceDeclaration
- Agda.Syntax.Concrete.Definitions.Types: NiceRecSig :: Range -> Erased -> Access -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [LamBinding] -> Expr -> NiceDeclaration
+ Agda.Syntax.Concrete.Definitions.Types: NiceRecSig :: Range -> Erased -> Access -> IsAbstract -> PositivityCheck -> UniverseCheck -> ForceRecordEta -> Name -> Parameters -> Expr -> NiceDeclaration
- Agda.Syntax.Concrete.Definitions.Types: RecName :: PositivityCheck -> UniverseCheck -> DataRecOrFun
+ Agda.Syntax.Concrete.Definitions.Types: RecName :: PositivityCheck -> UniverseCheck -> ForceRecordEta -> DataRecOrFun
- Agda.Syntax.Concrete.Definitions.Types: [interleavedDataCons] :: InterleavedDecl -> Maybe (DeclNum, List1 [NiceConstructor])
+ Agda.Syntax.Concrete.Definitions.Types: [interleavedDataCons] :: InterleavedDecl -> Maybe (DeclNum, List1 (DefParameters, [NiceConstructor]))
- Agda.Syntax.Concrete.Definitions.Types: [interleavedFunClauses] :: InterleavedDecl -> Maybe (DeclNum, List1 ([Declaration], [Clause]))
+ Agda.Syntax.Concrete.Definitions.Types: [interleavedFunClauses] :: InterleavedDecl -> Maybe (DeclNum, List1 (List1 Declaration, List1 Clause))
- Agda.Syntax.Concrete.Glyph: SpecialCharacters :: (Doc -> Doc) -> Doc -> Doc -> Doc -> Doc -> Doc -> Doc -> SpecialCharacters
+ Agda.Syntax.Concrete.Glyph: SpecialCharacters :: (Doc -> Doc) -> Doc -> Doc -> Doc -> Doc -> Doc -> Doc -> Doc -> Doc -> Doc -> Doc -> SpecialCharacters
- Agda.Syntax.Concrete.Operators.Parser.Monad: NodeK :: PrecedenceKey -> MemoKey
+ Agda.Syntax.Concrete.Operators.Parser.Monad: NodeK :: {-# UNPACK #-} !PrecedenceKey -> MemoKey
- Agda.Syntax.Concrete.Operators.Parser.Monad: PostLeftsK :: PrecedenceKey -> MemoKey
+ Agda.Syntax.Concrete.Operators.Parser.Monad: PostLeftsK :: {-# UNPACK #-} !PrecedenceKey -> MemoKey
- Agda.Syntax.Concrete.Operators.Parser.Monad: PreRightsK :: PrecedenceKey -> MemoKey
+ Agda.Syntax.Concrete.Operators.Parser.Monad: PreRightsK :: {-# UNPACK #-} !PrecedenceKey -> MemoKey
- Agda.Syntax.Concrete.Pattern: ($dmtraverseCPatternA) :: forall (f :: Type -> Type) q m. (CPatternLike p, Traversable f, CPatternLike q, f q ~ p, Applicative m, Functor m) => (Pattern -> m Pattern -> m Pattern) -> p -> m p
+ Agda.Syntax.Concrete.Pattern: ($dmtraverseCPatternA) :: forall (f :: Type -> Type) q m. (CPatternLike p, Traversable f, CPatternLike q, f q ~ p, Applicative m) => (Pattern -> m Pattern -> m Pattern) -> p -> m p
- Agda.Syntax.Concrete.Pattern: mapLhsOriginalPatternM :: (Functor m, Applicative m) => (Pattern -> m Pattern) -> LHS -> m LHS
+ Agda.Syntax.Concrete.Pattern: mapLhsOriginalPatternM :: Functor m => (Pattern -> m Pattern) -> LHS -> m LHS
- Agda.Syntax.Concrete.Pattern: traverseCPatternA :: (CPatternLike p, Applicative m, Functor m) => (Pattern -> m Pattern -> m Pattern) -> p -> m p
+ Agda.Syntax.Concrete.Pattern: traverseCPatternA :: (CPatternLike p, Applicative m) => (Pattern -> m Pattern -> m Pattern) -> p -> m p
- Agda.Syntax.Concrete.Pretty: pRecord :: Erased -> Name -> [RecordDirective] -> [LamBinding] -> Maybe Expr -> [Declaration] -> Doc
+ Agda.Syntax.Concrete.Pretty: pRecord :: Erased -> Name -> [RecordDirective] -> Parameters -> Maybe Expr -> [Declaration] -> Doc
- Agda.Syntax.Concrete.Pretty: prettyOpApp :: Pretty a => Aspect -> QName -> List1 (NamedArg (MaybePlaceholder a)) -> [Doc]
+ Agda.Syntax.Concrete.Pretty: prettyOpApp :: Pretty a => Aspects -> QName -> List1 (NamedArg (MaybePlaceholder a)) -> [Doc]
- Agda.Syntax.DoNotation: desugarDoNotation :: Range -> List1 DoStmt -> ScopeM Expr
+ Agda.Syntax.DoNotation: desugarDoNotation :: Maybe QName -> List1 DoStmt -> ScopeM Expr
- Agda.Syntax.IdiomBrackets: parseIdiomBracketsSeq :: Range -> [Expr] -> ScopeM Expr
+ Agda.Syntax.IdiomBrackets: parseIdiomBracketsSeq :: Range -> Maybe QName -> [Expr] -> ScopeM Expr
- Agda.Syntax.Info: ModuleInfo :: Range -> Range -> Maybe Name -> Maybe OpenShortHand -> Maybe ImportDirective -> ModuleInfo
+ Agda.Syntax.Info: ModuleInfo :: Range -> Range -> Maybe Name -> OpenShortHand -> Maybe ImportDirective -> ModuleInfo
- Agda.Syntax.Info: [minfoOpenShort] :: ModuleInfo -> Maybe OpenShortHand
+ Agda.Syntax.Info: [minfoOpenShort] :: ModuleInfo -> OpenShortHand
- Agda.Syntax.Internal: (:#) :: a -> Substitution' a -> Substitution' a
+ Agda.Syntax.Internal: (:#) :: a -> !Substitution' a -> Substitution' a
- Agda.Syntax.Internal: Clause :: Range -> Range -> Telescope -> NAPs -> Maybe Term -> Maybe (Arg Type) -> Catchall -> Maybe Bool -> Maybe Bool -> ExpandedEllipsis -> Maybe ModuleName -> Clause
+ Agda.Syntax.Internal: Clause :: Range -> Range -> Telescope -> NAPs -> Maybe Term -> Maybe (Arg Type) -> Catchall -> ClauseRecursive -> Maybe Bool -> ExpandedEllipsis -> Maybe ModuleName -> Clause
- Agda.Syntax.Internal: ConHead :: QName -> DataOrRecord -> Induction -> [Arg QName] -> ConHead
+ Agda.Syntax.Internal: ConHead :: QName -> DataOrRecord -> Induction -> IsHIT -> [Arg QName] -> ConHead
- Agda.Syntax.Internal: ConPatternInfo :: PatternInfo -> Bool -> Bool -> Maybe (Arg Type) -> Bool -> ConPatternInfo
+ Agda.Syntax.Internal: ConPatternInfo :: PatternInfo -> Bool -> Bool -> Maybe (Arg Type) -> Bool -> !MatchPrio -> ConPatternInfo
- Agda.Syntax.Internal: Dummy :: String -> Elims -> Term
+ Agda.Syntax.Internal: Dummy :: DummyTermKind -> Elims -> Term
- Agda.Syntax.Internal: ExtendTel :: a -> Abs (Tele a) -> Tele a
+ Agda.Syntax.Internal: ExtendTel :: a -> !Abs (Tele a) -> Tele a
- Agda.Syntax.Internal: Lift :: !Int -> Substitution' a -> Substitution' a
+ Agda.Syntax.Internal: Lift :: !Int -> !Substitution' a -> Substitution' a
- Agda.Syntax.Internal: LitP :: PatternInfo -> Literal -> Pattern' x
+ Agda.Syntax.Internal: LitP :: LitPatternInfo -> Literal -> Pattern' x
- Agda.Syntax.Internal: ProblemId :: Nat -> ProblemId
+ Agda.Syntax.Internal: ProblemId :: Word64 -> ProblemId
- Agda.Syntax.Internal: Strengthen :: Impossible -> !Int -> Substitution' a -> Substitution' a
+ Agda.Syntax.Internal: Strengthen :: Impossible -> !Int -> !Substitution' a -> Substitution' a
- Agda.Syntax.Internal: Wk :: !Int -> Substitution' a -> Substitution' a
+ Agda.Syntax.Internal: Wk :: !Int -> !Substitution' a -> Substitution' a
- Agda.Syntax.Internal: [clauseRecursive] :: Clause -> Maybe Bool
+ Agda.Syntax.Internal: [clauseRecursive] :: Clause -> ClauseRecursive
- Agda.Syntax.Internal: __DUMMY_TERM_WITH__ :: HasCallStack => DummyTermKind -> Term
+ Agda.Syntax.Internal: __DUMMY_TERM_WITH__ :: HasCallStack => String -> Term
- Agda.Syntax.Internal: dummyTermWith :: DummyTermKind -> CallStack -> Term
+ Agda.Syntax.Internal: dummyTermWith :: String -> CallStack -> Term
- Agda.Syntax.Internal.Blockers: UnblockOnAll :: Set Blocker -> Blocker
+ Agda.Syntax.Internal.Blockers: UnblockOnAll :: !Set Blocker -> Blocker
- Agda.Syntax.Internal.Blockers: UnblockOnAny :: Set Blocker -> Blocker
+ Agda.Syntax.Internal.Blockers: UnblockOnAny :: !Set Blocker -> Blocker
- Agda.Syntax.Internal.Blockers: UnblockOnDef :: QName -> Blocker
+ Agda.Syntax.Internal.Blockers: UnblockOnDef :: !QName -> Blocker
- Agda.Syntax.Internal.Blockers: UnblockOnMeta :: MetaId -> Blocker
+ Agda.Syntax.Internal.Blockers: UnblockOnMeta :: {-# UNPACK #-} !MetaId -> Blocker
- Agda.Syntax.Internal.Blockers: UnblockOnProblem :: ProblemId -> Blocker
+ Agda.Syntax.Internal.Blockers: UnblockOnProblem :: !ProblemId -> Blocker
- Agda.Syntax.Internal.Defs: getDefs :: (GetDefs a, MonadGetDefs m) => a -> m ()
+ Agda.Syntax.Internal.Defs: getDefs :: (GetDefs a, Monoid m, ExpandCase m) => (MetaId -> Maybe Term) -> (QName -> m) -> a -> m
- Agda.Syntax.Internal.Elim: Apply :: Arg a -> Elim' a
+ Agda.Syntax.Internal.Elim: Apply :: {-# UNPACK #-} !Arg a -> Elim' a
- Agda.Syntax.Parser: InvalidExtensionError :: !RangeFile -> [String] -> ParseError
+ Agda.Syntax.Parser: InvalidExtensionError :: !RangeFile -> ![String] -> ParseError
- Agda.Syntax.Parser: MisplacedAttributes :: Range -> String -> ParseWarning
+ Agda.Syntax.Parser: MisplacedAttributes :: Range -> !String -> ParseWarning
- Agda.Syntax.Parser: OverlappingTokensError :: !Range' SrcFile -> ParseError
+ Agda.Syntax.Parser: OverlappingTokensError :: !Range -> ParseError
- Agda.Syntax.Parser: ParseError :: !SrcFile -> !PositionWithoutFile -> String -> String -> String -> ParseError
+ Agda.Syntax.Parser: ParseError :: !Position -> !String -> !String -> !String -> ParseError
- Agda.Syntax.Parser: ReadFileError :: !RangeFile -> IOError -> ParseError
+ Agda.Syntax.Parser: ReadFileError :: !RangeFile -> !IOError -> ParseError
- Agda.Syntax.Parser: UnknownAttribute :: Range -> String -> ParseWarning
+ Agda.Syntax.Parser: UnknownAttribute :: Range -> !String -> ParseWarning
- Agda.Syntax.Parser: UnknownPolarity :: Range -> String -> ParseWarning
+ Agda.Syntax.Parser: UnknownPolarity :: Range -> !String -> ParseWarning
- Agda.Syntax.Parser: [errIOError] :: ParseError -> IOError
+ Agda.Syntax.Parser: [errIOError] :: ParseError -> !IOError
- Agda.Syntax.Parser: [errInput] :: ParseError -> String
+ Agda.Syntax.Parser: [errInput] :: ParseError -> !String
- Agda.Syntax.Parser: [errMsg] :: ParseError -> String
+ Agda.Syntax.Parser: [errMsg] :: ParseError -> !String
- Agda.Syntax.Parser: [errPos] :: ParseError -> !PositionWithoutFile
+ Agda.Syntax.Parser: [errPos] :: ParseError -> !Position
- Agda.Syntax.Parser: [errPrevToken] :: ParseError -> String
+ Agda.Syntax.Parser: [errPrevToken] :: ParseError -> !String
- Agda.Syntax.Parser: [errRange] :: ParseError -> !Range' SrcFile
+ Agda.Syntax.Parser: [errRange] :: ParseError -> !Range
- Agda.Syntax.Parser: [errValidExts] :: ParseError -> [String]
+ Agda.Syntax.Parser: [errValidExts] :: ParseError -> ![String]
- Agda.Syntax.Parser: parseFile :: Show a => Parser a -> RangeFile -> String -> PM ((a, Attributes), FileType)
+ Agda.Syntax.Parser: parseFile :: Bool -> Parser a -> RangeFile -> String -> PM ((a, Attributes), FileType)
- Agda.Syntax.Parser.Alex: AlexInput :: !SrcFile -> !PositionWithoutFile -> String -> !Char -> AlexInput
+ Agda.Syntax.Parser.Alex: AlexInput :: !SrcFile -> !PositionWithoutFile -> !String -> !Char -> AlexInput
- Agda.Syntax.Parser.Alex: [lexInput] :: AlexInput -> String
+ Agda.Syntax.Parser.Alex: [lexInput] :: AlexInput -> !String
- Agda.Syntax.Parser.Helpers: figureOutTopLevelModule :: [Declaration] -> [Declaration]
+ Agda.Syntax.Parser.Helpers: figureOutTopLevelModule :: [Declaration] -> Module
- Agda.Syntax.Parser.Helpers: patternToNames :: Pattern -> Parser (List1 (ArgInfo, Name))
+ Agda.Syntax.Parser.Helpers: patternToNames :: Pattern -> Parser (List1 (Arg Name))
- Agda.Syntax.Parser.Literate: literateMd :: Processor
+ Agda.Syntax.Parser.Literate: literateMd :: Bool -> Processor
- Agda.Syntax.Parser.Literate: literateProcessors :: [(String, (Processor, FileType))]
+ Agda.Syntax.Parser.Literate: literateProcessors :: Bool -> [(String, (Processor, FileType))]
- Agda.Syntax.Parser.Monad: InvalidExtensionError :: !RangeFile -> [String] -> ParseError
+ Agda.Syntax.Parser.Monad: InvalidExtensionError :: !RangeFile -> ![String] -> ParseError
- Agda.Syntax.Parser.Monad: MisplacedAttributes :: Range -> String -> ParseWarning
+ Agda.Syntax.Parser.Monad: MisplacedAttributes :: Range -> !String -> ParseWarning
- Agda.Syntax.Parser.Monad: OverlappingTokensError :: !Range' SrcFile -> ParseError
+ Agda.Syntax.Parser.Monad: OverlappingTokensError :: !Range -> ParseError
- Agda.Syntax.Parser.Monad: PState :: !SrcFile -> !PositionWithoutFile -> !PositionWithoutFile -> String -> !Char -> String -> LayoutContext -> LayoutStatus -> Keyword -> [LexState] -> ParseFlags -> ![ParseWarning] -> !Attributes -> ParseState
+ Agda.Syntax.Parser.Monad: PState :: !SrcFile -> !PositionWithoutFile -> !PositionWithoutFile -> !String -> !Char -> !String -> !LayoutContext -> !LayoutStatus -> !Keyword -> ![LexState] -> !ParseFlags -> ![ParseWarning] -> ![OpenBracket] -> !Attributes -> ParseState
- Agda.Syntax.Parser.Monad: ParseError :: !SrcFile -> !PositionWithoutFile -> String -> String -> String -> ParseError
+ Agda.Syntax.Parser.Monad: ParseError :: !Position -> !String -> !String -> !String -> ParseError
- Agda.Syntax.Parser.Monad: ParseFlags :: Bool -> ParseFlags
+ Agda.Syntax.Parser.Monad: ParseFlags :: !Bool -> ParseFlags
- Agda.Syntax.Parser.Monad: ReadFileError :: !RangeFile -> IOError -> ParseError
+ Agda.Syntax.Parser.Monad: ReadFileError :: !RangeFile -> !IOError -> ParseError
- Agda.Syntax.Parser.Monad: UnknownAttribute :: Range -> String -> ParseWarning
+ Agda.Syntax.Parser.Monad: UnknownAttribute :: Range -> !String -> ParseWarning
- Agda.Syntax.Parser.Monad: UnknownPolarity :: Range -> String -> ParseWarning
+ Agda.Syntax.Parser.Monad: UnknownPolarity :: Range -> !String -> ParseWarning
- Agda.Syntax.Parser.Monad: [errIOError] :: ParseError -> IOError
+ Agda.Syntax.Parser.Monad: [errIOError] :: ParseError -> !IOError
- Agda.Syntax.Parser.Monad: [errInput] :: ParseError -> String
+ Agda.Syntax.Parser.Monad: [errInput] :: ParseError -> !String
- Agda.Syntax.Parser.Monad: [errMsg] :: ParseError -> String
+ Agda.Syntax.Parser.Monad: [errMsg] :: ParseError -> !String
- Agda.Syntax.Parser.Monad: [errPos] :: ParseError -> !PositionWithoutFile
+ Agda.Syntax.Parser.Monad: [errPos] :: ParseError -> !Position
- Agda.Syntax.Parser.Monad: [errPrevToken] :: ParseError -> String
+ Agda.Syntax.Parser.Monad: [errPrevToken] :: ParseError -> !String
- Agda.Syntax.Parser.Monad: [errRange] :: ParseError -> !Range' SrcFile
+ Agda.Syntax.Parser.Monad: [errRange] :: ParseError -> !Range
- Agda.Syntax.Parser.Monad: [errValidExts] :: ParseError -> [String]
+ Agda.Syntax.Parser.Monad: [errValidExts] :: ParseError -> ![String]
- Agda.Syntax.Parser.Monad: [parseFlags] :: ParseState -> ParseFlags
+ Agda.Syntax.Parser.Monad: [parseFlags] :: ParseState -> !ParseFlags
- Agda.Syntax.Parser.Monad: [parseInp] :: ParseState -> String
+ Agda.Syntax.Parser.Monad: [parseInp] :: ParseState -> !String
- Agda.Syntax.Parser.Monad: [parseKeepComments] :: ParseFlags -> Bool
+ Agda.Syntax.Parser.Monad: [parseKeepComments] :: ParseFlags -> !Bool
- Agda.Syntax.Parser.Monad: [parseLayKw] :: ParseState -> Keyword
+ Agda.Syntax.Parser.Monad: [parseLayKw] :: ParseState -> !Keyword
- Agda.Syntax.Parser.Monad: [parseLayStatus] :: ParseState -> LayoutStatus
+ Agda.Syntax.Parser.Monad: [parseLayStatus] :: ParseState -> !LayoutStatus
- Agda.Syntax.Parser.Monad: [parseLayout] :: ParseState -> LayoutContext
+ Agda.Syntax.Parser.Monad: [parseLayout] :: ParseState -> !LayoutContext
- Agda.Syntax.Parser.Monad: [parseLexState] :: ParseState -> [LexState]
+ Agda.Syntax.Parser.Monad: [parseLexState] :: ParseState -> ![LexState]
- Agda.Syntax.Parser.Monad: [parsePrevToken] :: ParseState -> String
+ Agda.Syntax.Parser.Monad: [parsePrevToken] :: ParseState -> !String
- Agda.Syntax.Parser.Tokens: SymCloseIdiomBracket :: Symbol
+ Agda.Syntax.Parser.Tokens: SymCloseIdiomBracket :: Bool -> Symbol
- Agda.Syntax.Parser.Tokens: SymDoubleCloseBrace :: Symbol
+ Agda.Syntax.Parser.Tokens: SymDoubleCloseBrace :: Bool -> Symbol
- Agda.Syntax.Parser.Tokens: SymDoubleOpenBrace :: Symbol
+ Agda.Syntax.Parser.Tokens: SymDoubleOpenBrace :: Bool -> Symbol
- Agda.Syntax.Parser.Tokens: SymOpenIdiomBracket :: Symbol
+ Agda.Syntax.Parser.Tokens: SymOpenIdiomBracket :: Bool -> Symbol
- Agda.Syntax.Position: Range :: !a -> Seq IntervalWithoutFile -> Range' a
+ Agda.Syntax.Position: Range :: !a -> Seq IntervalWithoutFile' -> Range' a
- Agda.Syntax.Position: continuousPerLine :: Ord a => Range' a -> Range' a
+ Agda.Syntax.Position: continuousPerLine :: Range' a -> Range' a
- Agda.Syntax.Position: fuseRanges :: Ord a => Range' a -> Range' a -> Range' a
+ Agda.Syntax.Position: fuseRanges :: Range' a -> Range' a -> Range' a
- Agda.Syntax.Position: posToRange :: Position' a -> Position' a -> Range' a
+ Agda.Syntax.Position: posToRange :: Position' a -> Position' b -> Range' a
- Agda.Syntax.Position: rangeInvariant :: Ord a => Range' a -> Bool
+ Agda.Syntax.Position: rangeInvariant :: Range' a -> Bool
- Agda.Syntax.Scope.Base: NameMapEntry :: KindOfName -> List1 QName -> NameMapEntry
+ Agda.Syntax.Scope.Base: NameMapEntry :: !KindOfName -> !List1 QName -> NameMapEntry
- Agda.Syntax.Scope.Base: NameSpace :: NamesInScope -> ModulesInScope -> InScopeSet -> NameSpace
+ Agda.Syntax.Scope.Base: NameSpace :: NamesInScope -> NamePartsInScope -> ModulesInScope -> InScopeSet -> NameSpace
- Agda.Syntax.Scope.Base: ScopeInfo :: ModuleName -> Map ModuleName Scope -> LocalVars -> LocalVars -> !PrecedenceStack -> NameMap -> ModuleMap -> InScopeSet -> Fixities -> Polarities -> Map QName (QName, Maybe Induction) -> ScopeInfo
+ Agda.Syntax.Scope.Base: ScopeInfo :: ModuleName -> Map ModuleName Scope -> LocalVars -> LocalVars -> !PrecedenceStack -> NameMap -> ModuleMap -> InScopeSet -> Fixities -> Polarities -> ScopeInfo
- Agda.Syntax.Scope.Base: [qnameConcrete] :: NameMapEntry -> List1 QName
+ Agda.Syntax.Scope.Base: [qnameConcrete] :: NameMapEntry -> !List1 QName
- Agda.Syntax.Scope.Base: [qnameKind] :: NameMapEntry -> KindOfName
+ Agda.Syntax.Scope.Base: [qnameKind] :: NameMapEntry -> !KindOfName
- Agda.Syntax.Scope.Base: type ModuleMap = Map ModuleName [QName]
+ Agda.Syntax.Scope.Base: type ModuleMap = HashMap ModuleName [QName]
- Agda.Syntax.Scope.Base: type NameMap = Map QName NameMapEntry
+ Agda.Syntax.Scope.Base: type NameMap = HashMap NameId NameMapEntry
- Agda.Syntax.Scope.Base: zipNameSpace :: (NamesInScope -> NamesInScope -> NamesInScope) -> (ModulesInScope -> ModulesInScope -> ModulesInScope) -> (InScopeSet -> InScopeSet -> InScopeSet) -> NameSpace -> NameSpace -> NameSpace
+ Agda.Syntax.Scope.Base: zipNameSpace :: (NamesInScope -> NamesInScope -> NamesInScope) -> (NamePartsInScope -> NamePartsInScope -> NamePartsInScope) -> (ModulesInScope -> ModulesInScope -> ModulesInScope) -> (InScopeSet -> InScopeSet -> InScopeSet) -> NameSpace -> NameSpace -> NameSpace
- Agda.Syntax.Scope.Base: zipScope :: (NameSpaceId -> NamesInScope -> NamesInScope -> NamesInScope) -> (NameSpaceId -> ModulesInScope -> ModulesInScope -> ModulesInScope) -> (NameSpaceId -> InScopeSet -> InScopeSet -> InScopeSet) -> Scope -> Scope -> Scope
+ Agda.Syntax.Scope.Base: zipScope :: (NameSpaceId -> NamesInScope -> NamesInScope -> NamesInScope) -> (NameSpaceId -> NamePartsInScope -> NamePartsInScope -> NamePartsInScope) -> (NameSpaceId -> ModulesInScope -> ModulesInScope -> ModulesInScope) -> (NameSpaceId -> InScopeSet -> InScopeSet -> InScopeSet) -> Scope -> Scope -> Scope
- Agda.Syntax.Scope.Base: zipScope_ :: (NamesInScope -> NamesInScope -> NamesInScope) -> (ModulesInScope -> ModulesInScope -> ModulesInScope) -> (InScopeSet -> InScopeSet -> InScopeSet) -> Scope -> Scope -> Scope
+ Agda.Syntax.Scope.Base: zipScope_ :: (NamesInScope -> NamesInScope -> NamesInScope) -> (NamePartsInScope -> NamePartsInScope -> NamePartsInScope) -> (ModulesInScope -> ModulesInScope -> ModulesInScope) -> (InScopeSet -> InScopeSet -> InScopeSet) -> Scope -> Scope -> Scope
- Agda.Syntax.Scope.Monad: annotateDecls :: ReadTCState m => m [Declaration] -> m Declaration
+ Agda.Syntax.Scope.Monad: annotateDecls :: ReadTCState m => m [Declaration] -> m (Maybe Declaration)
- Agda.Syntax.Scope.Monad: openModule :: OpenKind -> Maybe ModuleName -> QName -> ImportDirective -> ScopeM ImportDirective
+ Agda.Syntax.Scope.Monad: openModule :: KwRange -> OpenKind -> Maybe ModuleName -> QName -> ImportDirective -> ScopeM ImportDirective
- Agda.Syntax.Scope.Monad: openModule_ :: OpenKind -> QName -> ImportDirective -> ScopeM ImportDirective
+ Agda.Syntax.Scope.Monad: openModule_ :: KwRange -> OpenKind -> QName -> ImportDirective -> ScopeM ImportDirective
- Agda.Syntax.Scope.Monad: rebindName :: Access -> KindOfName -> Name -> QName -> ScopeM ()
+ Agda.Syntax.Scope.Monad: rebindName :: Access -> KindOfName -> NameMetadata -> Name -> QName -> ScopeM ()
- Agda.Syntax.Translation.AbstractToConcrete: type MonadAbsToCon (m :: Type -> Type) = (MonadFresh NameId m, MonadInteractionPoints m, MonadStConcreteNames m, HasOptions m, PureTCM m, IsString m Doc, Null m Doc, Semigroup m Doc)
+ Agda.Syntax.Translation.AbstractToConcrete: type MonadAbsToCon (m :: Type -> Type) = (MonadFileId m, MonadFresh NameId m, MonadInteractionPoints m, MonadStConcreteNames m, HasOptions m, PureTCM m, IsString m Doc, Null m Doc, Semigroup m Doc)
- Agda.Syntax.Translation.ReflectedToAbstract: toAbstractWithoutImplicit :: (ToAbstract r, MonadFresh NameId m, MonadError TCErr m, MonadTCEnv m, ReadTCState m, HasOptions m, HasBuiltins m, HasConstInfo m) => r -> m (AbsOfRef r)
+ Agda.Syntax.Translation.ReflectedToAbstract: toAbstractWithoutImplicit :: (ToAbstract r, MonadFresh NameId m, MonadError TCErr m, ReadTCState m, HasBuiltins m, HasConstInfo m) => r -> m (AbsOfRef r)
- Agda.Syntax.Translation.ReflectedToAbstract: toAbstract_ :: (ToAbstract r, MonadFresh NameId m, MonadError TCErr m, MonadTCEnv m, ReadTCState m, HasOptions m, HasBuiltins m, HasConstInfo m) => r -> m (AbsOfRef r)
+ Agda.Syntax.Translation.ReflectedToAbstract: toAbstract_ :: (ToAbstract r, MonadFresh NameId m, MonadError TCErr m, ReadTCState m, HasBuiltins m, HasConstInfo m) => r -> m (AbsOfRef r)
- Agda.Syntax.Treeless: CaseInfo :: Bool -> Erased -> CaseType -> CaseInfo
+ Agda.Syntax.Treeless: CaseInfo :: Bool -> !Induction -> Erased -> CaseType -> CaseInfo
- Agda.Syntax.Treeless: LazyEvaluation :: EvaluationStrategy
+ Agda.Syntax.Treeless: LazyEvaluation :: !Strictness -> EvaluationStrategy
- Agda.Syntax.Treeless: TLet :: TTerm -> TTerm -> TTerm
+ Agda.Syntax.Treeless: TLet :: Strictness -> TTerm -> TTerm -> TTerm
- Agda.Syntax.Treeless: mkLet :: TTerm -> TTerm -> TTerm
+ Agda.Syntax.Treeless: mkLet :: Strictness -> TTerm -> TTerm -> TTerm
- Agda.Syntax.Treeless: tLetView :: TTerm -> ([TTerm], TTerm)
+ Agda.Syntax.Treeless: tLetView :: TTerm -> ([(Strictness, TTerm)], TTerm)
- Agda.Termination.CallGraph: complete :: (?cutoff :: CutOff, Monoid cinfo) => CallGraph cinfo -> CallGraph cinfo
+ Agda.Termination.CallGraph: complete :: (Monoid cinfo, ?cutoff :: CutOff) => CallGraph cinfo -> CallGraph cinfo
- Agda.Termination.CallGraph: completionStep :: (?cutoff :: CutOff, Monoid cinfo) => CallGraph cinfo -> CallGraph cinfo -> (CallGraph cinfo, CallGraph cinfo)
+ Agda.Termination.CallGraph: completionStep :: (Monoid cinfo, ?cutoff :: CutOff) => CallGraph cinfo -> CallGraph cinfo -> (CallGraph cinfo, CallGraph cinfo)
- Agda.Termination.Monad: CallPath :: DList CallInfo -> CallPath
+ Agda.Termination.Monad: CallPath :: QName -> BinTree CallInfo -> CallPath
- Agda.Termination.Monad: TerEnv :: Bool -> Maybe QName -> Maybe QName -> CutOff -> QName -> MutualNames -> Set QName -> Bool -> Target -> [Bool] -> Bool -> Int -> MaskedDeBruijnPatterns -> !Int -> !Guarded -> Bool -> VarSet -> TerEnv
+ Agda.Termination.Monad: TerEnv :: !Maybe QName -> !Maybe QName -> !CutOff -> QName -> MutualNames -> Set QName -> !Bool -> !Target -> !ListInf Bool -> !Bool -> Int -> MaskedDeBruijnPatterns -> !Int -> !Guarded -> !Bool -> !VarSet -> !Map (QName, [QName]) Node -> !IntMap QName -> !Map QName [[QName]] -> !Map (QName, [QName]) (ListInf Bool) -> TerEnv
- Agda.Termination.Monad: [terCutOff] :: TerEnv -> CutOff
+ Agda.Termination.Monad: [terCutOff] :: TerEnv -> !CutOff
- Agda.Termination.Monad: [terHaveInlinedWith] :: TerEnv -> Bool
+ Agda.Termination.Monad: [terHaveInlinedWith] :: TerEnv -> !Bool
- Agda.Termination.Monad: [terMaskArgs] :: TerEnv -> [Bool]
+ Agda.Termination.Monad: [terMaskArgs] :: TerEnv -> !ListInf Bool
- Agda.Termination.Monad: [terMaskResult] :: TerEnv -> Bool
+ Agda.Termination.Monad: [terMaskResult] :: TerEnv -> !Bool
- Agda.Termination.Monad: [terSharp] :: TerEnv -> Maybe QName
+ Agda.Termination.Monad: [terSharp] :: TerEnv -> !Maybe QName
- Agda.Termination.Monad: [terSizeSuc] :: TerEnv -> Maybe QName
+ Agda.Termination.Monad: [terSizeSuc] :: TerEnv -> !Maybe QName
- Agda.Termination.Monad: [terTarget] :: TerEnv -> Target
+ Agda.Termination.Monad: [terTarget] :: TerEnv -> !Target
- Agda.Termination.Monad: [terUsableVars] :: TerEnv -> VarSet
+ Agda.Termination.Monad: [terUsableVars] :: TerEnv -> !VarSet
- Agda.Termination.Monad: [terUseSizeLt] :: TerEnv -> Bool
+ Agda.Termination.Monad: [terUseSizeLt] :: TerEnv -> !Bool
- Agda.Termination.Monad: terGetMaskArgs :: TerM [Bool]
+ Agda.Termination.Monad: terGetMaskArgs :: TerM (ListInf Bool)
- Agda.Termination.Monad: terSetMaskArgs :: [Bool] -> TerM a -> TerM a
+ Agda.Termination.Monad: terSetMaskArgs :: ListInf Bool -> TerM a -> TerM a
- Agda.Termination.RecCheck: anyDefs :: GetDefs a => (QName -> Bool) -> a -> TCM (Set QName)
+ Agda.Termination.RecCheck: anyDefs :: GetDefs a => Set QName -> a -> TCM (Set QName)
- Agda.Termination.Termination: terminatesFilter :: (Monoid cinfo, ?cutoff :: CutOff) => (Node -> Bool) -> CallGraph cinfo -> Terminates cinfo
+ Agda.Termination.Termination: terminatesFilter :: (Monoid cinfo, ?cutoff :: CutOff) => Bool -> (Node -> Bool) -> CallGraph cinfo -> Terminates cinfo
- Agda.TypeChecking.CheckInternal: Action :: (Type -> Term -> m Term) -> (Type -> Term -> m Term) -> (Modality -> Modality -> Modality) -> (Term -> m Term) -> Action (m :: Type -> Type)
+ Agda.TypeChecking.CheckInternal: Action :: (Type -> Term -> TCM Term) -> (Type -> Term -> TCM Term) -> (Modality -> Modality -> Modality) -> (Term -> TCM Term) -> Action
- Agda.TypeChecking.CheckInternal: [elimViewAction] :: Action (m :: Type -> Type) -> Term -> m Term
+ Agda.TypeChecking.CheckInternal: [elimViewAction] :: Action -> Term -> TCM Term
- Agda.TypeChecking.CheckInternal: [modalityAction] :: Action (m :: Type -> Type) -> Modality -> Modality -> Modality
+ Agda.TypeChecking.CheckInternal: [modalityAction] :: Action -> Modality -> Modality -> Modality
- Agda.TypeChecking.CheckInternal: [postAction] :: Action (m :: Type -> Type) -> Type -> Term -> m Term
+ Agda.TypeChecking.CheckInternal: [postAction] :: Action -> Type -> Term -> TCM Term
- Agda.TypeChecking.CheckInternal: [preAction] :: Action (m :: Type -> Type) -> Type -> Term -> m Term
+ Agda.TypeChecking.CheckInternal: [preAction] :: Action -> Type -> Term -> TCM Term
- Agda.TypeChecking.CheckInternal: checkInternal :: (CheckInternal a, MonadCheckInternal m) => a -> Comparison -> TypeOf a -> m ()
+ Agda.TypeChecking.CheckInternal: checkInternal :: CheckInternal a => a -> Comparison -> TypeOf a -> TCM ()
- Agda.TypeChecking.CheckInternal: checkInternal' :: (CheckInternal a, MonadCheckInternal m) => Action m -> a -> Comparison -> TypeOf a -> m a
+ Agda.TypeChecking.CheckInternal: checkInternal' :: CheckInternal a => Action -> a -> Comparison -> TypeOf a -> TCM a
- Agda.TypeChecking.CheckInternal: checkType :: MonadCheckInternal m => Type -> m ()
+ Agda.TypeChecking.CheckInternal: checkType :: Type -> TCM ()
- Agda.TypeChecking.CheckInternal: data Action (m :: Type -> Type)
+ Agda.TypeChecking.CheckInternal: data Action
- Agda.TypeChecking.CheckInternal: defaultAction :: forall (m :: Type -> Type). PureTCM m => Action m
+ Agda.TypeChecking.CheckInternal: defaultAction :: Action
- Agda.TypeChecking.CheckInternal: eraseUnusedAction :: Action TCM
+ Agda.TypeChecking.CheckInternal: eraseUnusedAction :: Action
- Agda.TypeChecking.CheckInternal: infer :: MonadCheckInternal m => Term -> m Type
+ Agda.TypeChecking.CheckInternal: infer :: Term -> TCM Type
- Agda.TypeChecking.CheckInternal: inferInternal :: (CheckInternal a, MonadCheckInternal m, TypeOf a ~ ()) => a -> m ()
+ Agda.TypeChecking.CheckInternal: inferInternal :: CheckInternal a => a -> TCM ()
- Agda.TypeChecking.CheckInternal: inferInternal' :: (CheckInternal a, MonadCheckInternal m, TypeOf a ~ ()) => Action m -> a -> m a
+ Agda.TypeChecking.CheckInternal: inferInternal' :: CheckInternal a => Action -> a -> TCM a
- Agda.TypeChecking.CheckInternal: inferSpine :: MonadCheckInternal m => Action m -> Type -> (Elims -> Term) -> Elims -> m (Type, Elims)
+ Agda.TypeChecking.CheckInternal: inferSpine :: Action -> Type -> (Elims -> Term) -> Elims -> TCM (Type, Elims, Term)
- Agda.TypeChecking.CompiledClause: Branches :: Bool -> Map QName (WithArity c) -> Maybe (ConHead, WithArity c) -> Map Literal c -> Maybe c -> Maybe Bool -> Bool -> Case c
+ Agda.TypeChecking.CompiledClause: Branches :: !Bool -> !Map QName (WithArity c) -> !Maybe (ConHead, WithArity c) -> !Map Literal c -> !Maybe c -> !Maybe Bool -> !Bool -> Case c
- Agda.TypeChecking.CompiledClause: Case :: Arg Int -> Case (CompiledClauses' a) -> CompiledClauses' a
+ Agda.TypeChecking.CompiledClause: Case :: !Arg Int -> !Case (CompiledClauses' a) -> CompiledClauses' a
- Agda.TypeChecking.CompiledClause: Fail :: [Arg ArgName] -> CompiledClauses' a
+ Agda.TypeChecking.CompiledClause: Fail :: ![Arg ArgName] -> CompiledClauses' a
- Agda.TypeChecking.CompiledClause: [catchallBranch] :: Case c -> Maybe c
+ Agda.TypeChecking.CompiledClause: [catchallBranch] :: Case c -> !Maybe c
- Agda.TypeChecking.CompiledClause: [conBranches] :: Case c -> Map QName (WithArity c)
+ Agda.TypeChecking.CompiledClause: [conBranches] :: Case c -> !Map QName (WithArity c)
- Agda.TypeChecking.CompiledClause: [etaBranch] :: Case c -> Maybe (ConHead, WithArity c)
+ Agda.TypeChecking.CompiledClause: [etaBranch] :: Case c -> !Maybe (ConHead, WithArity c)
- Agda.TypeChecking.CompiledClause: [fallThrough] :: Case c -> Maybe Bool
+ Agda.TypeChecking.CompiledClause: [fallThrough] :: Case c -> !Maybe Bool
- Agda.TypeChecking.CompiledClause: [lazyMatch] :: Case c -> Bool
+ Agda.TypeChecking.CompiledClause: [lazyMatch] :: Case c -> !Bool
- Agda.TypeChecking.CompiledClause: [litBranches] :: Case c -> Map Literal c
+ Agda.TypeChecking.CompiledClause: [litBranches] :: Case c -> !Map Literal c
- Agda.TypeChecking.CompiledClause: [projPatterns] :: Case c -> Bool
+ Agda.TypeChecking.CompiledClause: [projPatterns] :: Case c -> !Bool
- Agda.TypeChecking.CompiledClause.Compile: Cl :: [Arg Pattern] -> Maybe Term -> Cl
+ Agda.TypeChecking.CompiledClause.Compile: Cl :: ClauseNumber -> ClauseRecursive -> ![Arg Pattern] -> Maybe Term -> Cl
- Agda.TypeChecking.CompiledClause.Compile: [clPats] :: Cl -> [Arg Pattern]
+ Agda.TypeChecking.CompiledClause.Compile: [clPats] :: Cl -> ![Arg Pattern]
- Agda.TypeChecking.CompiledClause.Compile: nextSplit :: Cls -> Maybe (Bool, Arg Int)
+ Agda.TypeChecking.CompiledClause.Compile: nextSplit :: Cl -> Cls -> Maybe (Bool, Arg Int)
- Agda.TypeChecking.CompiledClause.Compile: unBruijn :: Clause -> Cl
+ Agda.TypeChecking.CompiledClause.Compile: unBruijn :: (ClauseNumber, Clause) -> Cl
- Agda.TypeChecking.Constraints: noConstraints :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m) => m a -> m a
+ Agda.TypeChecking.Constraints: noConstraints :: (MonadConstraint m, MonadWarning m, MonadFresh ProblemId m) => m a -> m a
- Agda.TypeChecking.Constraints: noConstraints' :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m) => Bool -> m a -> m a
+ Agda.TypeChecking.Constraints: noConstraints' :: (MonadConstraint m, MonadWarning m, MonadFresh ProblemId m) => Bool -> m a -> m a
- Agda.TypeChecking.Constraints: nonConstraining :: (HasOptions m, MonadConstraint m, MonadDebug m, MonadError TCErr m, MonadFresh ProblemId m, MonadTCEnv m, MonadWarning m) => m a -> m a
+ Agda.TypeChecking.Constraints: nonConstraining :: (MonadConstraint m, MonadFresh ProblemId m, MonadWarning m) => m a -> m a
- Agda.TypeChecking.Constraints: reallyNoConstraints :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m) => m a -> m a
+ Agda.TypeChecking.Constraints: reallyNoConstraints :: (MonadConstraint m, MonadWarning m, MonadFresh ProblemId m) => m a -> m a
- Agda.TypeChecking.Conversion: antiUnify :: MonadConversion m => ProblemId -> Type -> Term -> Term -> m Term
+ Agda.TypeChecking.Conversion: antiUnify :: ProblemId -> Type -> Term -> Term -> TCM Term
- Agda.TypeChecking.Conversion: antiUnifyArgs :: MonadConversion m => ProblemId -> Dom Type -> Arg Term -> Arg Term -> m (Arg Term)
+ Agda.TypeChecking.Conversion: antiUnifyArgs :: ProblemId -> Dom Type -> Arg Term -> Arg Term -> TCM (Arg Term)
- Agda.TypeChecking.Conversion: antiUnifyElims :: MonadConversion m => ProblemId -> Type -> Term -> Elims -> Elims -> m Term
+ Agda.TypeChecking.Conversion: antiUnifyElims :: ProblemId -> Type -> Term -> Elims -> Elims -> TCM Term
- Agda.TypeChecking.Conversion: antiUnifyType :: MonadConversion m => ProblemId -> Type -> Type -> m Type
+ Agda.TypeChecking.Conversion: antiUnifyType :: ProblemId -> Type -> Type -> TCM Type
- Agda.TypeChecking.Conversion: assignE :: MonadConversion m => CompareDirection -> MetaId -> Elims -> Term -> CompareAs -> (Term -> Term -> m ()) -> m ()
+ Agda.TypeChecking.Conversion: assignE :: CompareDirection -> MetaId -> Elims -> Term -> CompareAs -> (Term -> Term -> TCM ()) -> TCM ()
- Agda.TypeChecking.Conversion: bothAbsurd :: MonadConversion m => QName -> QName -> m Bool
+ Agda.TypeChecking.Conversion: bothAbsurd :: QName -> QName -> TCM Bool
- Agda.TypeChecking.Conversion: coerce :: (MonadConversion m, MonadTCM m) => Comparison -> Term -> Type -> Type -> m Term
+ Agda.TypeChecking.Conversion: coerce :: Comparison -> Term -> Type -> Type -> TCM Term
- Agda.TypeChecking.Conversion: coerceSize :: MonadConversion m => (Type -> Type -> m ()) -> Term -> Type -> Type -> m ()
+ Agda.TypeChecking.Conversion: coerceSize :: Comparison -> Term -> Type -> Type -> TCM ()
- Agda.TypeChecking.Conversion: compareArgs :: MonadConversion m => [Polarity] -> [IsForced] -> Type -> Term -> Args -> Args -> m ()
+ Agda.TypeChecking.Conversion: compareArgs :: [Polarity] -> [IsForced] -> Type -> Term -> Args -> Args -> TCM ()
- Agda.TypeChecking.Conversion: compareAs :: MonadConversion m => Comparison -> CompareAs -> Term -> Term -> m ()
+ Agda.TypeChecking.Conversion: compareAs :: Comparison -> CompareAs -> Term -> Term -> TCM ()
- Agda.TypeChecking.Conversion: compareAs' :: MonadConversion m => Comparison -> CompareAs -> Term -> Term -> m ()
+ Agda.TypeChecking.Conversion: compareAs' :: Comparison -> CompareAs -> Term -> Term -> TCM ()
- Agda.TypeChecking.Conversion: compareAsDir :: MonadConversion m => CompareDirection -> CompareAs -> Term -> Term -> m ()
+ Agda.TypeChecking.Conversion: compareAsDir :: CompareDirection -> CompareAs -> Term -> Term -> TCM ()
- Agda.TypeChecking.Conversion: compareAtom :: MonadConversion m => Comparison -> CompareAs -> Term -> Term -> m ()
+ Agda.TypeChecking.Conversion: compareAtom :: Comparison -> CompareAs -> Term -> Term -> TCM ()
- Agda.TypeChecking.Conversion: compareAtomDir :: MonadConversion m => CompareDirection -> CompareAs -> Term -> Term -> m ()
+ Agda.TypeChecking.Conversion: compareAtomDir :: CompareDirection -> CompareAs -> Term -> Term -> TCM ()
- Agda.TypeChecking.Conversion: compareDom :: (MonadConversion m, Free c) => Comparison -> Dom Type -> Dom Type -> Abs b -> Abs c -> m () -> m () -> m () -> m () -> m () -> m () -> m () -> m ()
+ Agda.TypeChecking.Conversion: compareDom :: Comparison -> Dom Type -> Dom Type -> Abs Type -> Abs Type -> TCM () -> TCM () -> TCM ()
- Agda.TypeChecking.Conversion: compareElims :: MonadConversion m => [Polarity] -> [IsForced] -> Type -> Term -> [Elim] -> [Elim] -> m ()
+ Agda.TypeChecking.Conversion: compareElims :: [Polarity] -> [IsForced] -> Type -> Term -> [Elim] -> [Elim] -> TCM ()
- Agda.TypeChecking.Conversion: compareInterval :: MonadConversion m => Comparison -> Type -> Term -> Term -> m ()
+ Agda.TypeChecking.Conversion: compareInterval :: Comparison -> Type -> Term -> Term -> TCM ()
- Agda.TypeChecking.Conversion: compareIrrelevant :: MonadConversion m => Type -> Term -> Term -> m ()
+ Agda.TypeChecking.Conversion: compareIrrelevant :: Type -> Term -> Term -> TCM ()
- Agda.TypeChecking.Conversion: compareLevel :: MonadConversion m => Comparison -> Level -> Level -> m ()
+ Agda.TypeChecking.Conversion: compareLevel :: Comparison -> Level -> Level -> TCM ()
- Agda.TypeChecking.Conversion: compareMetas :: MonadConversion m => Comparison -> CompareAs -> MetaId -> Elims -> MetaId -> Elims -> m ()
+ Agda.TypeChecking.Conversion: compareMetas :: Comparison -> CompareAs -> MetaId -> Elims -> MetaId -> Elims -> TCM ()
- Agda.TypeChecking.Conversion: compareSort :: MonadConversion m => Comparison -> Sort -> Sort -> m ()
+ Agda.TypeChecking.Conversion: compareSort :: Comparison -> Sort -> Sort -> TCM ()
- Agda.TypeChecking.Conversion: compareTerm :: MonadConversion m => Comparison -> Type -> Term -> Term -> m ()
+ Agda.TypeChecking.Conversion: compareTerm :: Comparison -> Type -> Term -> Term -> TCM ()
- Agda.TypeChecking.Conversion: compareTerm' :: MonadConversion m => Comparison -> Type -> Term -> Term -> m ()
+ Agda.TypeChecking.Conversion: compareTerm' :: Comparison -> Type -> Term -> Term -> TCM ()
- Agda.TypeChecking.Conversion: compareTermOnFace :: MonadConversion m => Comparison -> Term -> Type -> Term -> Term -> m ()
+ Agda.TypeChecking.Conversion: compareTermOnFace :: Comparison -> Term -> Type -> Term -> Term -> TCM ()
- Agda.TypeChecking.Conversion: compareTermOnFace' :: MonadConversion m => (Substitution -> Comparison -> Type -> Term -> Term -> m ()) -> Comparison -> Term -> Type -> Term -> Term -> m ()
+ Agda.TypeChecking.Conversion: compareTermOnFace' :: (Substitution -> Comparison -> Type -> Term -> Term -> TCM ()) -> Comparison -> Term -> Type -> Term -> Term -> TCM ()
- Agda.TypeChecking.Conversion: compareType :: MonadConversion m => Comparison -> Type -> Type -> m ()
+ Agda.TypeChecking.Conversion: compareType :: Comparison -> Type -> Type -> TCM ()
- Agda.TypeChecking.Conversion: compareWithPol :: MonadConversion m => Polarity -> (Comparison -> a -> a -> m ()) -> a -> a -> m ()
+ Agda.TypeChecking.Conversion: compareWithPol :: Polarity -> (Comparison -> a -> a -> TCM ()) -> a -> a -> TCM ()
- Agda.TypeChecking.Conversion: computeElimHeadType :: MonadConversion m => QName -> Elims -> Elims -> m Type
+ Agda.TypeChecking.Conversion: computeElimHeadType :: QName -> Elims -> Elims -> TCM Type
- Agda.TypeChecking.Conversion: equalAtom :: MonadConversion m => CompareAs -> Term -> Term -> m ()
+ Agda.TypeChecking.Conversion: equalAtom :: CompareAs -> Term -> Term -> TCM ()
- Agda.TypeChecking.Conversion: equalLevel :: MonadConversion m => Level -> Level -> m ()
+ Agda.TypeChecking.Conversion: equalLevel :: Level -> Level -> TCM ()
- Agda.TypeChecking.Conversion: equalSort :: MonadConversion m => Sort -> Sort -> m ()
+ Agda.TypeChecking.Conversion: equalSort :: Sort -> Sort -> TCM ()
- Agda.TypeChecking.Conversion: equalTerm :: MonadConversion m => Type -> Term -> Term -> m ()
+ Agda.TypeChecking.Conversion: equalTerm :: Type -> Term -> Term -> TCM ()
- Agda.TypeChecking.Conversion: equalTermOnFace :: MonadConversion m => Term -> Type -> Term -> Term -> m ()
+ Agda.TypeChecking.Conversion: equalTermOnFace :: Term -> Type -> Term -> Term -> TCM ()
- Agda.TypeChecking.Conversion: equalType :: MonadConversion m => Type -> Type -> m ()
+ Agda.TypeChecking.Conversion: equalType :: Type -> Type -> TCM ()
- Agda.TypeChecking.Conversion: forallFaceMaps :: MonadConversion m => Term -> (IntMap Bool -> Blocker -> Term -> m a) -> (IntMap Bool -> Substitution -> m a) -> m [a]
+ Agda.TypeChecking.Conversion: forallFaceMaps :: Term -> (IntMap Bool -> Blocker -> Term -> TCM a) -> (IntMap Bool -> Substitution -> TCM a) -> TCM [a]
- Agda.TypeChecking.Conversion: guardPointerEquality :: MonadConversion m => a -> a -> String -> m () -> m ()
+ Agda.TypeChecking.Conversion: guardPointerEquality :: a -> a -> String -> TCM () -> TCM ()
- Agda.TypeChecking.Conversion: leqConj :: MonadConversion m => Conj -> Conj -> m Bool
+ Agda.TypeChecking.Conversion: leqConj :: Conj -> Conj -> TCM Bool
- Agda.TypeChecking.Conversion: leqInterval :: MonadConversion m => [Conj] -> [Conj] -> m Bool
+ Agda.TypeChecking.Conversion: leqInterval :: [Conj] -> [Conj] -> TCM Bool
- Agda.TypeChecking.Conversion: leqLevel :: MonadConversion m => Level -> Level -> m ()
+ Agda.TypeChecking.Conversion: leqLevel :: Level -> Level -> TCM ()
- Agda.TypeChecking.Conversion: leqSort :: MonadConversion m => Sort -> Sort -> m ()
+ Agda.TypeChecking.Conversion: leqSort :: Sort -> Sort -> TCM ()
- Agda.TypeChecking.Conversion: leqType :: MonadConversion m => Type -> Type -> m ()
+ Agda.TypeChecking.Conversion: leqType :: Type -> Type -> TCM ()
- Agda.TypeChecking.Conversion: tryConversion :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m) => m () -> m Bool
+ Agda.TypeChecking.Conversion: tryConversion :: TCM () -> TCM Bool
- Agda.TypeChecking.Conversion: tryConversion' :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m) => m a -> m (Maybe a)
+ Agda.TypeChecking.Conversion: tryConversion' :: TCM a -> TCM (Maybe a)
- Agda.TypeChecking.Conversion.Pure: pureCompareAs :: (PureTCM m, MonadBlock m) => Comparison -> CompareAs -> Term -> Term -> m Bool
+ Agda.TypeChecking.Conversion.Pure: pureCompareAs :: Comparison -> CompareAs -> Term -> Term -> TCM Bool
- Agda.TypeChecking.Conversion.Pure: pureEqualTerm :: (PureTCM m, MonadBlock m) => Type -> Term -> Term -> m Bool
+ Agda.TypeChecking.Conversion.Pure: pureEqualTerm :: Type -> Term -> Term -> TCM Bool
- Agda.TypeChecking.Conversion.Pure: runPureConversion :: (MonadBlock m, PureTCM m) => PureConversionT m a -> m (Maybe a)
+ Agda.TypeChecking.Conversion.Pure: runPureConversion :: TCM a -> TCM a
- Agda.TypeChecking.Datatypes: consOfHIT :: HasConstInfo m => QName -> m Bool
+ Agda.TypeChecking.Datatypes: consOfHIT :: (HasCallStack, HasConstInfo m) => QName -> m Bool
- Agda.TypeChecking.Datatypes: getConForm :: QName -> TCM (Either SigError ConHead)
+ Agda.TypeChecking.Datatypes: getConForm :: HasCallStack => QName -> TCM (Either SigError ConHead)
- Agda.TypeChecking.Datatypes: getConHead :: HasConstInfo m => QName -> m (Either SigError ConHead)
+ Agda.TypeChecking.Datatypes: getConHead :: (HasCallStack, HasConstInfo m) => QName -> m (Either SigError ConHead)
- Agda.TypeChecking.Datatypes: getConstructorData :: HasConstInfo m => QName -> m QName
+ Agda.TypeChecking.Datatypes: getConstructorData :: (HasCallStack, HasConstInfo m) => QName -> m QName
- Agda.TypeChecking.Datatypes: getConstructorInfo :: HasConstInfo m => QName -> m ConstructorInfo
+ Agda.TypeChecking.Datatypes: getConstructorInfo :: (HasCallStack, HasConstInfo m) => QName -> m ConstructorInfo
- Agda.TypeChecking.Datatypes: getConstructorInfo' :: HasConstInfo m => QName -> m (Maybe ConstructorInfo)
+ Agda.TypeChecking.Datatypes: getConstructorInfo' :: (HasCallStack, HasConstInfo m) => QName -> m (Maybe ConstructorInfo)
- Agda.TypeChecking.Datatypes: getDatatypeArgs :: HasConstInfo m => Type -> m (Maybe (QName, Args, Args))
+ Agda.TypeChecking.Datatypes: getDatatypeArgs :: (HasCallStack, HasConstInfo m) => Type -> m (Maybe (QName, Args, Args))
- Agda.TypeChecking.Datatypes: getNumberOfParameters :: HasConstInfo m => QName -> m (Maybe Nat)
+ Agda.TypeChecking.Datatypes: getNumberOfParameters :: (HasCallStack, HasConstInfo m) => QName -> m (Maybe Nat)
- Agda.TypeChecking.Datatypes: getOrigConHead :: QName -> TCM (Either SigError ConHead)
+ Agda.TypeChecking.Datatypes: getOrigConHead :: HasCallStack => QName -> TCM ConHead
- Agda.TypeChecking.Datatypes: isConstructor :: HasConstInfo m => QName -> m Bool
+ Agda.TypeChecking.Datatypes: isConstructor :: (HasCallStack, HasConstInfo m) => QName -> m Bool
- Agda.TypeChecking.Datatypes: isPathCons :: HasConstInfo m => QName -> m Bool
+ Agda.TypeChecking.Datatypes: isPathCons :: (HasCallStack, HasConstInfo m) => QName -> m Bool
- Agda.TypeChecking.Empty: ensureEmptyType :: Range -> Type -> TCM ()
+ Agda.TypeChecking.Empty: ensureEmptyType :: Range -> Dom Type -> TCM ()
- Agda.TypeChecking.Empty: isEmptyType :: MonadTCM tcm => Type -> tcm Bool
+ Agda.TypeChecking.Empty: isEmptyType :: MonadTCM tcm => Dom Type -> tcm Bool
- Agda.TypeChecking.Errors: getAllUnsolvedWarnings :: (ReadTCState m, MonadWarning m, MonadTCM m) => m [TCWarning]
+ Agda.TypeChecking.Errors: getAllUnsolvedWarnings :: (MonadWarning m, MonadTCM m) => m [TCWarning]
- Agda.TypeChecking.Errors: getAllWarnings :: (ReadTCState m, MonadWarning m, MonadTCM m) => WhichWarnings -> m (Set TCWarning)
+ Agda.TypeChecking.Errors: getAllWarnings :: (MonadWarning m, MonadTCM m) => WhichWarnings -> m (Set TCWarning)
- Agda.TypeChecking.Errors: getAllWarningsPreserving :: (ReadTCState m, MonadWarning m, MonadTCM m) => Set WarningName -> WhichWarnings -> m (Set TCWarning)
+ Agda.TypeChecking.Errors: getAllWarningsPreserving :: (MonadWarning m, MonadTCM m) => Set WarningName -> WhichWarnings -> m (Set TCWarning)
- Agda.TypeChecking.Errors: tcWarningsToError :: [TCWarning] -> TCM ()
+ Agda.TypeChecking.Errors: tcWarningsToError :: TopLevelModuleNameWithSourceFile -> [TCWarning] -> TCM ()
- Agda.TypeChecking.EtaContract: etaCon :: (MonadTCEnv m, HasConstInfo m, HasOptions m) => ConHead -> ConInfo -> Elims -> (QName -> ConHead -> ConInfo -> Args -> m Term) -> m Term
+ Agda.TypeChecking.EtaContract: etaCon :: HasConstInfo m => ConHead -> ConInfo -> Elims -> (QName -> ConHead -> ConInfo -> Args -> m Term) -> m Term
- Agda.TypeChecking.EtaContract: etaContract :: (MonadTCEnv m, HasConstInfo m, HasOptions m, TermLike a) => a -> m a
+ Agda.TypeChecking.EtaContract: etaContract :: (HasConstInfo m, TermLike a) => a -> m a
- Agda.TypeChecking.EtaContract: etaLam :: (MonadTCEnv m, HasConstInfo m, HasOptions m) => ArgInfo -> ArgName -> Term -> m Term
+ Agda.TypeChecking.EtaContract: etaLam :: (MonadTCEnv m, HasOptions m) => ArgInfo -> ArgName -> Term -> m Term
- Agda.TypeChecking.EtaContract: etaOnce :: (MonadTCEnv m, HasConstInfo m, HasOptions m) => Term -> m Term
+ Agda.TypeChecking.EtaContract: etaOnce :: HasConstInfo m => Term -> m Term
- Agda.TypeChecking.Free: Flexible :: a -> FlexRig' a
+ Agda.TypeChecking.Free: Flexible :: !a -> FlexRig' a
- Agda.TypeChecking.Free: VarOcc :: FlexRig' a -> Modality -> VarOcc' a
+ Agda.TypeChecking.Free: VarOcc :: !FlexRig' a -> {-# UNPACK #-} !Modality -> VarOcc' a
- Agda.TypeChecking.Free: [varFlexRig] :: VarOcc' a -> FlexRig' a
+ Agda.TypeChecking.Free: [varFlexRig] :: VarOcc' a -> !FlexRig' a
- Agda.TypeChecking.Free: [varModality] :: VarOcc' a -> Modality
+ Agda.TypeChecking.Free: [varModality] :: VarOcc' a -> {-# UNPACK #-} !Modality
- Agda.TypeChecking.Free: filterVarMapToList :: (VarOcc -> Bool) -> VarMap -> [Variable]
+ Agda.TypeChecking.Free: filterVarMapToList :: (VarOcc -> Bool) -> VarMap -> [Int]
- Agda.TypeChecking.Free: freeIn :: Free a => Nat -> a -> Bool
+ Agda.TypeChecking.Free: freeIn :: Free t => Nat -> t -> Bool
- Agda.TypeChecking.Free: freeVars :: (IsVarSet a c, Singleton Variable c, Free t) => t -> c
+ Agda.TypeChecking.Free: freeVars :: (Free t, ComputeFree r) => t -> Reader r (Collect r)
- Agda.TypeChecking.Free.Reduce: MaybeFree :: MetaSet -> IsFree
+ Agda.TypeChecking.Free.Reduce: MaybeFree :: FlexRig -> IsFree
- Agda.TypeChecking.Free.Reduce: forceNotFree :: (ForceNotFree a, Reduce a, MonadReduce m) => IntSet -> a -> m (IntMap IsFree, a)
+ Agda.TypeChecking.Free.Reduce: forceNotFree :: (ForceNotFree a, Reduce a) => VarSet -> a -> ReduceM (IntMap IsFree, a)
- Agda.TypeChecking.Free.Reduce: reallyFree :: (MonadReduce m, Reduce a, ForceNotFree a) => IntSet -> a -> m (Either Blocked_ (Maybe a))
+ Agda.TypeChecking.Free.Reduce: reallyFree :: (Reduce a, ForceNotFree a) => VarSet -> a -> ReduceM (Either Blocked_ (Maybe a))
- Agda.TypeChecking.Functions: etaExpandClause :: PureTCM tcm => Clause -> tcm Clause
+ Agda.TypeChecking.Functions: etaExpandClause :: PureTCM tcm => Clause -> tcm (Int, Clause)
- Agda.TypeChecking.Implicit: NoSuchName :: ArgName -> ImplicitInsertion
+ Agda.TypeChecking.Implicit: NoSuchName :: ArgName -> [ArgName] -> ImplicitInsertion
- Agda.TypeChecking.Implicit: implicitArgs :: (PureTCM m, MonadMetaSolver m, MonadTCM m) => Int -> (Hiding -> Bool) -> Type -> m (Args, Type)
+ Agda.TypeChecking.Implicit: implicitArgs :: Int -> (Hiding -> Bool) -> Type -> TCM (Args, Type)
- Agda.TypeChecking.Implicit: implicitNamedArgs :: (PureTCM m, MonadMetaSolver m, MonadTCM m) => Int -> (Hiding -> ArgName -> Bool) -> Type -> m (NamedArgs, Type)
+ Agda.TypeChecking.Implicit: implicitNamedArgs :: Int -> (Hiding -> ArgName -> Bool) -> Type -> TCM (NamedArgs, Type)
- Agda.TypeChecking.Implicit: newMetaArg :: (PureTCM m, MonadMetaSolver m) => MetaKind -> ArgInfo -> ArgName -> Comparison -> Type -> m (MetaId, Term)
+ Agda.TypeChecking.Implicit: newMetaArg :: MetaKind -> ArgName -> Comparison -> Dom Type -> TCM (MetaId, Term)
- Agda.TypeChecking.Injectivity: invertFunction :: MonadConversion m => Comparison -> Term -> InvView -> TermHead -> m () -> m () -> (Term -> m ()) -> m ()
+ Agda.TypeChecking.Injectivity: invertFunction :: Comparison -> Term -> InvView -> TermHead -> TCM () -> TCM () -> (Term -> TCM ()) -> TCM ()
- Agda.TypeChecking.Injectivity: useInjectivity :: MonadConversion m => CompareDirection -> Blocker -> CompareAs -> Term -> Term -> m ()
+ Agda.TypeChecking.Injectivity: useInjectivity :: CompareDirection -> Blocker -> CompareAs -> Term -> Term -> TCM ()
- Agda.TypeChecking.InstanceArguments: addTypedInstance :: QName -> Type -> TCM ()
+ Agda.TypeChecking.InstanceArguments: addTypedInstance :: KwRange -> QName -> Type -> TCM ()
- Agda.TypeChecking.InstanceArguments: addTypedInstance' :: Bool -> Bool -> Maybe InstanceInfo -> QName -> Type -> TCM ()
+ Agda.TypeChecking.InstanceArguments: addTypedInstance' :: Bool -> Bool -> Maybe InstanceInfo -> KwRange -> QName -> Type -> TCM ()
- Agda.TypeChecking.InstanceArguments: readdTypedInstance :: QName -> Type -> TCM ()
+ Agda.TypeChecking.InstanceArguments: readdTypedInstance :: KwRange -> QName -> Type -> TCM ()
- Agda.TypeChecking.InstanceArguments: resolveInstanceHead :: QName -> TCM ()
+ Agda.TypeChecking.InstanceArguments: resolveInstanceHead :: KwRange -> QName -> TCM ()
- Agda.TypeChecking.Irrelevance: usableMod :: (UsableModality a, ReadTCState m, HasConstInfo m, MonadTCEnv m, MonadAddContext m, MonadDebug m, MonadReduce m, MonadError Blocker m) => Modality -> a -> m Bool
+ Agda.TypeChecking.Irrelevance: usableMod :: (UsableModality a, HasConstInfo m, MonadAddContext m, MonadReduce m, MonadError Blocker m) => Modality -> a -> m Bool
- Agda.TypeChecking.Irrelevance: usableModAbs :: (Subst a, MonadAddContext m, UsableModality a, ReadTCState m, HasConstInfo m, MonadReduce m, MonadError Blocker m) => ArgInfo -> Modality -> Abs a -> m Bool
+ Agda.TypeChecking.Irrelevance: usableModAbs :: (Subst a, MonadAddContext m, UsableModality a, HasConstInfo m, MonadReduce m, MonadError Blocker m) => ArgInfo -> Modality -> Abs a -> m Bool
- Agda.TypeChecking.Irrelevance: usableRel :: (UsableRelevance a, ReadTCState m, HasConstInfo m, MonadTCEnv m, MonadAddContext m, MonadDebug m) => Relevance -> a -> m Bool
+ Agda.TypeChecking.Irrelevance: usableRel :: (UsableRelevance a, ReadTCState m, HasConstInfo m, MonadAddContext m) => Relevance -> a -> m Bool
- Agda.TypeChecking.MetaVars: ($dmreduceAndEtaContract) :: forall (f :: Type -> Type) b. (ReduceAndEtaContract a, Traversable f, TermLike b, Subst b, Reduce b, ReduceAndEtaContract b, f b ~ a) => a -> TCM a
+ Agda.TypeChecking.MetaVars: ($dmreduceAndEtaContract) :: forall (f :: Type -> Type) b. (ReduceAndEtaContract a, Traversable f, ReduceAndEtaContract b, f b ~ a) => a -> TCM a
- Agda.TypeChecking.MetaVars: assignTerm :: MonadMetaSolver m => MetaId -> [Arg ArgName] -> Term -> m ()
+ Agda.TypeChecking.MetaVars: assignTerm :: MetaId -> [Arg ArgName] -> Term -> TCM ()
- Agda.TypeChecking.MetaVars: assignWrapper :: (MonadMetaSolver m, MonadConstraint m, MonadError TCErr m, MonadDebug m, HasOptions m) => CompareDirection -> MetaId -> Elims -> Term -> m () -> m ()
+ Agda.TypeChecking.MetaVars: assignWrapper :: MonadMetaSolver m => CompareDirection -> MetaId -> Elims -> Term -> m () -> m ()
- Agda.TypeChecking.MetaVars: blockTerm :: (MonadMetaSolver m, MonadConstraint m, MonadFresh Nat m, MonadFresh ProblemId m) => Type -> m Term -> m Term
+ Agda.TypeChecking.MetaVars: blockTerm :: Type -> TCM Term -> TCM Term
- Agda.TypeChecking.MetaVars: blockTermOnProblem :: (MonadMetaSolver m, MonadFresh Nat m) => Type -> Term -> ProblemId -> m Term
+ Agda.TypeChecking.MetaVars: blockTermOnProblem :: Type -> Term -> ProblemId -> TCM Term
- Agda.TypeChecking.MetaVars: blockTypeOnProblem :: (MonadMetaSolver m, MonadFresh Nat m) => Type -> ProblemId -> m Type
+ Agda.TypeChecking.MetaVars: blockTypeOnProblem :: Type -> ProblemId -> TCM Type
- Agda.TypeChecking.MetaVars: etaExpandBlocked :: (MonadReduce m, MonadMetaSolver m, IsMeta t, Reduce t) => Blocked t -> m (Blocked t)
+ Agda.TypeChecking.MetaVars: etaExpandBlocked :: (MonadMetaSolver m, IsMeta t, Reduce t) => Blocked t -> m (Blocked t)
- Agda.TypeChecking.MetaVars: inverseSubst' :: (Term -> Bool) -> Args -> ExceptT InvertExcept TCM SubstCand
+ Agda.TypeChecking.MetaVars: inverseSubst' :: (Term -> Bool) -> Tele (Dom Type) -> Args -> ExceptT InvertExcept TCM SubstCand
- Agda.TypeChecking.MetaVars: isInteractionMetaB :: (ReadTCState m, MonadReduce m, MonadPretty m) => MetaId -> Args -> m (Maybe (MetaId, InteractionId, Args))
+ Agda.TypeChecking.MetaVars: isInteractionMetaB :: MonadPretty m => MetaId -> Args -> m (Maybe (MetaId, InteractionId, Args))
- Agda.TypeChecking.MetaVars: newArgsMeta :: MonadMetaSolver m => Type -> m Args
+ Agda.TypeChecking.MetaVars: newArgsMeta :: Type -> TCM Args
- Agda.TypeChecking.MetaVars: newArgsMeta' :: MonadMetaSolver m => Condition -> Type -> m Args
+ Agda.TypeChecking.MetaVars: newArgsMeta' :: Condition -> Type -> TCM Args
- Agda.TypeChecking.MetaVars: newArgsMetaCtx' :: MonadMetaSolver m => Frozen -> Condition -> Type -> Telescope -> Permutation -> Args -> m Args
+ Agda.TypeChecking.MetaVars: newArgsMetaCtx' :: Frozen -> Condition -> Type -> Telescope -> Permutation -> Args -> TCM Args
- Agda.TypeChecking.MetaVars: newArgsMetaCtx'' :: MonadMetaSolver m => MetaNameSuggestion -> Frozen -> Condition -> Type -> Telescope -> Permutation -> Args -> m Args
+ Agda.TypeChecking.MetaVars: newArgsMetaCtx'' :: MetaNameSuggestion -> Frozen -> Condition -> Type -> Telescope -> Permutation -> Args -> TCM Args
- Agda.TypeChecking.MetaVars: newInstanceMeta :: MonadMetaSolver m => MetaNameSuggestion -> Type -> m (MetaId, Term)
+ Agda.TypeChecking.MetaVars: newInstanceMeta :: MetaNameSuggestion -> Type -> TCM (MetaId, Term)
- Agda.TypeChecking.MetaVars: newInstanceMetaCtx :: MonadMetaSolver m => MetaNameSuggestion -> Type -> Args -> m (MetaId, Term)
+ Agda.TypeChecking.MetaVars: newInstanceMetaCtx :: MetaNameSuggestion -> Type -> Args -> TCM (MetaId, Term)
- Agda.TypeChecking.MetaVars: newLevelMeta :: MonadMetaSolver m => m Level
+ Agda.TypeChecking.MetaVars: newLevelMeta :: TCM Level
- Agda.TypeChecking.MetaVars: newNamedValueMeta :: MonadMetaSolver m => RunMetaOccursCheck -> MetaNameSuggestion -> Comparison -> Type -> m (MetaId, Term)
+ Agda.TypeChecking.MetaVars: newNamedValueMeta :: RunMetaOccursCheck -> MetaNameSuggestion -> Comparison -> Type -> TCM (MetaId, Term)
- Agda.TypeChecking.MetaVars: newNamedValueMeta' :: MonadMetaSolver m => RunMetaOccursCheck -> MetaNameSuggestion -> Comparison -> Type -> m (MetaId, Term)
+ Agda.TypeChecking.MetaVars: newNamedValueMeta' :: RunMetaOccursCheck -> MetaNameSuggestion -> Comparison -> Type -> TCM (MetaId, Term)
- Agda.TypeChecking.MetaVars: newSortMeta :: MonadMetaSolver m => m Sort
+ Agda.TypeChecking.MetaVars: newSortMeta :: TCM Sort
- Agda.TypeChecking.MetaVars: newTelMeta :: MonadMetaSolver m => Telescope -> m Args
+ Agda.TypeChecking.MetaVars: newTelMeta :: Telescope -> TCM Args
- Agda.TypeChecking.MetaVars: newValueMeta :: MonadMetaSolver m => RunMetaOccursCheck -> Comparison -> Type -> m (MetaId, Term)
+ Agda.TypeChecking.MetaVars: newValueMeta :: RunMetaOccursCheck -> Comparison -> Type -> TCM (MetaId, Term)
- Agda.TypeChecking.MetaVars: newValueMeta' :: MonadMetaSolver m => RunMetaOccursCheck -> Comparison -> Type -> m (MetaId, Term)
+ Agda.TypeChecking.MetaVars: newValueMeta' :: RunMetaOccursCheck -> Comparison -> Type -> TCM (MetaId, Term)
- Agda.TypeChecking.MetaVars: newValueMetaCtx :: MonadMetaSolver m => Frozen -> RunMetaOccursCheck -> Comparison -> Type -> Telescope -> Permutation -> Args -> m (MetaId, Term)
+ Agda.TypeChecking.MetaVars: newValueMetaCtx :: Frozen -> RunMetaOccursCheck -> Comparison -> Type -> Telescope -> Permutation -> Args -> TCM (MetaId, Term)
- Agda.TypeChecking.MetaVars: newValueMetaCtx' :: MonadMetaSolver m => Frozen -> RunMetaOccursCheck -> Comparison -> Type -> Telescope -> Permutation -> Args -> m (MetaId, Term)
+ Agda.TypeChecking.MetaVars: newValueMetaCtx' :: Frozen -> RunMetaOccursCheck -> Comparison -> Type -> Telescope -> Permutation -> Args -> TCM (MetaId, Term)
- Agda.TypeChecking.MetaVars: newValueMetaOfKind :: MonadMetaSolver m => MetaInfo -> RunMetaOccursCheck -> Comparison -> Type -> m (MetaId, Term)
+ Agda.TypeChecking.MetaVars: newValueMetaOfKind :: MetaInfo -> RunMetaOccursCheck -> Comparison -> Type -> TCM (MetaId, Term)
- Agda.TypeChecking.MetaVars.Occurs: killArgs :: MonadMetaSolver m => [Bool] -> MetaId -> m PruneResult
+ Agda.TypeChecking.MetaVars.Occurs: killArgs :: [Bool] -> MetaId -> TCM PruneResult
- Agda.TypeChecking.MetaVars.Occurs: prune :: (PureTCM m, MonadMetaSolver m) => MetaId -> Args -> (Nat -> Bool) -> m PruneResult
+ Agda.TypeChecking.MetaVars.Occurs: prune :: MetaId -> Args -> (Nat -> Bool) -> TCM PruneResult
- Agda.TypeChecking.Modalities: checkModality :: MonadConversion m => QName -> Definition -> m ()
+ Agda.TypeChecking.Modalities: checkModality :: QName -> Definition -> TCM ()
- Agda.TypeChecking.Modalities: checkModality' :: MonadConversion m => QName -> Definition -> m (Maybe TypeError)
+ Agda.TypeChecking.Modalities: checkModality' :: QName -> Definition -> TCM (Maybe TypeError)
- Agda.TypeChecking.Modalities: checkModalityArgs :: MonadConversion m => Definition -> Args -> m ()
+ Agda.TypeChecking.Modalities: checkModalityArgs :: Definition -> Args -> TCM ()
- Agda.TypeChecking.Monad.Base: AmbiguousOverloadedProjection :: List1 QName -> Doc -> TypeError
+ Agda.TypeChecking.Monad.Base: AmbiguousOverloadedProjection :: AmbiguousQName -> Doc -> TypeError
- Agda.TypeChecking.Monad.Base: CannotEliminateWithProjection :: Arg Type -> Bool -> QName -> TypeError
+ Agda.TypeChecking.Monad.Base: CannotEliminateWithProjection :: Maybe Blocker -> Arg Type -> Bool -> QName -> TypeError
- Agda.TypeChecking.Monad.Base: CannotQuoteAmbiguous :: List2 QName -> CannotQuote
+ Agda.TypeChecking.Monad.Base: CannotQuoteAmbiguous :: AmbiguousQName -> CannotQuote
- Agda.TypeChecking.Monad.Base: CheckFunDefCall :: Range -> QName -> [Clause] -> Bool -> Call
+ Agda.TypeChecking.Monad.Base: CheckFunDefCall :: Range -> QName -> Bool -> Call
- Agda.TypeChecking.Monad.Base: CheckProjAppToKnownPrincipalArg :: Comparison -> Expr -> ProjOrigin -> List1 QName -> Expr -> Args -> Type -> Int -> Term -> Type -> PrincipalArgTypeMetas -> TypeCheckingProblem
+ Agda.TypeChecking.Monad.Base: CheckProjAppToKnownPrincipalArg :: Comparison -> Expr -> ProjOrigin -> AmbiguousQName -> Expr -> Args -> Type -> Int -> Term -> Type -> PrincipalArgTypeMetas -> TypeCheckingProblem
- Agda.TypeChecking.Monad.Base: CheckedArg :: Elim -> Maybe Range -> Maybe (Abs Constraint) -> CheckedArg
+ Agda.TypeChecking.Monad.Base: CheckedArg :: Elim -> Range -> Maybe (Abs Constraint) -> CheckedArg
- Agda.TypeChecking.Monad.Base: ClashingDefinition :: QName -> QName -> Maybe NiceDeclaration -> TypeError
+ Agda.TypeChecking.Monad.Base: ClashingDefinition :: QName -> ClashingName -> Maybe NiceDeclaration -> TypeError
- Agda.TypeChecking.Monad.Base: Closure :: Signature -> TCEnv -> ScopeInfo -> Map ModuleName CheckpointId -> a -> Closure a
+ Agda.TypeChecking.Monad.Base: Closure :: Signature -> TCEnv -> ScopeInfo -> ModuleCheckpoints -> a -> Closure a
- Agda.TypeChecking.Monad.Base: ConstructorData :: Int -> Int -> ConHead -> QName -> IsAbstract -> CompKit -> Maybe [QName] -> [IsForced] -> Maybe [Bool] -> !Bool -> !Bool -> ConstructorData
+ Agda.TypeChecking.Monad.Base: ConstructorData :: Int -> Int -> ConHead -> QName -> IsAbstract -> !IsPathCons -> CompKit -> Maybe [QName] -> [IsForced] -> Maybe [Bool] -> !Bool -> !Bool -> ConstructorData
- Agda.TypeChecking.Monad.Base: ConstructorParametersNotGeneral :: ConHead -> Args -> IllegalRewriteRuleReason
+ Agda.TypeChecking.Monad.Base: ConstructorParametersNotGeneral :: ConHead -> Args1 -> IllegalRewriteRuleReason
- Agda.TypeChecking.Monad.Base: ConstructorPatternInWrongDatatype :: QName -> QName -> TypeError
+ Agda.TypeChecking.Monad.Base: ConstructorPatternInWrongDatatype :: QName -> QName -> DataOrRecord_ -> TypeError
- Agda.TypeChecking.Monad.Base: DataOrRecSigData :: Int -> DataOrRecSigData
+ Agda.TypeChecking.Monad.Base: DataOrRecSigData :: !Int -> !DataOrRecord_ -> DataOrRecSigData
- Agda.TypeChecking.Monad.Base: DatatypeData :: Nat -> Nat -> Maybe Clause -> [QName] -> Sort -> Maybe [QName] -> IsAbstract -> [QName] -> Maybe QName -> Maybe QName -> DatatypeData
+ Agda.TypeChecking.Monad.Base: DatatypeData :: Nat -> Nat -> Maybe Term -> [QName] -> Sort -> Maybe [QName] -> PositivityCheck -> IsAbstract -> !IsHIT -> Maybe QName -> Maybe QName -> DatatypeData
- Agda.TypeChecking.Monad.Base: Defn :: ArgInfo -> QName -> Type -> [Polarity] -> [Occurrence] -> [Maybe Name] -> [LocalDisplayForm] -> MutualId -> CompiledRepresentation -> Maybe InstanceInfo -> Bool -> Set QName -> Bool -> Bool -> Bool -> Blocked_ -> !Language -> Defn -> Definition
+ Agda.TypeChecking.Monad.Base: Defn :: ArgInfo -> QName -> Type -> [Polarity] -> [Occurrence] -> [Maybe Name] -> [LocalDisplayForm] -> MutualId -> CompiledRepresentation -> Maybe InstanceInfo -> Bool -> Set QName -> Bool -> Bool -> Bool -> Blocked_ -> !Language -> !Bool -> Defn -> Definition
- Agda.TypeChecking.Monad.Base: DeprecationWarning :: String -> String -> String -> Warning
+ Agda.TypeChecking.Monad.Base: DeprecationWarning :: String -> Maybe String -> String -> Warning
- Agda.TypeChecking.Monad.Base: FileNotFound :: TopLevelModuleName -> [AbsolutePath] -> TypeError
+ Agda.TypeChecking.Monad.Base: FileNotFound :: TopLevelModuleName -> List1 AbsolutePath -> TypeError
- Agda.TypeChecking.Monad.Base: FunctionData :: [Clause] -> Maybe CompiledClauses -> Maybe SplitTree -> Maybe Compiled -> [Clause] -> FunctionInverse -> Maybe [QName] -> Either ProjectionLikenessMissing Projection -> SmallSet FunctionFlag -> Maybe Bool -> Maybe ExtLamInfo -> Maybe QName -> Maybe QName -> IsOpaque -> FunctionData
+ Agda.TypeChecking.Monad.Base: FunctionData :: [Clause] -> Maybe CompiledClauses -> Maybe SplitTree -> Maybe Compiled -> [Clause] -> FunctionInverse -> Maybe [QName] -> Either ProjectionLikenessMissing Projection -> SmallSet FunctionFlag -> Maybe Bool -> Maybe ExtLamInfo -> IsWithFunction QName -> Maybe QName -> IsOpaque -> FunctionData
- Agda.TypeChecking.Monad.Base: IPClause :: QName -> Int -> Type -> Maybe Substitution -> SpineClause -> Closure () -> IPClause
+ Agda.TypeChecking.Monad.Base: IPClause :: QName -> ClauseNumber -> Type -> IsWithFunction Substitution -> SpineClause -> Closure () -> IPClause
- Agda.TypeChecking.Monad.Base: IllegalDeclarationInDataDefinition :: List1 Declaration -> TypeError
+ Agda.TypeChecking.Monad.Base: IllegalDeclarationInDataDefinition :: List1 Declaration -> Warning
- Agda.TypeChecking.Monad.Base: IllegalRewriteRule :: QName -> IllegalRewriteRuleReason -> Warning
+ Agda.TypeChecking.Monad.Base: IllegalRewriteRule :: SerialisableRewriteSource -> IllegalRewriteRuleReason -> Warning
- Agda.TypeChecking.Monad.Base: InstanceWithExplicitArg :: QName -> Warning
+ Agda.TypeChecking.Monad.Base: InstanceWithExplicitArg :: KwRange -> QName -> Warning
- Agda.TypeChecking.Monad.Base: IsEmpty :: Range -> Type -> Constraint
+ Agda.TypeChecking.Monad.Base: IsEmpty :: Range -> Dom Type -> Constraint
- Agda.TypeChecking.Monad.Base: LetBinding :: Origin -> Term -> Dom Type -> LetBinding
+ Agda.TypeChecking.Monad.Base: LetBinding :: IsAxiom -> Origin -> Term -> Dom Type -> LetBinding
- Agda.TypeChecking.Monad.Base: MissingDefinition :: QName -> UnquoteError
+ Agda.TypeChecking.Monad.Base: MissingDefinition :: List1 QName -> UnquoteError
- Agda.TypeChecking.Monad.Base: ModuleInfo :: Interface -> Set TCWarning -> Bool -> ModuleCheckMode -> ModuleInfo
+ Agda.TypeChecking.Monad.Base: ModuleInfo :: Interface -> Set TCWarning -> !Maybe IsBuiltinModule -> ModuleCheckMode -> SourceFile -> ModuleInfo
- Agda.TypeChecking.Monad.Base: ModuleNameDoesntMatchFileName :: TopLevelModuleName -> [AbsolutePath] -> TypeError
+ Agda.TypeChecking.Monad.Base: ModuleNameDoesntMatchFileName :: TopLevelModuleName -> List1 AbsolutePath -> TypeError
- Agda.TypeChecking.Monad.Base: ModuleNameUnexpected :: TopLevelModuleName -> TopLevelModuleName -> TypeError
+ Agda.TypeChecking.Monad.Base: ModuleNameUnexpected :: TopLevelModuleNameWithSourceFile -> TopLevelModuleName -> TypeError
- Agda.TypeChecking.Monad.Base: NoParameterOfName :: ArgName -> TypeError
+ Agda.TypeChecking.Monad.Base: NoParameterOfName :: ArgName -> [ArgName] -> TypeError
- Agda.TypeChecking.Monad.Base: OperatorInformation :: [NotationSection] -> TypeError -> TypeError
+ Agda.TypeChecking.Monad.Base: OperatorInformation :: [NotationSection] -> OperatorScope -> TypeError -> TypeError
- Agda.TypeChecking.Monad.Base: PersistentTCSt :: !SessionTCState -> !DecodedModules -> !BiMap RawTopLevelModuleName ModuleNameHash -> CommandLineOptions -> InteractionOutputCallback -> !Statistics -> !Maybe LoadedFileCache -> PersistentTCState
+ Agda.TypeChecking.Monad.Base: PersistentTCSt :: !Atomic SessionState -> !DecodedModules -> !BiMap RawTopLevelModuleName ModuleNameHash -> CommandLineOptions -> !Statistics -> !Maybe LoadedFileCache -> PersistentTCState
- Agda.TypeChecking.Monad.Base: PostScopeState :: !HighlightingInfo -> !DisambiguatedNames -> !LocalMetaStore -> !LocalMetaStore -> !InteractionPoints -> !Constraints -> !Constraints -> !Bool -> !Set QName -> !Signature -> !Map ModuleName CheckpointId -> !DisplayForms -> !BackendForeignCode -> !Maybe (ModuleName, TopLevelModuleName) -> !Set QName -> !Set QName -> !ConcreteNames -> !UsedNames -> !ShadowingNames -> !Statistics -> !Set TCWarning -> !MutualBlocks -> !BuiltinThings -> !MetaId -> !MutualId -> !ProblemId -> !CheckpointId -> !Int -> !NameId -> !OpaqueId -> !Bool -> !Bool -> !Bool -> !Bool -> !Set QName -> Map OpaqueId OpaqueBlock -> Map QName OpaqueId -> !Bool -> PostScopeState
+ Agda.TypeChecking.Monad.Base: PostScopeState :: !PostNamesCheckpoints -> !PostMetaState -> !PostColdState -> PostScopeState
- Agda.TypeChecking.Monad.Base: PreScopeState :: !HighlightingInfo -> !Signature -> !ImportedModules -> !ImportedModules -> !ModuleToSourceId -> !VisitedModules -> !ScopeInfo -> !PatternSynDefns -> !PatternSynDefns -> !Maybe (Set QName) -> !PragmaOptions -> !BuiltinThings -> !DisplayForms -> !InteractionId -> !UserWarnings -> !UserWarnings -> !Maybe Text -> !Set QName -> !LibCache -> !RemoteMetaStore -> !HashMap QName QName -> !HashMap QName (HashSet QName) -> PreScopeState
+ Agda.TypeChecking.Monad.Base: PreScopeState :: !Maybe FileId -> !HighlightingInfo -> !Signature -> !ImportedModules -> !ImportedModules -> !VisitedModules -> !ScopeInfo -> !PatternSynDefns -> !PatternSynDefns -> !Maybe (Set QName) -> !PragmaOptions -> !BuiltinThings -> !DisplayForms -> !InteractionId -> !UserWarnings -> !UserWarnings -> !Maybe Text -> !Set QName -> !LibCache -> !RemoteMetaStore -> !HashMap QName QName -> !HashMap QName (HashSet QName) -> !UnusedImportsState -> PreScopeState
- 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: RecordData :: Nat -> Maybe Term -> ConHead -> Bool -> [Dom QName] -> Telescope -> Maybe [QName] -> PositivityCheck -> EtaEquality -> PatternOrCopattern -> Maybe Induction -> Maybe Bool -> IsAbstract -> CompKit -> RecordData
- Agda.TypeChecking.Monad.Base: RecursiveRecordNeedsInductivity :: QName -> TypeError
+ Agda.TypeChecking.Monad.Base: RecursiveRecordNeedsInductivity :: QName -> Warning
- Agda.TypeChecking.Monad.Base: ReduceEnv :: TCEnv -> TCState -> Maybe (MetaId -> ReduceM Bool) -> ReduceEnv
+ Agda.TypeChecking.Monad.Base: ReduceEnv :: !TCEnv -> !TCState -> !SessionState -> !Maybe (MetaId -> ReduceM Bool) -> ReduceEnv
- Agda.TypeChecking.Monad.Base: ResolveInstanceHead :: QName -> Constraint
+ Agda.TypeChecking.Monad.Base: ResolveInstanceHead :: KwRange -> QName -> Constraint
- Agda.TypeChecking.Monad.Base: ShouldBeRecordPattern :: DeBruijnPattern -> TypeError
+ Agda.TypeChecking.Monad.Base: ShouldBeRecordPattern :: TypeError
- Agda.TypeChecking.Monad.Base: Sig :: Sections -> Definitions -> RewriteRuleMap -> InstanceTable -> Signature
+ Agda.TypeChecking.Monad.Base: Sig :: Sections -> Definitions -> GlobalRewriteRuleMap -> InstanceTable -> Signature
- Agda.TypeChecking.Monad.Base: SolvedButOpenHoles :: TypeError
+ Agda.TypeChecking.Monad.Base: SolvedButOpenHoles :: TopLevelModuleNameWithSourceFile -> TypeError
- Agda.TypeChecking.Monad.Base: TCEnv :: Context -> LetBindings -> ModuleName -> Maybe FileId -> [(ModuleName, Nat)] -> [TopLevelModuleName] -> Maybe MutualId -> TerminationCheck () -> CoverageCheck -> Bool -> Bool -> WhereClause_ -> Bool -> Bool -> Set ProblemId -> Maybe ProblemId -> AbstractMode -> Relevance -> Quantity -> Bool -> Bool -> 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 -> !Maybe OpaqueId -> Bool -> TCEnv
+ Agda.TypeChecking.Monad.Base: TCEnv :: !TCContext -> !Set ProblemId -> !ModalEnv -> !Flags64 -> !ColdEnv -> TCEnv
- Agda.TypeChecking.Monad.Base: VariablesBoundMoreThanOnce :: IntSet -> IllegalRewriteRuleReason
+ Agda.TypeChecking.Monad.Base: VariablesBoundMoreThanOnce :: VarSet -> IllegalRewriteRuleReason
- Agda.TypeChecking.Monad.Base: VariablesNotBoundByLHS :: IntSet -> IllegalRewriteRuleReason
+ Agda.TypeChecking.Monad.Base: VariablesNotBoundByLHS :: VarSet -> IllegalRewriteRuleReason
- Agda.TypeChecking.Monad.Base: WrongInstanceDeclaration :: Warning
+ Agda.TypeChecking.Monad.Base: WrongInstanceDeclaration :: KwRange -> Warning
- Agda.TypeChecking.Monad.Base: [_dataClause] :: DatatypeData -> Maybe Clause
+ Agda.TypeChecking.Monad.Base: [_dataClause] :: DatatypeData -> Maybe Term
- Agda.TypeChecking.Monad.Base: [_datarecPars] :: DataOrRecSigData -> Int
+ Agda.TypeChecking.Monad.Base: [_datarecPars] :: DataOrRecSigData -> !Int
- Agda.TypeChecking.Monad.Base: [_funWith] :: FunctionData -> Maybe QName
+ Agda.TypeChecking.Monad.Base: [_funWith] :: FunctionData -> IsWithFunction QName
- Agda.TypeChecking.Monad.Base: [_recClause] :: RecordData -> Maybe Clause
+ Agda.TypeChecking.Monad.Base: [_recClause] :: RecordData -> Maybe Term
- Agda.TypeChecking.Monad.Base: [_sigRewriteRules] :: Signature -> RewriteRuleMap
+ Agda.TypeChecking.Monad.Base: [_sigRewriteRules] :: Signature -> GlobalRewriteRuleMap
- Agda.TypeChecking.Monad.Base: [caRange] :: CheckedArg -> Maybe Range
+ Agda.TypeChecking.Monad.Base: [caRange] :: CheckedArg -> Range
- Agda.TypeChecking.Monad.Base: [clModuleCheckpoints] :: Closure a -> Map ModuleName CheckpointId
+ Agda.TypeChecking.Monad.Base: [clModuleCheckpoints] :: Closure a -> ModuleCheckpoints
- Agda.TypeChecking.Monad.Base: [envAbstractMode] :: TCEnv -> AbstractMode
+ Agda.TypeChecking.Monad.Base: [envAbstractMode] :: ColdEnv -> !AbstractMode
- Agda.TypeChecking.Monad.Base: [envActiveBackendName] :: TCEnv -> Maybe BackendName
+ Agda.TypeChecking.Monad.Base: [envActiveBackendName] :: ColdEnv -> !Maybe BackendName
- Agda.TypeChecking.Monad.Base: [envActiveProblems] :: TCEnv -> Set ProblemId
+ Agda.TypeChecking.Monad.Base: [envActiveProblems] :: TCEnv -> !Set ProblemId
- Agda.TypeChecking.Monad.Base: [envAllowedReductions] :: TCEnv -> AllowedReductions
+ Agda.TypeChecking.Monad.Base: [envAllowedReductions] :: ModalEnv -> !AllowedReductions
- Agda.TypeChecking.Monad.Base: [envAnonymousModules] :: TCEnv -> [(ModuleName, Nat)]
+ Agda.TypeChecking.Monad.Base: [envAnonymousModules] :: ColdEnv -> [(ModuleName, Nat)]
- Agda.TypeChecking.Monad.Base: [envAppDef] :: TCEnv -> Maybe QName
+ Agda.TypeChecking.Monad.Base: [envAppDef] :: TCContext -> !Maybe QName
- Agda.TypeChecking.Monad.Base: [envCall] :: TCEnv -> Maybe (Closure Call)
+ Agda.TypeChecking.Monad.Base: [envCall] :: ColdEnv -> Maybe (Closure Call)
- Agda.TypeChecking.Monad.Base: [envCheckingWhere] :: TCEnv -> WhereClause_
+ Agda.TypeChecking.Monad.Base: [envCheckingWhere] :: ColdEnv -> !WhereClause_
- Agda.TypeChecking.Monad.Base: [envCheckpoints] :: TCEnv -> Map CheckpointId Substitution
+ Agda.TypeChecking.Monad.Base: [envCheckpoints] :: TCContext -> Map CheckpointId Substitution
- Agda.TypeChecking.Monad.Base: [envClause] :: TCEnv -> IPClause
+ Agda.TypeChecking.Monad.Base: [envClause] :: ColdEnv -> IPClause
- Agda.TypeChecking.Monad.Base: [envContext] :: TCEnv -> Context
+ Agda.TypeChecking.Monad.Base: [envContext] :: TCContext -> !Context
- Agda.TypeChecking.Monad.Base: [envCoverageCheck] :: TCEnv -> CoverageCheck
+ Agda.TypeChecking.Monad.Base: [envCoverageCheck] :: ColdEnv -> !CoverageCheck
- Agda.TypeChecking.Monad.Base: [envCurrentCheckpoint] :: TCEnv -> CheckpointId
+ Agda.TypeChecking.Monad.Base: [envCurrentCheckpoint] :: TCContext -> !CheckpointId
- Agda.TypeChecking.Monad.Base: [envCurrentModule] :: TCEnv -> ModuleName
+ Agda.TypeChecking.Monad.Base: [envCurrentModule] :: ColdEnv -> ModuleName
- Agda.TypeChecking.Monad.Base: [envCurrentOpaqueId] :: TCEnv -> !Maybe OpaqueId
+ Agda.TypeChecking.Monad.Base: [envCurrentOpaqueId] :: ColdEnv -> !Maybe OpaqueId
- Agda.TypeChecking.Monad.Base: [envCurrentPath] :: TCEnv -> Maybe FileId
+ Agda.TypeChecking.Monad.Base: [envCurrentPath] :: ColdEnv -> Maybe FileId
- Agda.TypeChecking.Monad.Base: [envExpandLast] :: TCEnv -> ExpandHidden
+ Agda.TypeChecking.Monad.Base: [envExpandLast] :: ColdEnv -> !ExpandHidden
- Agda.TypeChecking.Monad.Base: [envGeneralizeMetas] :: TCEnv -> DoGeneralize
+ Agda.TypeChecking.Monad.Base: [envGeneralizeMetas] :: ColdEnv -> !DoGeneralize
- Agda.TypeChecking.Monad.Base: [envGeneralizedVars] :: TCEnv -> Map QName GeneralizedValue
+ Agda.TypeChecking.Monad.Base: [envGeneralizedVars] :: ColdEnv -> !Map QName GeneralizedValue
- Agda.TypeChecking.Monad.Base: [envHighlightingLevel] :: TCEnv -> HighlightingLevel
+ Agda.TypeChecking.Monad.Base: [envHighlightingLevel] :: ColdEnv -> !HighlightingLevel
- Agda.TypeChecking.Monad.Base: [envHighlightingMethod] :: TCEnv -> HighlightingMethod
+ Agda.TypeChecking.Monad.Base: [envHighlightingMethod] :: ColdEnv -> !HighlightingMethod
- Agda.TypeChecking.Monad.Base: [envHighlightingRange] :: TCEnv -> Range
+ Agda.TypeChecking.Monad.Base: [envHighlightingRange] :: ColdEnv -> Range
- Agda.TypeChecking.Monad.Base: [envInjectivityDepth] :: TCEnv -> Int
+ Agda.TypeChecking.Monad.Base: [envInjectivityDepth] :: ColdEnv -> !Int
- Agda.TypeChecking.Monad.Base: [envInstanceDepth] :: TCEnv -> !Int
+ Agda.TypeChecking.Monad.Base: [envInstanceDepth] :: ColdEnv -> !Int
- Agda.TypeChecking.Monad.Base: [envLetBindings] :: TCEnv -> LetBindings
+ Agda.TypeChecking.Monad.Base: [envLetBindings] :: ModalEnv -> !LetBindings
- Agda.TypeChecking.Monad.Base: [envMutualBlock] :: TCEnv -> Maybe MutualId
+ Agda.TypeChecking.Monad.Base: [envMutualBlock] :: ColdEnv -> !Maybe MutualId
- Agda.TypeChecking.Monad.Base: [envPrintingPatternLambdas] :: TCEnv -> [QName]
+ Agda.TypeChecking.Monad.Base: [envPrintingPatternLambdas] :: ColdEnv -> [QName]
- Agda.TypeChecking.Monad.Base: [envQuantity] :: TCEnv -> Quantity
+ Agda.TypeChecking.Monad.Base: [envQuantity] :: ModalEnv -> !Quantity
- Agda.TypeChecking.Monad.Base: [envRange] :: TCEnv -> Range
+ Agda.TypeChecking.Monad.Base: [envRange] :: ColdEnv -> Range
- Agda.TypeChecking.Monad.Base: [envReduceDefs] :: TCEnv -> ReduceDefs
+ Agda.TypeChecking.Monad.Base: [envReduceDefs] :: ColdEnv -> !ReduceDefs
- Agda.TypeChecking.Monad.Base: [envRelevance] :: TCEnv -> Relevance
+ Agda.TypeChecking.Monad.Base: [envRelevance] :: ModalEnv -> !Relevance
- Agda.TypeChecking.Monad.Base: [envSimplification] :: TCEnv -> Simplification
+ Agda.TypeChecking.Monad.Base: [envSimplification] :: ColdEnv -> !Simplification
- Agda.TypeChecking.Monad.Base: [envSyntacticEqualityFuel] :: TCEnv -> !Maybe Int
+ Agda.TypeChecking.Monad.Base: [envSyntacticEqualityFuel] :: ColdEnv -> !Maybe Int
- Agda.TypeChecking.Monad.Base: [envTerminationCheck] :: TCEnv -> TerminationCheck ()
+ Agda.TypeChecking.Monad.Base: [envTerminationCheck] :: ColdEnv -> !TerminationCheck ()
- Agda.TypeChecking.Monad.Base: [envUnquoteFlags] :: TCEnv -> UnquoteFlags
+ Agda.TypeChecking.Monad.Base: [envUnquoteFlags] :: ColdEnv -> !UnquoteFlags
- Agda.TypeChecking.Monad.Base: [envUnquoteProblem] :: TCEnv -> Maybe ProblemId
+ Agda.TypeChecking.Monad.Base: [envUnquoteProblem] :: ColdEnv -> !Maybe ProblemId
- Agda.TypeChecking.Monad.Base: [ipcClauseNo] :: IPClause -> Int
+ Agda.TypeChecking.Monad.Base: [ipcClauseNo] :: IPClause -> ClauseNumber
- Agda.TypeChecking.Monad.Base: [ipcWithSub] :: IPClause -> Maybe Substitution
+ Agda.TypeChecking.Monad.Base: [ipcWithSub] :: IPClause -> IsWithFunction Substitution
- Agda.TypeChecking.Monad.Base: [redEnv] :: ReduceEnv -> TCEnv
+ Agda.TypeChecking.Monad.Base: [redEnv] :: ReduceEnv -> !TCEnv
- Agda.TypeChecking.Monad.Base: [redPred] :: ReduceEnv -> Maybe (MetaId -> ReduceM Bool)
+ Agda.TypeChecking.Monad.Base: [redPred] :: ReduceEnv -> !Maybe (MetaId -> ReduceM Bool)
- Agda.TypeChecking.Monad.Base: [redSt] :: ReduceEnv -> TCState
+ Agda.TypeChecking.Monad.Base: [redSt] :: ReduceEnv -> !TCState
- Agda.TypeChecking.Monad.Base: [stPersistentSession] :: PersistentTCState -> !SessionTCState
+ Agda.TypeChecking.Monad.Base: [stPersistentSession] :: PersistentTCState -> !Atomic SessionState
- Agda.TypeChecking.Monad.Base: [stPostAwakeConstraints] :: PostScopeState -> !Constraints
+ Agda.TypeChecking.Monad.Base: [stPostAwakeConstraints] :: PostMetaState -> !Constraints
- Agda.TypeChecking.Monad.Base: [stPostConcreteNames] :: PostScopeState -> !ConcreteNames
+ Agda.TypeChecking.Monad.Base: [stPostConcreteNames] :: PostColdState -> !ConcreteNames
- Agda.TypeChecking.Monad.Base: [stPostCurrentModule] :: PostScopeState -> !Maybe (ModuleName, TopLevelModuleName)
+ Agda.TypeChecking.Monad.Base: [stPostCurrentModule] :: PostColdState -> !Maybe (Pair ModuleName TopLevelModuleName)
- Agda.TypeChecking.Monad.Base: [stPostDisambiguatedNames] :: PostScopeState -> !DisambiguatedNames
+ Agda.TypeChecking.Monad.Base: [stPostDisambiguatedNames] :: PostColdState -> !DisambiguatedNames
- Agda.TypeChecking.Monad.Base: [stPostForeignCode] :: PostScopeState -> !BackendForeignCode
+ Agda.TypeChecking.Monad.Base: [stPostForeignCode] :: PostColdState -> !BackendForeignCode
- Agda.TypeChecking.Monad.Base: [stPostFreshCheckpointId] :: PostScopeState -> !CheckpointId
+ Agda.TypeChecking.Monad.Base: [stPostFreshCheckpointId] :: PostNamesCheckpoints -> !CheckpointId
- Agda.TypeChecking.Monad.Base: [stPostFreshInt] :: PostScopeState -> !Int
+ Agda.TypeChecking.Monad.Base: [stPostFreshInt] :: PostColdState -> !Int
- Agda.TypeChecking.Monad.Base: [stPostFreshMetaId] :: PostScopeState -> !MetaId
+ Agda.TypeChecking.Monad.Base: [stPostFreshMetaId] :: PostMetaState -> !MetaId
- Agda.TypeChecking.Monad.Base: [stPostFreshMutualId] :: PostScopeState -> !MutualId
+ Agda.TypeChecking.Monad.Base: [stPostFreshMutualId] :: PostColdState -> !MutualId
- Agda.TypeChecking.Monad.Base: [stPostFreshNameId] :: PostScopeState -> !NameId
+ Agda.TypeChecking.Monad.Base: [stPostFreshNameId] :: PostColdState -> !NameId
- Agda.TypeChecking.Monad.Base: [stPostFreshOpaqueId] :: PostScopeState -> !OpaqueId
+ Agda.TypeChecking.Monad.Base: [stPostFreshOpaqueId] :: PostColdState -> !OpaqueId
- Agda.TypeChecking.Monad.Base: [stPostFreshProblemId] :: PostScopeState -> !ProblemId
+ Agda.TypeChecking.Monad.Base: [stPostFreshProblemId] :: PostMetaState -> !ProblemId
- Agda.TypeChecking.Monad.Base: [stPostImportsDisplayForms] :: PostScopeState -> !DisplayForms
+ Agda.TypeChecking.Monad.Base: [stPostImportsDisplayForms] :: PostColdState -> !DisplayForms
- Agda.TypeChecking.Monad.Base: [stPostInteractionPoints] :: PostScopeState -> !InteractionPoints
+ Agda.TypeChecking.Monad.Base: [stPostInteractionPoints] :: PostColdState -> !InteractionPoints
- Agda.TypeChecking.Monad.Base: [stPostLocalBuiltins] :: PostScopeState -> !BuiltinThings
+ Agda.TypeChecking.Monad.Base: [stPostLocalBuiltins] :: PostColdState -> !BuiltinThings
- Agda.TypeChecking.Monad.Base: [stPostLocalPartialDefs] :: PostScopeState -> !Set QName
+ Agda.TypeChecking.Monad.Base: [stPostLocalPartialDefs] :: PostColdState -> !Set QName
- Agda.TypeChecking.Monad.Base: [stPostModuleCheckpoints] :: PostScopeState -> !Map ModuleName CheckpointId
+ Agda.TypeChecking.Monad.Base: [stPostModuleCheckpoints] :: PostNamesCheckpoints -> !ModuleCheckpoints
- Agda.TypeChecking.Monad.Base: [stPostMutualBlocks] :: PostScopeState -> !MutualBlocks
+ Agda.TypeChecking.Monad.Base: [stPostMutualBlocks] :: PostColdState -> !MutualBlocks
- Agda.TypeChecking.Monad.Base: [stPostOccursCheckDefs] :: PostScopeState -> !Set QName
+ Agda.TypeChecking.Monad.Base: [stPostOccursCheckDefs] :: PostMetaState -> !Set QName
- Agda.TypeChecking.Monad.Base: [stPostOpaqueBlocks] :: PostScopeState -> Map OpaqueId OpaqueBlock
+ Agda.TypeChecking.Monad.Base: [stPostOpaqueBlocks] :: PostColdState -> !Map OpaqueId OpaqueBlock
- Agda.TypeChecking.Monad.Base: [stPostOpaqueIds] :: PostScopeState -> Map QName OpaqueId
+ Agda.TypeChecking.Monad.Base: [stPostOpaqueIds] :: PostColdState -> !Map QName OpaqueId
- Agda.TypeChecking.Monad.Base: [stPostOpenMetaStore] :: PostScopeState -> !LocalMetaStore
+ Agda.TypeChecking.Monad.Base: [stPostOpenMetaStore] :: PostMetaState -> !LocalMetaStore
- Agda.TypeChecking.Monad.Base: [stPostPendingInstances] :: PostScopeState -> !Set QName
+ Agda.TypeChecking.Monad.Base: [stPostPendingInstances] :: PostColdState -> !Set QName
- Agda.TypeChecking.Monad.Base: [stPostSignature] :: PostScopeState -> !Signature
+ Agda.TypeChecking.Monad.Base: [stPostSignature] :: PostColdState -> !Signature
- Agda.TypeChecking.Monad.Base: [stPostSleepingConstraints] :: PostScopeState -> !Constraints
+ Agda.TypeChecking.Monad.Base: [stPostSleepingConstraints] :: PostMetaState -> !Constraints
- Agda.TypeChecking.Monad.Base: [stPostSolvedMetaStore] :: PostScopeState -> !LocalMetaStore
+ Agda.TypeChecking.Monad.Base: [stPostSolvedMetaStore] :: PostMetaState -> !LocalMetaStore
- Agda.TypeChecking.Monad.Base: [stPostStatistics] :: PostScopeState -> !Statistics
+ Agda.TypeChecking.Monad.Base: [stPostStatistics] :: PostColdState -> !Statistics
- Agda.TypeChecking.Monad.Base: [stPostSyntaxInfo] :: PostScopeState -> !HighlightingInfo
+ Agda.TypeChecking.Monad.Base: [stPostSyntaxInfo] :: PostColdState -> !HighlightingInfo
- Agda.TypeChecking.Monad.Base: [stPostTCWarnings] :: PostScopeState -> !Set TCWarning
+ Agda.TypeChecking.Monad.Base: [stPostTCWarnings] :: PostColdState -> !Set TCWarning
- Agda.TypeChecking.Monad.Base: [stPostTemporaryInstances] :: PostScopeState -> !Set QName
+ Agda.TypeChecking.Monad.Base: [stPostTemporaryInstances] :: PostColdState -> !Set QName
- Agda.TypeChecking.Monad.Base: [stSessionBackends] :: SessionTCState -> [Backend]
+ Agda.TypeChecking.Monad.Base: [stSessionBackends] :: SessionState -> [Backend]
- Agda.TypeChecking.Monad.Base: [stSessionFileDict] :: SessionTCState -> !FileDictWithBuiltins
+ Agda.TypeChecking.Monad.Base: [stSessionFileDict] :: SessionState -> !FileDictWithBuiltins
- Agda.TypeChecking.Monad.Base: dataClause :: Defn -> Maybe Clause
+ Agda.TypeChecking.Monad.Base: dataClause :: Defn -> Maybe Term
- Agda.TypeChecking.Monad.Base: funWith :: Defn -> Maybe QName
+ Agda.TypeChecking.Monad.Base: funWith :: Defn -> IsWithFunction QName
- Agda.TypeChecking.Monad.Base: initPersistentStateFromSessionState :: SessionTCState -> PersistentTCState
+ Agda.TypeChecking.Monad.Base: initPersistentStateFromSessionState :: Atomic SessionState -> PersistentTCState
- Agda.TypeChecking.Monad.Base: initSessionState :: AbsolutePath -> SessionTCState
+ Agda.TypeChecking.Monad.Base: initSessionState :: AbsolutePath -> SessionState
- Agda.TypeChecking.Monad.Base: initState :: AbsolutePath -> TCState
+ Agda.TypeChecking.Monad.Base: initState :: AbsolutePath -> IO TCState
- Agda.TypeChecking.Monad.Base: initStateFromSessionState :: SessionTCState -> TCState
+ Agda.TypeChecking.Monad.Base: initStateFromSessionState :: Atomic SessionState -> TCState
- Agda.TypeChecking.Monad.Base: isCopatternLHS :: [Clause] -> Bool
+ Agda.TypeChecking.Monad.Base: isCopatternLHS :: Foldable f => f Clause -> Bool
- Agda.TypeChecking.Monad.Base: lensBackends :: Lens' SessionTCState [Backend]
+ Agda.TypeChecking.Monad.Base: lensBackends :: Lens' SessionState [Backend]
- Agda.TypeChecking.Monad.Base: lensBuiltinModuleIds :: Lens' SessionTCState BuiltinModuleIds
+ Agda.TypeChecking.Monad.Base: lensBuiltinModuleIds :: Lens' SessionState BuiltinModuleIds
- Agda.TypeChecking.Monad.Base: lensFileDict :: Lens' SessionTCState FileDictWithBuiltins
+ Agda.TypeChecking.Monad.Base: lensFileDict :: Lens' SessionState FileDictWithBuiltins
- Agda.TypeChecking.Monad.Base: lensFileDictBuilder :: Lens' SessionTCState FileDictBuilder
+ Agda.TypeChecking.Monad.Base: lensFileDictBuilder :: Lens' SessionState FileDictBuilder
- Agda.TypeChecking.Monad.Base: lensModuleCheckpoints :: Lens' PostScopeState (Map ModuleName CheckpointId)
+ Agda.TypeChecking.Monad.Base: lensModuleCheckpoints :: Lens' PostScopeState ModuleCheckpoints
- Agda.TypeChecking.Monad.Base: lensModuleToSourceId :: Lens' PreScopeState ModuleToSourceId
+ Agda.TypeChecking.Monad.Base: lensModuleToSourceId :: Lens' SessionState ModuleToSourceId
- Agda.TypeChecking.Monad.Base: lensPersistentSession :: Lens' PersistentTCState SessionTCState
+ Agda.TypeChecking.Monad.Base: lensPersistentSession :: Lens' PersistentTCState (Atomic SessionState)
- Agda.TypeChecking.Monad.Base: lensPrimitiveLibDir :: Lens' SessionTCState PrimitiveLibDir
+ Agda.TypeChecking.Monad.Base: lensPrimitiveLibDir :: Lens' SessionState PrimitiveLibDir
- Agda.TypeChecking.Monad.Base: pattern Constructor :: Int -> Int -> ConHead -> QName -> IsAbstract -> CompKit -> Maybe [QName] -> [IsForced] -> Maybe [Bool] -> Bool -> Bool -> Defn
+ Agda.TypeChecking.Monad.Base: pattern Constructor :: Int -> Int -> ConHead -> QName -> IsAbstract -> IsPathCons -> CompKit -> Maybe [QName] -> [IsForced] -> Maybe [Bool] -> Bool -> Bool -> Defn
- Agda.TypeChecking.Monad.Base: pattern DataOrRecSig :: Int -> Defn
+ Agda.TypeChecking.Monad.Base: pattern DataOrRecSig :: Int -> DataOrRecord_ -> 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 Datatype :: Nat -> Nat -> Maybe Term -> [QName] -> Sort -> Maybe [QName] -> PositivityCheck -> IsAbstract -> IsHIT -> Maybe QName -> Maybe QName -> Defn
- Agda.TypeChecking.Monad.Base: pattern Function :: [Clause] -> Maybe CompiledClauses -> Maybe SplitTree -> Maybe Compiled -> [Clause] -> FunctionInverse -> Maybe [QName] -> Either ProjectionLikenessMissing Projection -> SmallSet FunctionFlag -> Maybe Bool -> Maybe ExtLamInfo -> Maybe QName -> Maybe QName -> IsOpaque -> Defn
+ Agda.TypeChecking.Monad.Base: pattern Function :: [Clause] -> Maybe CompiledClauses -> Maybe SplitTree -> Maybe Compiled -> [Clause] -> FunctionInverse -> Maybe [QName] -> Either ProjectionLikenessMissing Projection -> SmallSet FunctionFlag -> Maybe Bool -> Maybe ExtLamInfo -> IsWithFunction QName -> Maybe QName -> IsOpaque -> 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: pattern Record :: Nat -> Maybe Term -> ConHead -> Bool -> [Dom QName] -> Telescope -> Maybe [QName] -> PositivityCheck -> EtaEquality -> PatternOrCopattern -> Maybe Induction -> Maybe Bool -> IsAbstract -> CompKit -> Defn
- Agda.TypeChecking.Monad.Base: recClause :: Defn -> Maybe Clause
+ Agda.TypeChecking.Monad.Base: recClause :: Defn -> Maybe Term
- Agda.TypeChecking.Monad.Base: runBlocked :: Monad m => BlockT m a -> m (Either Blocker a)
+ Agda.TypeChecking.Monad.Base: runBlocked :: BlockT m a -> m (Either Blocker a)
- Agda.TypeChecking.Monad.Base: setEtaEquality :: EtaEquality -> HasEta -> EtaEquality
+ Agda.TypeChecking.Monad.Base: setEtaEquality :: EtaEquality -> EtaEquality -> EtaEquality
- Agda.TypeChecking.Monad.Base: sigRewriteRules :: Lens' Signature RewriteRuleMap
+ Agda.TypeChecking.Monad.Base: sigRewriteRules :: Lens' Signature GlobalRewriteRuleMap
- Agda.TypeChecking.Monad.Base: stCurrentModule :: Lens' TCState (Maybe (ModuleName, TopLevelModuleName))
+ Agda.TypeChecking.Monad.Base: stCurrentModule :: Lens' TCState (Maybe (Pair ModuleName TopLevelModuleName))
- Agda.TypeChecking.Monad.Base: stModuleCheckpoints :: Lens' TCState (Map ModuleName CheckpointId)
+ Agda.TypeChecking.Monad.Base: stModuleCheckpoints :: Lens' TCState ModuleCheckpoints
- Agda.TypeChecking.Monad.Base: stRewriteRules :: Lens' TCState RewriteRuleMap
+ Agda.TypeChecking.Monad.Base: stRewriteRules :: Lens' TCState GlobalRewriteRuleMap
- Agda.TypeChecking.Monad.Base: topLevelModuleFilePath :: ModuleToSource -> TopLevelModuleName -> AbsolutePath
+ Agda.TypeChecking.Monad.Base: topLevelModuleFilePath :: HasCallStack => ModuleToSource -> TopLevelModuleName -> AbsolutePath
- Agda.TypeChecking.Monad.Base: type DisplayForms = HashMap QName [LocalDisplayForm]
+ Agda.TypeChecking.Monad.Base: type DisplayForms = HashMap QName List1 LocalDisplayForm
- Agda.TypeChecking.Monad.Base.Types: NamedMeta :: MetaNameSuggestion -> MetaId -> NamedMeta
+ Agda.TypeChecking.Monad.Base.Types: NamedMeta :: MetaNameSuggestion -> {-# UNPACK #-} !MetaId -> NamedMeta
- Agda.TypeChecking.Monad.Base.Types: [nmid] :: NamedMeta -> MetaId
+ Agda.TypeChecking.Monad.Base.Types: [nmid] :: NamedMeta -> {-# UNPACK #-} !MetaId
- Agda.TypeChecking.Monad.Base.Types: type Context = [ContextEntry]
+ Agda.TypeChecking.Monad.Base.Types: type Context = Context' ContextEntry
- Agda.TypeChecking.Monad.Builtin: sortKit :: (HasBuiltins m, MonadTCError m, HasOptions m) => m SortKit
+ Agda.TypeChecking.Monad.Builtin: sortKit :: (HasBuiltins m, MonadTCError m) => m SortKit
- Agda.TypeChecking.Monad.Context: ($dmaddLetBinding') :: forall (n :: Type -> Type) (t :: (Type -> Type) -> Type -> Type) a. (MonadAddContext m, MonadAddContext n, MonadTransControl t, t n ~ m) => Origin -> Name -> Term -> Dom Type -> m a -> m a
+ Agda.TypeChecking.Monad.Context: ($dmaddLetBinding') :: forall (n :: Type -> Type) (t :: (Type -> Type) -> Type -> Type) a. (MonadAddContext m, MonadAddContext n, MonadTransControl t, t n ~ m) => IsAxiom -> Origin -> Name -> Term -> Dom Type -> m a -> m a
- Agda.TypeChecking.Monad.Context: addLetBinding :: MonadAddContext m => ArgInfo -> Origin -> Name -> Term -> Type -> m a -> m a
+ Agda.TypeChecking.Monad.Context: addLetBinding :: MonadWarning m => ArgInfo -> Origin -> Name -> Term -> Type -> m a -> m a
- Agda.TypeChecking.Monad.Context: addLetBinding' :: MonadAddContext m => Origin -> Name -> Term -> Dom Type -> m a -> m a
+ Agda.TypeChecking.Monad.Context: addLetBinding' :: MonadAddContext m => IsAxiom -> Origin -> Name -> Term -> Dom Type -> m a -> m a
- Agda.TypeChecking.Monad.Context: checkpoint :: (MonadDebug tcm, MonadTCM tcm, MonadFresh CheckpointId tcm, ReadTCState tcm) => Substitution -> tcm a -> tcm a
+ Agda.TypeChecking.Monad.Context: checkpoint :: Substitution -> TCM a -> TCM a
- Agda.TypeChecking.Monad.Context: defaultAddLetBinding' :: (ReadTCState m, MonadTCEnv m) => Origin -> Name -> Term -> Dom Type -> m a -> m a
+ Agda.TypeChecking.Monad.Context: defaultAddLetBinding' :: (ReadTCState m, MonadTCEnv m) => IsAxiom -> Origin -> Name -> Term -> Dom Type -> m a -> m a
- Agda.TypeChecking.Monad.Context: getVarInfo :: (MonadDebug m, MonadTCEnv m) => Name -> m (Term, Dom Type)
+ Agda.TypeChecking.Monad.Context: getVarInfo :: (MonadDebug m, MonadFail m, MonadTCEnv m) => Name -> m (Term, Dom Type)
- Agda.TypeChecking.Monad.Context: mapAbstraction :: (Subst a, Subst b, MonadAddContext m) => Dom Type -> (a -> m b) -> Abs a -> m (Abs b)
+ Agda.TypeChecking.Monad.Context: mapAbstraction :: (Subst a, MonadAddContext m) => Dom Type -> (a -> m b) -> Abs a -> m (Abs b)
- Agda.TypeChecking.Monad.Context: mapAbstraction_ :: (Subst a, Subst b, MonadAddContext m) => (a -> m b) -> Abs a -> m (Abs b)
+ Agda.TypeChecking.Monad.Context: mapAbstraction_ :: (Subst a, MonadAddContext m) => (a -> m b) -> Abs a -> m (Abs b)
- Agda.TypeChecking.Monad.Debug: ($dmformatDebugMessage) :: forall (t :: (Type -> Type) -> Type -> Type) (n :: Type -> Type). (MonadDebug m, MonadTrans t, MonadDebug n, m ~ t n) => VerboseKey -> VerboseLevel -> TCM Doc -> m String
+ Agda.TypeChecking.Monad.Debug: ($dmformatDebugMessage) :: forall (t :: (Type -> Type) -> Type -> Type) (n :: Type -> Type). (MonadDebug m, MonadTrans t, MonadDebug n, m ~ t n) => VerboseKey -> VerboseLevel -> TCM Doc -> m Doc
- Agda.TypeChecking.Monad.Debug: ($dmtraceDebugMessage) :: forall (t :: (Type -> Type) -> Type -> Type) (n :: Type -> Type) a. (MonadDebug m, MonadTransControl t, MonadDebug n, m ~ t n) => VerboseKey -> VerboseLevel -> String -> m a -> m a
+ Agda.TypeChecking.Monad.Debug: ($dmtraceDebugMessage) :: forall (t :: (Type -> Type) -> Type -> Type) (n :: Type -> Type) a. (MonadDebug m, MonadTransControl t, MonadDebug n, m ~ t n) => VerboseKey -> VerboseLevel -> Doc -> m a -> m a
- Agda.TypeChecking.Monad.Debug: __CRASH_WHEN__ :: (HasCallStack, MonadTCM m, MonadDebug m) => VerboseKey -> VerboseLevel -> m ()
+ Agda.TypeChecking.Monad.Debug: __CRASH_WHEN__ :: (HasCallStack, MonadDebug m) => VerboseKey -> VerboseLevel -> m ()
- Agda.TypeChecking.Monad.Debug: catchAndPrintImpossible :: (CatchImpossible m, Monad m) => VerboseKey -> VerboseLevel -> m String -> m String
+ Agda.TypeChecking.Monad.Debug: catchAndPrintImpossible :: (CatchImpossible m, Monad m) => VerboseKey -> VerboseLevel -> m DocTree -> m DocTree
- Agda.TypeChecking.Monad.Debug: displayDebugMessage :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m ()
+ Agda.TypeChecking.Monad.Debug: displayDebugMessage :: MonadDebug m => VerboseKey -> VerboseLevel -> Doc -> m ()
- Agda.TypeChecking.Monad.Debug: formatDebugMessage :: MonadDebug m => VerboseKey -> VerboseLevel -> TCM Doc -> m String
+ Agda.TypeChecking.Monad.Debug: formatDebugMessage :: MonadDebug m => VerboseKey -> VerboseLevel -> TCM Doc -> m Doc
- Agda.TypeChecking.Monad.Debug: traceDebugMessage :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m a -> m a
+ Agda.TypeChecking.Monad.Debug: traceDebugMessage :: MonadDebug m => VerboseKey -> VerboseLevel -> Doc -> m a -> m a
- Agda.TypeChecking.Monad.MetaVars: LocalMetaStores :: LocalMetaStore -> LocalMetaStore -> LocalMetaStores
+ Agda.TypeChecking.Monad.MetaVars: LocalMetaStores :: !LocalMetaStore -> !LocalMetaStore -> LocalMetaStores
- Agda.TypeChecking.Monad.MetaVars: [openMetas] :: LocalMetaStores -> LocalMetaStore
+ Agda.TypeChecking.Monad.MetaVars: [openMetas] :: LocalMetaStores -> !LocalMetaStore
- Agda.TypeChecking.Monad.MetaVars: [solvedMetas] :: LocalMetaStores -> LocalMetaStore
+ Agda.TypeChecking.Monad.MetaVars: [solvedMetas] :: LocalMetaStores -> !LocalMetaStore
- Agda.TypeChecking.Monad.MetaVars: dontAssignMetas :: (MonadTCEnv m, HasOptions m, MonadDebug m) => m a -> m a
+ Agda.TypeChecking.Monad.MetaVars: dontAssignMetas :: (MonadTCEnv m, MonadDebug m) => m a -> m a
- Agda.TypeChecking.Monad.MetaVars: freezeMetas :: (MonadTCState m, ReadTCState m) => LocalMetaStore -> m (Set MetaId)
+ Agda.TypeChecking.Monad.MetaVars: freezeMetas :: (MonadTCState m, ReadTCState m, Traversable t) => t MetaId -> m (Set MetaId)
- Agda.TypeChecking.Monad.MetaVars: getMetaTypeInContext :: (HasBuiltins m, HasCallStack, MonadDebug m, MonadReduce m, MonadTCEnv m, ReadTCState m) => MetaId -> m Type
+ Agda.TypeChecking.Monad.MetaVars: getMetaTypeInContext :: (HasBuiltins m, HasCallStack, MonadDebug m, MonadReduce m) => MetaId -> m Type
- Agda.TypeChecking.Monad.MetaVars: withInteractionId :: (MonadDebug m, ReadTCState m, MonadError TCErr m, MonadTCEnv m, MonadTrace m) => InteractionId -> m a -> m a
+ Agda.TypeChecking.Monad.MetaVars: withInteractionId :: (MonadDebug m, MonadError TCErr m, MonadTrace m) => InteractionId -> 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.MetaVars: withMetaId :: (HasCallStack, MonadDebug m, MonadTrace m) => MetaId -> m a -> m a
- Agda.TypeChecking.Monad.MetaVars: withMetaInfo :: (MonadTCEnv m, ReadTCState m, MonadTrace m) => Closure Range -> m a -> m a
+ Agda.TypeChecking.Monad.MetaVars: withMetaInfo :: MonadTrace m => Closure Range -> m a -> m a
- Agda.TypeChecking.Monad.MetaVars: withMetaInfo' :: (MonadTCEnv m, ReadTCState m, MonadTrace m) => MetaVariable -> m a -> m a
+ Agda.TypeChecking.Monad.MetaVars: withMetaInfo' :: MonadTrace m => MetaVariable -> m a -> m a
- Agda.TypeChecking.Monad.Modality: applyModalityToContext :: (MonadTCEnv tcm, LensModality m) => m -> tcm a -> tcm a
+ Agda.TypeChecking.Monad.Modality: applyModalityToContext :: (MonadTCEnv tcm, ExpandCase (tcm a), LensModality m) => m -> tcm a -> tcm a
- Agda.TypeChecking.Monad.Modality: applyModalityToContextFunBody :: (MonadTCM tcm, LensModality r) => r -> tcm a -> tcm a
+ Agda.TypeChecking.Monad.Modality: applyModalityToContextFunBody :: (MonadTCM tcm, LensModality r, ExpandCase (tcm a)) => r -> tcm a -> tcm a
- Agda.TypeChecking.Monad.Modality: applyRelevanceToContextFunBody :: (MonadTCM tcm, LensRelevance r) => r -> tcm a -> tcm a
+ Agda.TypeChecking.Monad.Modality: applyRelevanceToContextFunBody :: (MonadTCM tcm, ExpandCase (tcm a), LensRelevance r) => r -> tcm a -> tcm a
- Agda.TypeChecking.Monad.Options: addDefaultLibraries :: AbsolutePath -> CommandLineOptions -> TCM CommandLineOptions
+ Agda.TypeChecking.Monad.Options: addDefaultLibraries :: AbsolutePath -> CommandLineOptions -> TCM (Maybe AgdaLibFile, CommandLineOptions)
- Agda.TypeChecking.Monad.Options: getIncludeDirs :: HasOptions m => m (List1 AbsolutePath)
+ Agda.TypeChecking.Monad.Options: getIncludeDirs :: TCM (List1 AbsolutePath)
- Agda.TypeChecking.Monad.Options: setLibraryIncludes :: CommandLineOptions -> TCM CommandLineOptions
+ Agda.TypeChecking.Monad.Options: setLibraryIncludes :: Maybe AgdaLibFile -> CommandLineOptions -> TCM CommandLineOptions
- Agda.TypeChecking.Monad.Pure: class (HasBuiltins m, HasConstInfo m, MonadAddContext m, MonadDebug m, MonadReduce m, MonadTCEnv m, ReadTCState m) => PureTCM (m :: Type -> Type)
+ Agda.TypeChecking.Monad.Pure: class (HasBuiltins m, HasConstInfo m, MonadAddContext m, MonadDebug m, MonadFileId m, MonadReduce m, MonadTCEnv m, ReadTCState m) => PureTCM (m :: Type -> Type)
- Agda.TypeChecking.Monad.Signature: ($dmgetConstInfo') :: forall (n :: Type -> Type) (t :: (Type -> Type) -> Type -> Type). (HasConstInfo m, HasConstInfo n, MonadTrans t, m ~ t n) => QName -> m (Either SigError Definition)
+ Agda.TypeChecking.Monad.Signature: ($dmgetConstInfo') :: forall (n :: Type -> Type) (t :: (Type -> Type) -> Type -> Type). (HasConstInfo m, HasCallStack, HasConstInfo n, MonadTrans t, m ~ t n) => QName -> m (Either SigError Definition)
- Agda.TypeChecking.Monad.Signature: defaultGetConstInfo :: (HasOptions m, MonadDebug m, MonadTCEnv m) => TCState -> TCEnv -> QName -> m (Either SigError Definition)
+ Agda.TypeChecking.Monad.Signature: defaultGetConstInfo :: (HasCallStack, HasOptions m, MonadDebug m) => TCState -> TCEnv -> QName -> m (Either SigError Definition)
- Agda.TypeChecking.Monad.Signature: freeVarsToApply :: (Functor m, HasConstInfo m, HasOptions m, ReadTCState m, MonadTCEnv m, MonadDebug m) => QName -> m Args
+ Agda.TypeChecking.Monad.Signature: freeVarsToApply :: (HasConstInfo m, ReadTCState m) => QName -> m Args
- Agda.TypeChecking.Monad.Signature: getArgOccurrence :: QName -> Nat -> TCM Occurrence
+ Agda.TypeChecking.Monad.Signature: getArgOccurrence :: HasCallStack => QName -> Nat -> TCM Occurrence
- Agda.TypeChecking.Monad.Signature: getConInfo :: HasConstInfo m => ConHead -> m Definition
+ Agda.TypeChecking.Monad.Signature: getConInfo :: (HasCallStack, HasConstInfo m) => ConHead -> m Definition
- Agda.TypeChecking.Monad.Signature: getDefFreeVars :: (Functor m, Applicative m, ReadTCState m, MonadTCEnv m) => QName -> m Nat
+ Agda.TypeChecking.Monad.Signature: getDefFreeVars :: (ReadTCState m, MonadTCEnv m) => QName -> m Nat
- Agda.TypeChecking.Monad.Signature: getErasedConArgs :: HasConstInfo m => QName -> m [Bool]
+ Agda.TypeChecking.Monad.Signature: getErasedConArgs :: (HasCallStack, HasConstInfo m) => QName -> m [Bool]
- Agda.TypeChecking.Monad.Signature: getModuleFreeVars :: (Functor m, Applicative m, MonadTCEnv m, ReadTCState m) => ModuleName -> m Nat
+ Agda.TypeChecking.Monad.Signature: getModuleFreeVars :: (MonadTCEnv m, ReadTCState m) => ModuleName -> m Nat
- Agda.TypeChecking.Monad.Signature: getOriginalConstInfo :: (ReadTCState m, HasConstInfo m) => QName -> m Definition
+ Agda.TypeChecking.Monad.Signature: getOriginalConstInfo :: (HasCallStack, ReadTCState m, HasConstInfo m) => QName -> m Definition
- Agda.TypeChecking.Monad.Signature: getOriginalProjection :: HasConstInfo m => QName -> m QName
+ Agda.TypeChecking.Monad.Signature: getOriginalProjection :: (HasCallStack, HasConstInfo m) => QName -> m QName
- Agda.TypeChecking.Monad.Signature: getPolarity :: HasConstInfo m => QName -> m [Polarity]
+ Agda.TypeChecking.Monad.Signature: getPolarity :: (HasCallStack, HasConstInfo m) => QName -> m [Polarity]
- Agda.TypeChecking.Monad.Signature: getPolarity' :: HasConstInfo m => Comparison -> QName -> m [Polarity]
+ Agda.TypeChecking.Monad.Signature: getPolarity' :: (HasCallStack, HasConstInfo m) => Comparison -> QName -> m [Polarity]
- Agda.TypeChecking.Monad.Signature: getSection :: (Functor m, ReadTCState m) => ModuleName -> m (Maybe Section)
+ Agda.TypeChecking.Monad.Signature: getSection :: ReadTCState m => ModuleName -> m (Maybe Section)
- Agda.TypeChecking.Monad.Signature: inConcreteOrAbstractMode :: (MonadTCEnv m, HasConstInfo m) => QName -> (Definition -> m a) -> m a
+ Agda.TypeChecking.Monad.Signature: inConcreteOrAbstractMode :: HasConstInfo m => QName -> (Definition -> m a) -> m a
- Agda.TypeChecking.Monad.Signature: instantiateDef :: (Functor m, HasConstInfo m, HasOptions m, ReadTCState m, MonadTCEnv m, MonadDebug m) => Definition -> m Definition
+ Agda.TypeChecking.Monad.Signature: instantiateDef :: (HasConstInfo m, ReadTCState m) => Definition -> m Definition
- Agda.TypeChecking.Monad.Signature: instantiateRewriteRule :: (Functor m, HasConstInfo m, HasOptions m, ReadTCState m, MonadTCEnv m, MonadDebug m) => RewriteRule -> m RewriteRule
+ Agda.TypeChecking.Monad.Signature: instantiateRewriteRule :: (HasConstInfo m, ReadTCState m) => GlobalRewriteRule -> m GlobalRewriteRule
- Agda.TypeChecking.Monad.Signature: instantiateRewriteRules :: (Functor m, HasConstInfo m, HasOptions m, ReadTCState m, MonadTCEnv m, MonadDebug m) => RewriteRules -> m RewriteRules
+ Agda.TypeChecking.Monad.Signature: instantiateRewriteRules :: (HasConstInfo m, ReadTCState m) => GlobalRewriteRules -> m GlobalRewriteRules
- Agda.TypeChecking.Monad.Signature: lookupSection :: (Functor m, ReadTCState m) => ModuleName -> m Telescope
+ Agda.TypeChecking.Monad.Signature: lookupSection :: ReadTCState m => ModuleName -> m Telescope
- Agda.TypeChecking.Monad.Signature: moduleParamsToApply :: (Functor m, Applicative m, HasOptions m, MonadTCEnv m, ReadTCState m, MonadDebug m) => ModuleName -> m Args
+ Agda.TypeChecking.Monad.Signature: moduleParamsToApply :: (HasOptions m, MonadTCEnv m, ReadTCState m, MonadDebug m) => ModuleName -> m Args
- Agda.TypeChecking.Monad.Signature: setTerminates :: MonadTCState m => QName -> Bool -> m ()
+ Agda.TypeChecking.Monad.Signature: setTerminates :: MonadTCState m => QName -> Maybe Bool -> m ()
- Agda.TypeChecking.Monad.Signature: usesCopatterns :: (HasConstInfo m, HasBuiltins m) => QName -> m Bool
+ Agda.TypeChecking.Monad.Signature: usesCopatterns :: HasConstInfo m => QName -> m Bool
- Agda.TypeChecking.Monad.SizedTypes: sizeType :: (HasBuiltins m, MonadTCEnv m, ReadTCState m) => m Type
+ Agda.TypeChecking.Monad.SizedTypes: sizeType :: HasBuiltins m => m Type
- Agda.TypeChecking.Monad.SizedTypes: sizeView :: (HasBuiltins m, MonadTCEnv m, ReadTCState m) => Term -> m SizeView
+ Agda.TypeChecking.Monad.SizedTypes: sizeView :: HasBuiltins m => Term -> m SizeView
- Agda.TypeChecking.Monad.State: addRewriteRulesFor :: QName -> RewriteRules -> [QName] -> Signature -> Signature
+ Agda.TypeChecking.Monad.State: addRewriteRulesFor :: QName -> GlobalRewriteRules -> [QName] -> TCM ()
- Agda.TypeChecking.Monad.Statistics: printStatistics :: (MonadDebug m, MonadTCEnv m, HasOptions m) => Maybe TopLevelModuleName -> Statistics -> m ()
+ Agda.TypeChecking.Monad.Statistics: printStatistics :: MonadDebug m => Maybe TopLevelModuleName -> Statistics -> m ()
- Agda.TypeChecking.Monad.Statistics: tickMax :: MonadStatistics m => String -> Integer -> m ()
+ Agda.TypeChecking.Monad.Statistics: tickMax :: MonadStatistics m => String -> Word64 -> m ()
- Agda.TypeChecking.Monad.Statistics: tickN :: MonadStatistics m => String -> Integer -> m ()
+ Agda.TypeChecking.Monad.Statistics: tickN :: MonadStatistics m => String -> Word64 -> m ()
- Agda.TypeChecking.Names: glamN :: forall (m :: Type -> Type). (Functor m, Monad m) => [Arg ArgName] -> (NamesT m Args -> NamesT m Term) -> NamesT m Term
+ Agda.TypeChecking.Names: glamN :: forall (m :: Type -> Type). Monad m => [Arg ArgName] -> (NamesT m Args -> NamesT m Term) -> NamesT m Term
- Agda.TypeChecking.Opacity: hasAccessibleDef :: (ReadTCState m, MonadTCEnv m, HasConstInfo m) => QName -> m Bool
+ Agda.TypeChecking.Opacity: hasAccessibleDef :: (ReadTCState m, HasConstInfo m) => QName -> m Bool
- Agda.TypeChecking.Opacity: saturateOpaqueBlocks :: (MonadTCState m, ReadTCState m, MonadFresh OpaqueId m, MonadDebug m, MonadTrace m, MonadWarning m, MonadIO m) => m ()
+ Agda.TypeChecking.Opacity: saturateOpaqueBlocks :: (MonadTCState m, MonadFresh OpaqueId m, MonadTrace m, MonadWarning m, MonadIO m) => m ()
- Agda.TypeChecking.Patterns.Match: DontKnow :: OnlyLazy -> Blocked () -> Match a
+ Agda.TypeChecking.Patterns.Match: DontKnow :: MatchPrio -> OnlyLazy -> Blocked () -> Match a
- Agda.TypeChecking.Patterns.Match: No :: Match a
+ Agda.TypeChecking.Patterns.Match: No :: MatchPrio -> Match a
- Agda.TypeChecking.Polarity: computePolarity :: (HasOptions m, HasConstInfo m, HasBuiltins m, MonadTCEnv m, MonadTCState m, MonadReduce m, MonadAddContext m, MonadTCError m, MonadDebug m, MonadPretty m) => [QName] -> m ()
+ Agda.TypeChecking.Polarity: computePolarity :: [QName] -> TCM ()
- Agda.TypeChecking.Positivity.Occurrence: ConArgType :: QName -> Where
+ Agda.TypeChecking.Positivity.Occurrence: ConArgType :: !OccursPath -> !QName -> OccursPath
- Agda.TypeChecking.Positivity.Occurrence: ConEndpoint :: QName -> Where
+ Agda.TypeChecking.Positivity.Occurrence: ConEndpoint :: !OccursPath -> !QName -> OccursPath
- Agda.TypeChecking.Positivity.Occurrence: DefArg :: QName -> Nat -> Where
+ Agda.TypeChecking.Positivity.Occurrence: DefArg :: !OccursPath -> !QName -> !Nat -> OccursPath
- Agda.TypeChecking.Positivity.Occurrence: InClause :: Nat -> Where
+ Agda.TypeChecking.Positivity.Occurrence: InClause :: !OccursPath -> !Nat -> OccursPath
- Agda.TypeChecking.Positivity.Occurrence: InDefOf :: QName -> Where
+ Agda.TypeChecking.Positivity.Occurrence: InDefOf :: !OccursPath -> !QName -> OccursPath
- Agda.TypeChecking.Positivity.Occurrence: IndArgType :: QName -> Where
+ Agda.TypeChecking.Positivity.Occurrence: IndArgType :: !OccursPath -> !QName -> OccursPath
- Agda.TypeChecking.Positivity.Occurrence: LeftOfArrow :: Where
+ Agda.TypeChecking.Positivity.Occurrence: LeftOfArrow :: !OccursPath -> OccursPath
- Agda.TypeChecking.Positivity.Occurrence: Matched :: Where
+ Agda.TypeChecking.Positivity.Occurrence: Matched :: !OccursPath -> OccursPath
- Agda.TypeChecking.Positivity.Occurrence: MetaArg :: Where
+ Agda.TypeChecking.Positivity.Occurrence: MetaArg :: !OccursPath -> OccursPath
- Agda.TypeChecking.Positivity.Occurrence: OccursWhere :: Range -> Seq Where -> Seq Where -> OccursWhere
+ Agda.TypeChecking.Positivity.Occurrence: OccursWhere :: !Range -> !OccursPath -> OccursWhere
- Agda.TypeChecking.Positivity.Occurrence: UnderInf :: Where
+ Agda.TypeChecking.Positivity.Occurrence: UnderInf :: !OccursPath -> OccursPath
- Agda.TypeChecking.Positivity.Occurrence: VarArg :: Occurrence -> Nat -> Where
+ Agda.TypeChecking.Positivity.Occurrence: VarArg :: !OccursPath -> !Nat -> !Occurrence -> OccursPath
- Agda.TypeChecking.Pretty: type MonadAbsToCon (m :: Type -> Type) = (MonadFresh NameId m, MonadInteractionPoints m, MonadStConcreteNames m, HasOptions m, PureTCM m, IsString m Doc, Null m Doc, Semigroup m Doc)
+ Agda.TypeChecking.Pretty: type MonadAbsToCon (m :: Type -> Type) = (MonadFileId m, MonadFresh NameId m, MonadInteractionPoints m, MonadStConcreteNames m, HasOptions m, PureTCM m, IsString m Doc, Null m Doc, Semigroup m Doc)
- Agda.TypeChecking.Pretty.Warning: getAllUnsolvedWarnings :: (ReadTCState m, MonadWarning m, MonadTCM m) => m [TCWarning]
+ Agda.TypeChecking.Pretty.Warning: getAllUnsolvedWarnings :: (MonadWarning m, MonadTCM m) => m [TCWarning]
- Agda.TypeChecking.Pretty.Warning: getAllWarnings :: (ReadTCState m, MonadWarning m, MonadTCM m) => WhichWarnings -> m (Set TCWarning)
+ Agda.TypeChecking.Pretty.Warning: getAllWarnings :: (MonadWarning m, MonadTCM m) => WhichWarnings -> m (Set TCWarning)
- Agda.TypeChecking.Pretty.Warning: getAllWarningsPreserving :: (ReadTCState m, MonadWarning m, MonadTCM m) => Set WarningName -> WhichWarnings -> m (Set TCWarning)
+ Agda.TypeChecking.Pretty.Warning: getAllWarningsPreserving :: (MonadWarning m, MonadTCM m) => Set WarningName -> WhichWarnings -> m (Set TCWarning)
- Agda.TypeChecking.Pretty.Warning: tcWarningsToError :: [TCWarning] -> TCM ()
+ Agda.TypeChecking.Pretty.Warning: tcWarningsToError :: TopLevelModuleNameWithSourceFile -> [TCWarning] -> TCM ()
- Agda.TypeChecking.Primitive: primitiveFunctions :: Map PrimitiveId (TCM PrimitiveImpl)
+ Agda.TypeChecking.Primitive: primitiveFunctions :: Map PrimitiveId (TCM (Maybe Type, PrimFun))
- Agda.TypeChecking.Primitive.Base: (-->) :: Applicative m => m Type -> m Type -> m Type
+ Agda.TypeChecking.Primitive.Base: (-->) :: HasOptions m => m Type -> m Type -> m Type
- Agda.TypeChecking.Primitive.Base: (.-->) :: Applicative m => m Type -> m Type -> m Type
+ Agda.TypeChecking.Primitive.Base: (.-->) :: HasOptions m => m Type -> m Type -> m Type
- Agda.TypeChecking.Primitive.Base: (..-->) :: Applicative m => m Type -> m Type -> m Type
+ Agda.TypeChecking.Primitive.Base: (..-->) :: HasOptions m => m Type -> m Type -> m Type
- Agda.TypeChecking.Primitive.Base: garr :: Applicative m => (Relevance -> Relevance) -> m Type -> m Type -> m Type
+ Agda.TypeChecking.Primitive.Base: garr :: HasOptions m => (Relevance -> Relevance) -> m Type -> m Type -> m Type
- Agda.TypeChecking.Primitive.Base: lookupPrimitiveFunctionQ :: QName -> TCM (PrimitiveId, PrimitiveImpl)
+ Agda.TypeChecking.Primitive.Base: lookupPrimitiveFunctionQ :: QName -> TCM (PrimitiveId, Maybe Type, PrimFun)
- Agda.TypeChecking.Primitive.Cubical: hcomp :: forall (m :: Type -> Type). (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: hcomp :: forall (m :: Type -> Type). (HasBuiltins m, MonadError TCErr m, MonadReduce m) => NamesT m Type -> [(NamesT m Term, NamesT m Term)] -> NamesT m Term -> NamesT m Term
- Agda.TypeChecking.Primitive.Cubical.Base: hfill :: forall (m :: Type -> Type). (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: hfill :: forall (m :: Type -> Type). HasBuiltins m => NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term
- Agda.TypeChecking.ProjectionLike: elimView :: PureTCM m => ProjEliminator -> Term -> m Term
+ Agda.TypeChecking.ProjectionLike: elimView :: PureTCM m => LoneProjectionLikeToLambda -> Term -> m Term
- Agda.TypeChecking.ReconstructParameters: reconstructAction :: Action TCM
+ Agda.TypeChecking.ReconstructParameters: reconstructAction :: Action
- Agda.TypeChecking.ReconstructParameters: reconstructAction' :: Action TCM -> Action TCM
+ Agda.TypeChecking.ReconstructParameters: reconstructAction' :: Action -> Action
- Agda.TypeChecking.ReconstructParameters: reconstructParameters' :: Action TCM -> Type -> Term -> TCM Term
+ Agda.TypeChecking.ReconstructParameters: reconstructParameters' :: Action -> Type -> Term -> TCM Term
- Agda.TypeChecking.ReconstructParameters: reconstructParametersInType' :: Action TCM -> Type -> TCM Type
+ Agda.TypeChecking.ReconstructParameters: reconstructParametersInType' :: Action -> Type -> TCM Type
- Agda.TypeChecking.Records: etaExpandRecord :: (HasConstInfo m, MonadDebug m, ReadTCState m) => QName -> Args -> Term -> m (Telescope, Args)
+ Agda.TypeChecking.Records: etaExpandRecord :: HasConstInfo m => QName -> Args -> Term -> m (Maybe (Telescope, Args))
- Agda.TypeChecking.Records: etaExpandRecord' :: (HasConstInfo m, MonadDebug m, ReadTCState m) => Bool -> QName -> Args -> Term -> m (Telescope, Args)
+ Agda.TypeChecking.Records: etaExpandRecord' :: HasConstInfo m => Bool -> QName -> Args -> Term -> m (Maybe (Telescope, Args))
- Agda.TypeChecking.Records: etaExpandRecord'_ :: HasConstInfo m => Bool -> QName -> Args -> RecordData -> Term -> m (Telescope, ConHead, ConInfo, Args)
+ Agda.TypeChecking.Records: etaExpandRecord'_ :: HasConstInfo m => Bool -> QName -> Args -> RecordData -> Term -> m (Maybe (Telescope, ConHead, ConInfo, Args))
- Agda.TypeChecking.Records: etaExpandRecord_ :: HasConstInfo m => QName -> Args -> RecordData -> Term -> m (Telescope, ConHead, ConInfo, Args)
+ Agda.TypeChecking.Records: etaExpandRecord_ :: HasConstInfo m => QName -> Args -> RecordData -> Term -> m (Maybe (Telescope, ConHead, ConInfo, Args))
- Agda.TypeChecking.Records: forceEtaExpandRecord :: (HasConstInfo m, MonadDebug m, ReadTCState m, MonadError TCErr m) => QName -> Args -> Term -> m (Telescope, Args)
+ Agda.TypeChecking.Records: forceEtaExpandRecord :: HasConstInfo m => QName -> Args -> Term -> m (Maybe (Telescope, Args))
- Agda.TypeChecking.Records: getRecordConstructor :: (HasConstInfo m, ReadTCState m, MonadError TCErr m) => QName -> m ConHead
+ Agda.TypeChecking.Records: getRecordConstructor :: (HasCallStack, HasConstInfo m, ReadTCState m, MonadError TCErr m) => QName -> m ConHead
- Agda.TypeChecking.Records: getRecordDef :: (HasConstInfo m, ReadTCState m, MonadError TCErr m) => QName -> m RecordData
+ Agda.TypeChecking.Records: getRecordDef :: (HasCallStack, HasConstInfo m, ReadTCState m, MonadError TCErr m) => QName -> m RecordData
- Agda.TypeChecking.Records: getRecordFieldNames :: (HasConstInfo m, ReadTCState m, MonadError TCErr m) => QName -> m [Dom Name]
+ Agda.TypeChecking.Records: getRecordFieldNames :: (HasCallStack, HasConstInfo m, ReadTCState m, MonadError TCErr m) => QName -> m [Dom Name]
- Agda.TypeChecking.Records: getRecordTypeFields :: Type -> TCM [Dom QName]
+ Agda.TypeChecking.Records: getRecordTypeFields :: HasCallStack => Type -> TCM [Dom QName]
- Agda.TypeChecking.Records: isEtaCon :: HasConstInfo m => QName -> m Bool
+ Agda.TypeChecking.Records: isEtaCon :: (HasCallStack, HasConstInfo m) => QName -> m Bool
- Agda.TypeChecking.Records: isEtaOrCoinductiveRecordConstructor :: HasConstInfo m => QName -> m Bool
+ Agda.TypeChecking.Records: isEtaOrCoinductiveRecordConstructor :: (HasCallStack, HasConstInfo m) => QName -> m Bool
- Agda.TypeChecking.Records: isEtaRecord :: HasConstInfo m => QName -> m Bool
+ Agda.TypeChecking.Records: isEtaRecord :: (HasCallStack, HasConstInfo m) => QName -> m Bool
- Agda.TypeChecking.Records: isEtaRecordConstructor :: HasConstInfo m => QName -> m (Maybe (QName, RecordData))
+ Agda.TypeChecking.Records: isEtaRecordConstructor :: (HasCallStack, HasConstInfo m) => QName -> m (Maybe (QName, RecordData))
- Agda.TypeChecking.Records: isEtaRecordType :: HasConstInfo m => Type -> m (Maybe (QName, Args))
+ Agda.TypeChecking.Records: isEtaRecordType :: (HasCallStack, HasConstInfo m) => Type -> m (Maybe (QName, Args))
- Agda.TypeChecking.Records: isInductiveRecord :: HasConstInfo m => QName -> m Bool
+ Agda.TypeChecking.Records: isInductiveRecord :: (HasCallStack, HasConstInfo m) => QName -> m Bool
- Agda.TypeChecking.Records: isRecord :: HasConstInfo m => QName -> m (Maybe RecordData)
+ Agda.TypeChecking.Records: isRecord :: (HasCallStack, HasConstInfo m) => QName -> m (Maybe RecordData)
- Agda.TypeChecking.Records: isRecordConstructor :: HasConstInfo m => QName -> m (Maybe (QName, RecordData))
+ Agda.TypeChecking.Records: isRecordConstructor :: (HasCallStack, HasConstInfo m) => QName -> m (Maybe (QName, RecordData))
- Agda.TypeChecking.Records: isRecordType :: PureTCM m => Type -> m (Maybe (QName, Args, RecordData))
+ Agda.TypeChecking.Records: isRecordType :: (HasCallStack, PureTCM m) => Type -> m (Maybe (QName, Args, RecordData))
- Agda.TypeChecking.Records: origProjection :: HasConstInfo m => QName -> m (QName, Definition, Maybe Projection)
+ Agda.TypeChecking.Records: origProjection :: (HasCallStack, HasConstInfo m) => QName -> m (QName, Definition, Maybe Projection)
- Agda.TypeChecking.Records: tryRecordType :: PureTCM m => Type -> m (Either (Blocked Type) (QName, Args, RecordData))
+ Agda.TypeChecking.Records: tryRecordType :: (HasCallStack, PureTCM m) => Type -> m (Either (Blocked Type) (QName, Args, RecordData))
- Agda.TypeChecking.Records: unguardedRecord :: QName -> PatternOrCopattern -> TCM ()
+ Agda.TypeChecking.Records: unguardedRecord :: QName -> TCM ()
- Agda.TypeChecking.Reduce: blockOnError :: MonadError TCErr m => Blocker -> m a -> m a
+ Agda.TypeChecking.Reduce: blockOnError :: Blocker -> TCM a -> TCM a
- Agda.TypeChecking.Reduce.Monad: enterClosure :: LensClosure c a => c -> (a -> ReduceM b) -> ReduceM b
+ Agda.TypeChecking.Reduce.Monad: enterClosure :: (MonadTCEnv m, ReadTCState m, LensClosure c a) => c -> (a -> m b) -> m b
- Agda.TypeChecking.Rewriting: checkRewriteRule :: QName -> TCM (Maybe RewriteRule)
+ Agda.TypeChecking.Rewriting: checkRewriteRule :: QName -> TCM (Maybe GlobalRewriteRule)
- Agda.TypeChecking.Rewriting.Clause: clauseToRewriteRule :: (MonadTCEnv m, ReadTCState m) => QName -> QName -> Clause -> m (Maybe RewriteRule)
+ Agda.TypeChecking.Rewriting.Clause: clauseToRewriteRule :: (MonadTCEnv m, ReadTCState m) => QName -> QName -> Clause -> m (Maybe GlobalRewriteRule)
- Agda.TypeChecking.Rewriting.Clause: getClausesAsRewriteRules :: (HasConstInfo m, ReadTCState m, MonadFresh NameId m) => QName -> m [RewriteRule]
+ Agda.TypeChecking.Rewriting.Clause: getClausesAsRewriteRules :: (HasConstInfo m, ReadTCState m, MonadFresh NameId m) => QName -> m [GlobalRewriteRule]
- Agda.TypeChecking.Rewriting.Confluence: checkConfluenceOfRules :: ConfluenceCheck -> [RewriteRule] -> TCM ()
+ Agda.TypeChecking.Rewriting.Confluence: checkConfluenceOfRules :: ConfluenceCheck -> [GlobalRewriteRule] -> TCM ()
- Agda.TypeChecking.Rewriting.NonLinPattern: nlPatVars :: NLPatVars a => a -> IntSet
+ Agda.TypeChecking.Rewriting.NonLinPattern: nlPatVars :: NLPatVars a => a -> PatVars
- Agda.TypeChecking.Rewriting.NonLinPattern: nlPatVarsUnder :: NLPatVars a => Int -> a -> IntSet
+ Agda.TypeChecking.Rewriting.NonLinPattern: nlPatVarsUnder :: NLPatVars a => Int -> a -> PatVars
- Agda.TypeChecking.Rewriting.NonLinPattern: patternFrom :: PatternFrom a b => Relevance -> Int -> TypeOf a -> a -> TCM b
+ Agda.TypeChecking.Rewriting.NonLinPattern: patternFrom :: PatternFrom a b => DefSing -> DefSing -> Int -> Int -> TypeOf a -> a -> TCM b
- Agda.TypeChecking.Rules.Application: checkProjAppToKnownPrincipalArg :: Comparison -> Expr -> ProjOrigin -> List1 QName -> Expr -> Args -> Type -> Int -> Term -> Type -> PrincipalArgTypeMetas -> TCM Term
+ Agda.TypeChecking.Rules.Application: checkProjAppToKnownPrincipalArg :: Comparison -> Expr -> ProjOrigin -> AmbiguousQName -> Expr -> Args -> Type -> Int -> Term -> Type -> PrincipalArgTypeMetas -> TCM Term
- Agda.TypeChecking.Rules.Builtin: bindUntypedBuiltin :: BuiltinId -> ResolvedName -> TCM ()
+ Agda.TypeChecking.Rules.Builtin: bindUntypedBuiltin :: BuiltinId -> QName -> ResolvedName -> TCM ()
- Agda.TypeChecking.Rules.Data: checkDataDef :: DefInfo -> QName -> UniverseCheck -> DataDefParams -> [Constructor] -> TCM ()
+ Agda.TypeChecking.Rules.Data: checkDataDef :: DefInfo -> QName -> PositivityCheck -> UniverseCheck -> DataDefParams -> [Constructor] -> TCM ()
- Agda.TypeChecking.Rules.Data: defineTranspFun :: QName -> Maybe QName -> [QName] -> [QName] -> TCM (Maybe QName)
+ Agda.TypeChecking.Rules.Data: defineTranspFun :: QName -> Maybe QName -> [QName] -> IsHIT -> TCM (Maybe QName)
- Agda.TypeChecking.Rules.Decl: checkAxiom :: KindOfName -> DefInfo -> ArgInfo -> Maybe PragmaPolarities -> QName -> Expr -> TCM ()
+ Agda.TypeChecking.Rules.Decl: checkAxiom :: Maybe GeneralizeTelescope -> KindOfName -> DefInfo -> ArgInfo -> Maybe PragmaPolarities -> QName -> Expr -> TCM ()
- Agda.TypeChecking.Rules.Decl: checkMutual :: MutualInfo -> [Declaration] -> TCM (MutualId, Set QName)
+ Agda.TypeChecking.Rules.Decl: checkMutual :: MutualInfo -> List1 Declaration -> TCM (MutualId, Set QName)
- Agda.TypeChecking.Rules.Decl: mutualChecks :: MutualInfo -> Declaration -> [Declaration] -> MutualId -> Set QName -> TCM ()
+ Agda.TypeChecking.Rules.Decl: mutualChecks :: MutualInfo -> Declaration -> MutualId -> Set QName -> TCM ()
- Agda.TypeChecking.Rules.Decl: unquoteTop :: [QName] -> Expr -> TCM [QName]
+ Agda.TypeChecking.Rules.Decl: unquoteTop :: [QName] -> Expr -> TCM ()
- Agda.TypeChecking.Rules.Def: [wfAfterTel] :: WithFunctionProblem -> Telescope
+ Agda.TypeChecking.Rules.Def: [wfAfterTel] :: WithFunctionProblemData -> Telescope
- Agda.TypeChecking.Rules.Def: [wfBeforeTel] :: WithFunctionProblem -> Telescope
+ Agda.TypeChecking.Rules.Def: [wfBeforeTel] :: WithFunctionProblemData -> Telescope
- Agda.TypeChecking.Rules.Def: [wfCallSubst] :: WithFunctionProblem -> Substitution
+ Agda.TypeChecking.Rules.Def: [wfCallSubst] :: WithFunctionProblemData -> Substitution
- Agda.TypeChecking.Rules.Def: [wfClauses] :: WithFunctionProblem -> List1 Clause
+ Agda.TypeChecking.Rules.Def: [wfClauses] :: WithFunctionProblemData -> List1 Clause
- Agda.TypeChecking.Rules.Def: [wfExprs] :: WithFunctionProblem -> List1 (Arg (Term, EqualityView))
+ Agda.TypeChecking.Rules.Def: [wfExprs] :: WithFunctionProblemData -> List1 (Arg (Term, EqualityView))
- Agda.TypeChecking.Rules.Def: [wfLetBindings] :: WithFunctionProblem -> Map Name LetBinding
+ Agda.TypeChecking.Rules.Def: [wfLetBindings] :: WithFunctionProblemData -> Map Name LetBinding
- Agda.TypeChecking.Rules.Def: [wfName] :: WithFunctionProblem -> QName
+ Agda.TypeChecking.Rules.Def: [wfName] :: WithFunctionProblemData -> QName
- Agda.TypeChecking.Rules.Def: [wfParentName] :: WithFunctionProblem -> QName
+ Agda.TypeChecking.Rules.Def: [wfParentName] :: WithFunctionProblemData -> QName
- Agda.TypeChecking.Rules.Def: [wfParentParams] :: WithFunctionProblem -> Nat
+ Agda.TypeChecking.Rules.Def: [wfParentParams] :: WithFunctionProblemData -> Nat
- Agda.TypeChecking.Rules.Def: [wfParentPats] :: WithFunctionProblem -> [NamedArg DeBruijnPattern]
+ Agda.TypeChecking.Rules.Def: [wfParentPats] :: WithFunctionProblemData -> [NamedArg DeBruijnPattern]
- Agda.TypeChecking.Rules.Def: [wfParentTel] :: WithFunctionProblem -> Telescope
+ Agda.TypeChecking.Rules.Def: [wfParentTel] :: WithFunctionProblemData -> Telescope
- Agda.TypeChecking.Rules.Def: [wfParentType] :: WithFunctionProblem -> Type
+ Agda.TypeChecking.Rules.Def: [wfParentType] :: WithFunctionProblemData -> Type
- Agda.TypeChecking.Rules.Def: [wfPermFinal] :: WithFunctionProblem -> Permutation
+ Agda.TypeChecking.Rules.Def: [wfPermFinal] :: WithFunctionProblemData -> Permutation
- Agda.TypeChecking.Rules.Def: [wfPermParent] :: WithFunctionProblem -> Permutation
+ Agda.TypeChecking.Rules.Def: [wfPermParent] :: WithFunctionProblemData -> Permutation
- Agda.TypeChecking.Rules.Def: [wfPermSplit] :: WithFunctionProblem -> Permutation
+ Agda.TypeChecking.Rules.Def: [wfPermSplit] :: WithFunctionProblemData -> Permutation
- Agda.TypeChecking.Rules.Def: [wfRHSType] :: WithFunctionProblem -> Type
+ Agda.TypeChecking.Rules.Def: [wfRHSType] :: WithFunctionProblemData -> Type
- Agda.TypeChecking.Rules.Def: atClause :: QName -> Int -> Type -> Maybe Substitution -> SpineClause -> TCM a -> TCM a
+ Agda.TypeChecking.Rules.Def: atClause :: QName -> Int -> Type -> IsWithFunction Substitution -> SpineClause -> TCM a -> TCM a
- Agda.TypeChecking.Rules.Def: checkClause :: Type -> Maybe (Substitution, Map Name LetBinding) -> SpineClause -> TCM (Clause, ClausesPostChecks)
+ Agda.TypeChecking.Rules.Def: checkClause :: Type -> IsWithFunction (QName, Substitution, Map Name LetBinding) -> SpineClause -> TCM (Clause, ClausesPostChecks)
- Agda.TypeChecking.Rules.Def: checkClauseLHS :: Type -> Maybe Substitution -> SpineClause -> (LHSResult -> TCM a) -> TCM a
+ Agda.TypeChecking.Rules.Def: checkClauseLHS :: Type -> IsWithFunction Substitution -> SpineClause -> (LHSResult -> TCM a) -> TCM a
- Agda.TypeChecking.Rules.Def: checkFunDef' :: Type -> ArgInfo -> Maybe ExtLamInfo -> Maybe QName -> DefInfo -> QName -> [Clause] -> TCM ()
+ Agda.TypeChecking.Rules.Def: checkFunDef' :: Type -> ArgInfo -> Maybe ExtLamInfo -> DefInfo -> QName -> [Clause] -> TCM ()
- Agda.TypeChecking.Rules.Def: checkFunDefS :: Type -> ArgInfo -> Maybe ExtLamInfo -> Maybe QName -> DefInfo -> QName -> Maybe (Substitution, Map Name LetBinding) -> [Clause] -> TCM ()
+ Agda.TypeChecking.Rules.Def: checkFunDefS :: Type -> ArgInfo -> Maybe ExtLamInfo -> IsWithFunction (QName, Substitution, Map Name LetBinding) -> DefInfo -> QName -> [Clause] -> TCM ()
- Agda.TypeChecking.Rules.Def: mapLHSCores :: (LHSCore -> LHSCore) -> RHS -> RHS
+ Agda.TypeChecking.Rules.Def: mapLHSCores :: HasLHSCores a => (LHSCore -> LHSCore) -> a -> a
- Agda.TypeChecking.Rules.LHS: checkLeftHandSide :: Call -> Range -> Maybe QName -> [NamedArg Pattern] -> Type -> Maybe Substitution -> [ProblemEq] -> (LHSResult -> TCM a) -> TCM a
+ Agda.TypeChecking.Rules.LHS: checkLeftHandSide :: Call -> Range -> LetOrClause -> [NamedArg Pattern] -> Type -> IsWithFunction Substitution -> [ProblemEq] -> (LHSResult -> TCM a) -> TCM a
- Agda.TypeChecking.Rules.LHS: isFlexiblePattern :: (IsFlexiblePattern a, HasConstInfo m, MonadDebug m) => a -> m Bool
+ Agda.TypeChecking.Rules.LHS: isFlexiblePattern :: (IsFlexiblePattern a, HasConstInfo m) => a -> m Bool
- Agda.TypeChecking.Rules.LHS: maybeFlexiblePattern :: forall (m :: Type -> Type). (IsFlexiblePattern a, HasConstInfo m, MonadDebug m) => a -> MaybeT m FlexibleVarKind
+ Agda.TypeChecking.Rules.LHS: maybeFlexiblePattern :: forall (m :: Type -> Type). (IsFlexiblePattern a, HasConstInfo m) => a -> MaybeT m FlexibleVarKind
- Agda.TypeChecking.Rules.LHS.Problem: Absurd :: Range -> Type -> AbsurdPattern
+ Agda.TypeChecking.Rules.LHS.Problem: Absurd :: Range -> Dom Type -> AbsurdPattern
- Agda.TypeChecking.Rules.LHS.Problem: LHSState :: Telescope -> [NamedArg DeBruijnPattern] -> Problem a -> Arg Type -> ![Maybe Int] -> !Bool -> LHSState a
+ Agda.TypeChecking.Rules.LHS.Problem: LHSState :: Telescope -> [NamedArg DeBruijnPattern] -> Problem a -> Arg Type -> ![Maybe Int] -> !Bool -> !MatchPrio -> LHSState a
- Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: buildEquiv :: (PureTCM tcm, MonadError TCErr tcm) => UnifyLogEntry -> UnifyState -> tcm (Either NoLeftInv (Retract, Term))
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: buildEquiv :: DigestedUnifyLogEntry -> 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: buildLeftInverse :: 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: composeRetract :: Retract -> Term -> Retract -> TCM (Either (Closure (Abs Type)) Retract)
- Agda.TypeChecking.Rules.LHS.Unify.Types: UnifyOutput :: PatternSubstitution -> PatternSubstitution -> UnifyOutput
+ Agda.TypeChecking.Rules.LHS.Unify.Types: UnifyOutput :: PatternSubstitution -> PatternSubstitution -> Maybe Permutation -> UnifyOutput
- Agda.TypeChecking.Rules.LHS.Unify.Types: eqUnLevel :: (HasBuiltins m, HasOptions m) => Equality -> m Equality
+ Agda.TypeChecking.Rules.LHS.Unify.Types: eqUnLevel :: HasBuiltins m => Equality -> m Equality
- Agda.TypeChecking.Rules.LHS.Unify.Types: runUnifyLogT :: Functor m => UnifyLogT m a -> m (a, UnifyLog)
+ Agda.TypeChecking.Rules.LHS.Unify.Types: runUnifyLogT :: Monad m => UnifyLogT m a -> m (a, UnifyLog)
- Agda.TypeChecking.Rules.LHS.Unify.Types: solveVar :: Int -> DeBruijnPattern -> UnifyState -> Maybe (UnifyState, PatternSubstitution)
+ Agda.TypeChecking.Rules.LHS.Unify.Types: solveVar :: Int -> DeBruijnPattern -> UnifyState -> Maybe (UnifyState, PatternSubstitution, Permutation)
- Agda.TypeChecking.Rules.Record: checkRecDef :: DefInfo -> QName -> UniverseCheck -> RecordDirectives -> DataDefParams -> Expr -> [Field] -> TCM ()
+ Agda.TypeChecking.Rules.Record: checkRecDef :: DefInfo -> QName -> PositivityCheck -> UniverseCheck -> ForceRecordEta -> RecordDirectives -> DataDefParams -> Expr -> [Field] -> TCM ()
- Agda.TypeChecking.Rules.Term: LamNotPi :: LamOrPi
+ Agda.TypeChecking.Rules.Term: LamNotPi :: ModTelOrigin -> LamOrPi
- Agda.TypeChecking.Rules.Term: checkDomain :: (LensLock a, LensModality a) => LamOrPi -> List1 a -> Expr -> TCM Type
+ Agda.TypeChecking.Rules.Term: checkDomain :: (LensLock a, LensModality a, LensRewriteAnn a, LensRelevance a) => LamOrPi -> Maybe Name -> List1 a -> Expr -> TCM (Maybe RewDom, Type)
- Agda.TypeChecking.Rules.Term: checkGeneralizeTelescope :: Maybe ModuleName -> GeneralizeTelescope -> ([Maybe Name] -> Telescope -> TCM a) -> TCM a
+ Agda.TypeChecking.Rules.Term: checkGeneralizeTelescope :: ModTelOrigin -> Maybe ModuleName -> GeneralizeTelescope -> ([Maybe Name] -> Telescope -> TCM a) -> TCM a
- Agda.TypeChecking.Rules.Term: checkPiDomain :: (LensLock a, LensModality a) => List1 a -> Expr -> TCM Type
+ Agda.TypeChecking.Rules.Term: checkPiDomain :: (LensLock a, LensModality a, LensRewriteAnn a, LensRelevance a) => Maybe Name -> List1 a -> Expr -> TCM (Maybe RewDom, Type)
- Agda.TypeChecking.Rules.Term: checkTelescope :: Telescope -> (Telescope -> TCM a) -> TCM a
+ Agda.TypeChecking.Rules.Term: checkTelescope :: ModTelOrigin -> Telescope -> (Telescope -> TCM a) -> TCM a
- Agda.TypeChecking.Serialise: decode :: EmbPrj a => ByteString -> TCM (Maybe a)
+ Agda.TypeChecking.Serialise: decode :: EmbPrj a => Encoded -> MaybeT TCM a
- Agda.TypeChecking.Serialise: decodeInterface :: ByteString -> TCM (Maybe Interface)
+ Agda.TypeChecking.Serialise: decodeInterface :: ByteString -> MaybeT TCM Interface
- Agda.TypeChecking.Serialise: encodeFile :: FilePath -> Interface -> TCM ByteString
+ Agda.TypeChecking.Serialise: encodeFile :: FilePath -> Interface -> TCM Interface
- Agda.TypeChecking.Serialise.Base: ($dmicod_) :: (EmbPrj a, Enum a, Bounded a) => a -> S Word32
+ Agda.TypeChecking.Serialise.Base: ($dmicod_) :: (EmbPrj a, Enum a) => a -> S Word32
- Agda.TypeChecking.Serialise.Base: Dict :: !HashTable Node Word32 -> !HashTable String Word32 -> !HashTable Text Word32 -> !HashTable Text Word32 -> !HashTable Integer Word32 -> !HashTable Double Word32 -> !HashTable NameId Word32 -> !HashTable QNameId Word32 -> !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: Dict :: !HashTableLU Node Word32 -> !HashTableLU String Word32 -> !HashTableLU Text Word32 -> !HashTableLU Text Word32 -> !HashTableLU Integer Word32 -> !HashTableLU VarSet Word32 -> !HashTableLU Word64 Word32 -> !HashTableLU NameIdR Word32 -> !HashTableLU QNameId Word32 -> !FreshAndReuse -> !FreshAndReuse -> !FreshAndReuse -> !FreshAndReuse -> !FreshAndReuse -> !FreshAndReuse -> !FreshAndReuse -> !FreshAndReuse -> !FreshAndReuse -> !FreshAndReuse -> !HashTableLU String Int -> !Bool -> Dict
- Agda.TypeChecking.Serialise.Base: [doubleC] :: Dict -> !IORef FreshAndReuse
+ Agda.TypeChecking.Serialise.Base: [doubleC] :: Dict -> !FreshAndReuse
- Agda.TypeChecking.Serialise.Base: [doubleD] :: Dict -> !HashTable Double Word32
+ Agda.TypeChecking.Serialise.Base: [doubleD] :: Dict -> !HashTableLU Word64 Word32
- Agda.TypeChecking.Serialise.Base: [includes] :: St -> !List1 AbsolutePath
+ Agda.TypeChecking.Serialise.Base: [includes] :: Decode -> !List1 AbsolutePath
- Agda.TypeChecking.Serialise.Base: [integerC] :: Dict -> !IORef FreshAndReuse
+ Agda.TypeChecking.Serialise.Base: [integerC] :: Dict -> !FreshAndReuse
- Agda.TypeChecking.Serialise.Base: [integerD] :: Dict -> !HashTable Integer Word32
+ Agda.TypeChecking.Serialise.Base: [integerD] :: Dict -> !HashTableLU Integer Word32
- Agda.TypeChecking.Serialise.Base: [lTextC] :: Dict -> !IORef FreshAndReuse
+ Agda.TypeChecking.Serialise.Base: [lTextC] :: Dict -> !FreshAndReuse
- Agda.TypeChecking.Serialise.Base: [lTextD] :: Dict -> !HashTable Text Word32
+ Agda.TypeChecking.Serialise.Base: [lTextD] :: Dict -> !HashTableLU Text Word32
- Agda.TypeChecking.Serialise.Base: [modFile] :: St -> !ModuleToSource
+ Agda.TypeChecking.Serialise.Base: [modFile] :: Decode -> !IORef ModuleToSource
- Agda.TypeChecking.Serialise.Base: [nameC] :: Dict -> !IORef FreshAndReuse
+ Agda.TypeChecking.Serialise.Base: [nameC] :: Dict -> !FreshAndReuse
- Agda.TypeChecking.Serialise.Base: [nameD] :: Dict -> !HashTable NameId Word32
+ Agda.TypeChecking.Serialise.Base: [nameD] :: Dict -> !HashTableLU NameIdR Word32
- Agda.TypeChecking.Serialise.Base: [nodeC] :: Dict -> !IORef FreshAndReuse
+ Agda.TypeChecking.Serialise.Base: [nodeC] :: Dict -> !FreshAndReuse
- Agda.TypeChecking.Serialise.Base: [nodeD] :: Dict -> !HashTable Node Word32
+ Agda.TypeChecking.Serialise.Base: [nodeD] :: Dict -> !HashTableLU Node Word32
- Agda.TypeChecking.Serialise.Base: [nodeMemo] :: St -> !Memo
+ Agda.TypeChecking.Serialise.Base: [nodeMemo] :: Decode -> !IOArray MemoEntry
- Agda.TypeChecking.Serialise.Base: [qnameC] :: Dict -> !IORef FreshAndReuse
+ Agda.TypeChecking.Serialise.Base: [qnameC] :: Dict -> !FreshAndReuse
- Agda.TypeChecking.Serialise.Base: [qnameD] :: Dict -> !HashTable QNameId Word32
+ Agda.TypeChecking.Serialise.Base: [qnameD] :: Dict -> !HashTableLU QNameId Word32
- Agda.TypeChecking.Serialise.Base: [sTextC] :: Dict -> !IORef FreshAndReuse
+ Agda.TypeChecking.Serialise.Base: [sTextC] :: Dict -> !FreshAndReuse
- Agda.TypeChecking.Serialise.Base: [sTextD] :: Dict -> !HashTable Text Word32
+ Agda.TypeChecking.Serialise.Base: [sTextD] :: Dict -> !HashTableLU Text Word32
- Agda.TypeChecking.Serialise.Base: [stats] :: Dict -> !HashTable String Int
+ Agda.TypeChecking.Serialise.Base: [stats] :: Dict -> !HashTableLU String Int
- Agda.TypeChecking.Serialise.Base: [stringC] :: Dict -> !IORef FreshAndReuse
+ Agda.TypeChecking.Serialise.Base: [stringC] :: Dict -> !FreshAndReuse
- Agda.TypeChecking.Serialise.Base: [stringD] :: Dict -> !HashTable String Word32
+ Agda.TypeChecking.Serialise.Base: [stringD] :: Dict -> !HashTableLU String Word32
- Agda.TypeChecking.Serialise.Base: [termC] :: Dict -> !IORef FreshAndReuse
+ Agda.TypeChecking.Serialise.Base: [termC] :: Dict -> !FreshAndReuse
- Agda.TypeChecking.Serialise.Base: class ICODE t (b :: Bool)
+ Agda.TypeChecking.Serialise.Base: class ICODE t (a :: Nat)
- Agda.TypeChecking.Serialise.Base: class VALU t (b :: Bool)
+ Agda.TypeChecking.Serialise.Base: class VALU t (a :: Nat)
- Agda.TypeChecking.Serialise.Base: farEmpty :: FreshAndReuse
+ Agda.TypeChecking.Serialise.Base: farEmpty :: IO FreshAndReuse
- Agda.TypeChecking.Serialise.Base: icodeArgs :: ICODE t b => Proxy t -> StrictProducts (Domains t) -> S Node
+ Agda.TypeChecking.Serialise.Base: icodeArgs :: ICODE t a => Proxy t -> StrictProducts (Domains t) -> S Node
- Agda.TypeChecking.Serialise.Base: icodeMemo :: (Ord a, Hashable a) => (Dict -> HashTable a Word32) -> (Dict -> IORef FreshAndReuse) -> a -> S Word32 -> S Word32
+ Agda.TypeChecking.Serialise.Base: icodeMemo :: Hashable a => (Dict -> HashTableLU a Word32) -> (Dict -> FreshAndReuse) -> a -> S Word32 -> S Word32
- Agda.TypeChecking.Serialise.Base: icodeN :: (ICODE t (IsBase t), StrictCurrying (Domains t) (S Word32), All EmbPrj (Domains t)) => Word32 -> t -> Arrows (Domains t) (S Word32)
+ Agda.TypeChecking.Serialise.Base: icodeN :: (ICODE (Word32 -> t) (Arity (Word32 -> t)), StrictCurrying (Domains (Word32 -> t)) (S Word32), All EmbPrj (Domains (Word32 -> t))) => Word32 -> t -> Arrows (Domains t) (S Word32)
- Agda.TypeChecking.Serialise.Base: icodeN' :: (ICODE t (IsBase t), StrictCurrying (Domains t) (S Word32), All EmbPrj (Domains t)) => t -> Arrows (Domains t) (S Word32)
+ Agda.TypeChecking.Serialise.Base: icodeN' :: (ICODE t (Arity t), StrictCurrying (Domains t) (S Word32), All EmbPrj (Domains t)) => t -> Arrows (Domains t) (S Word32)
- Agda.TypeChecking.Serialise.Base: lookupME :: Proxy a -> Fingerprint -> MemoEntry -> (a -> b) -> b -> b
+ Agda.TypeChecking.Serialise.Base: lookupME :: Proxy a -> Fingerprint -> MemoEntry -> (# a | (# #) #)
- Agda.TypeChecking.Serialise.Base: type QNameId = [NameId]
+ Agda.TypeChecking.Serialise.Base: type QNameId = NameIdR
- Agda.TypeChecking.Serialise.Base: type R = StateT St IO
+ Agda.TypeChecking.Serialise.Base: type R = ReaderT Decode IO
- Agda.TypeChecking.Serialise.Base: valuN :: (VALU t (IsBase t), StrictCurrying (Constant Word32 (Domains t)) (R (CoDomain t)), All EmbPrj (Domains t)) => t -> Arrows (Constant Word32 (Domains t)) (R (CoDomain t))
+ Agda.TypeChecking.Serialise.Base: valuN :: (VALU t (Arity t), StrictCurrying (Constant Word32 (Domains t)) (R (CoDomain t)), All EmbPrj (Domains t)) => t -> Arrows (Constant Word32 (Domains t)) (R (CoDomain t))
- Agda.TypeChecking.Serialise.Base: valuN' :: VALU t b => t -> StrictProducts (Constant Word32 (Domains t)) -> R (CoDomain t)
+ Agda.TypeChecking.Serialise.Base: valuN' :: VALU t a => t -> StrictProducts (Constant Word32 (Domains t)) -> R (CoDomain t)
- Agda.TypeChecking.Serialise.Base: valueArgs :: VALU t b => Proxy t -> [Word32] -> Maybe (StrictProducts (Constant Word32 (Domains t)))
+ Agda.TypeChecking.Serialise.Base: valueArgs :: VALU t a => Proxy t -> Node -> Maybe (StrictProducts (Constant Word32 (Domains t)))
- Agda.TypeChecking.Serialise.Base: valueN :: (VALU t (IsBase t), All EmbPrj (CoDomain t ': Domains t)) => t -> Word32 -> R (CoDomain t)
+ Agda.TypeChecking.Serialise.Base: valueN :: (VALU t (Arity t), All EmbPrj (CoDomain t ': Domains t)) => t -> Word32 -> R (CoDomain t)
- Agda.TypeChecking.Serialise.Base: vcase :: EmbPrj a => ([Word32] -> R a) -> Word32 -> R a
+ Agda.TypeChecking.Serialise.Base: vcase :: EmbPrj a => (Node -> R a) -> Word32 -> R a
- Agda.TypeChecking.SizedTypes: boundedSizeMetaHook :: (MonadConstraint m, MonadTCEnv m, ReadTCState m, MonadAddContext m, HasOptions m, HasBuiltins m) => Term -> Telescope -> Type -> m ()
+ Agda.TypeChecking.SizedTypes: boundedSizeMetaHook :: (MonadConstraint m, MonadAddContext m, HasBuiltins m) => Term -> Telescope -> Type -> m ()
- Agda.TypeChecking.SizedTypes: compareBelowMax :: MonadConversion m => DeepSizeView -> SizeMaxView -> m ()
+ Agda.TypeChecking.SizedTypes: compareBelowMax :: DeepSizeView -> SizeMaxView -> TCM ()
- Agda.TypeChecking.SizedTypes: compareMaxViews :: MonadConversion m => Comparison -> SizeMaxView -> SizeMaxView -> m ()
+ Agda.TypeChecking.SizedTypes: compareMaxViews :: Comparison -> SizeMaxView -> SizeMaxView -> TCM ()
- Agda.TypeChecking.SizedTypes: compareSizeViews :: MonadConversion m => Comparison -> DeepSizeView -> DeepSizeView -> m ()
+ Agda.TypeChecking.SizedTypes: compareSizeViews :: Comparison -> DeepSizeView -> DeepSizeView -> TCM ()
- Agda.TypeChecking.SizedTypes: compareSizes :: MonadConversion m => Comparison -> Term -> Term -> m ()
+ Agda.TypeChecking.SizedTypes: compareSizes :: Comparison -> Term -> Term -> TCM ()
- Agda.TypeChecking.SizedTypes: giveUp :: MonadConversion m => Comparison -> Type -> Term -> Term -> m ()
+ Agda.TypeChecking.SizedTypes: giveUp :: Comparison -> Type -> Term -> Term -> TCM ()
- Agda.TypeChecking.SizedTypes: isBoundedProjVar :: (MonadCheckInternal m, PureTCM m) => ProjectedVar -> m BoundedSize
+ Agda.TypeChecking.SizedTypes: isBoundedProjVar :: ProjectedVar -> TCM BoundedSize
- Agda.TypeChecking.SizedTypes: oldSizeExpr :: (PureTCM m, MonadBlock m) => Term -> m (OldSizeExpr, Int)
+ Agda.TypeChecking.SizedTypes: oldSizeExpr :: Term -> TCM (OldSizeExpr, Int)
- Agda.TypeChecking.SizedTypes: trivial :: MonadConversion m => Term -> Term -> m Bool
+ Agda.TypeChecking.SizedTypes: trivial :: Term -> Term -> TCM Bool
- Agda.TypeChecking.SizedTypes: trySizeUniv :: MonadConversion m => Comparison -> CompareAs -> Term -> Term -> QName -> Elims -> QName -> Elims -> m ()
+ Agda.TypeChecking.SizedTypes: trySizeUniv :: Comparison -> CompareAs -> Term -> Term -> QName -> Elims -> QName -> Elims -> TCM ()
- Agda.TypeChecking.SizedTypes.Syntax: simplify1 :: (Pretty f, Pretty r, Eq r) => CTrans r f -> CTrans r f
+ Agda.TypeChecking.SizedTypes.Syntax: simplify1 :: Eq r => CTrans r f -> CTrans 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 Error ()
+ Agda.TypeChecking.SizedTypes.WarshallSolver: verifySolution :: (Ord r, Ord f, Pretty r, Pretty f) => HypGraph r f -> [Constraint' r f] -> Solution r f -> Either Error ()
- Agda.TypeChecking.Sort: checkTelePiSort :: Type -> TCM ()
+ Agda.TypeChecking.Sort: checkTelePiSort :: Telescope -> Sort -> TCM ()
- Agda.TypeChecking.Sort: inferFunSort :: (PureTCM m, MonadConstraint m) => Dom Type -> Sort -> m Sort
+ Agda.TypeChecking.Sort: inferFunSort :: MonadConstraint m => Dom Type -> Type -> m Sort
- Agda.TypeChecking.Sort: inferPiSort :: (PureTCM m, MonadConstraint m) => Dom Type -> Abs Sort -> m Sort
+ Agda.TypeChecking.Sort: inferPiSort :: MonadConstraint m => Dom Type -> Abs Type -> m Sort
- Agda.TypeChecking.Sort: inferUnivSort :: (PureTCM m, MonadConstraint m) => Sort -> m Sort
+ Agda.TypeChecking.Sort: inferUnivSort :: PureTCM m => Sort -> m Sort
- Agda.TypeChecking.Sort: sortFitsIn :: MonadConversion m => Sort -> Sort -> m ()
+ Agda.TypeChecking.Sort: sortFitsIn :: Sort -> Sort -> TCM ()
- Agda.TypeChecking.Sort: sortOf :: (PureTCM m, MonadBlock m, MonadConstraint m) => Term -> m Sort
+ Agda.TypeChecking.Sort: sortOf :: (PureTCM m, MonadConstraint m) => Term -> m Sort
- Agda.TypeChecking.Sort: sortOfType :: (PureTCM m, MonadBlock m, MonadConstraint m) => Type -> m Sort
+ Agda.TypeChecking.Sort: sortOfType :: (PureTCM m, MonadConstraint m) => Type -> m Sort
- Agda.TypeChecking.Substitute: (:#) :: a -> Substitution' a -> Substitution' a
+ Agda.TypeChecking.Substitute: (:#) :: a -> !Substitution' a -> Substitution' a
- Agda.TypeChecking.Substitute: Lift :: !Int -> Substitution' a -> Substitution' a
+ Agda.TypeChecking.Substitute: Lift :: !Int -> !Substitution' a -> Substitution' a
- Agda.TypeChecking.Substitute: Strengthen :: Impossible -> !Int -> Substitution' a -> Substitution' a
+ Agda.TypeChecking.Substitute: Strengthen :: Impossible -> !Int -> !Substitution' a -> Substitution' a
- Agda.TypeChecking.Substitute: Wk :: !Int -> Substitution' a -> Substitution' a
+ Agda.TypeChecking.Substitute: Wk :: !Int -> !Substitution' a -> Substitution' a
- Agda.TypeChecking.Substitute: funSort :: Sort -> Sort -> Sort
+ Agda.TypeChecking.Substitute: funSort :: Bool -> Sort -> Sort -> Sort
- Agda.TypeChecking.Substitute: funSort' :: Sort -> Sort -> Either Blocker Sort
+ Agda.TypeChecking.Substitute: funSort' :: Bool -> Sort -> Sort -> Either Blocker Sort
- 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: checkSyntacticEquality' :: (SynEq a, MonadReduce m) => a -> a -> (a -> a -> m b) -> (a -> a -> m b) -> m b
- Agda.TypeChecking.Telescope: varDependencies :: Telescope -> IntSet -> IntSet
+ Agda.TypeChecking.Telescope: varDependencies :: Telescope -> VarSet -> VarSet
- Agda.TypeChecking.Telescope: varDependents :: Telescope -> IntSet -> IntSet
+ Agda.TypeChecking.Telescope: varDependents :: Telescope -> VarSet -> VarSet
- Agda.TypeChecking.Telescope.Path: isInterval :: (MonadTCM m, MonadReduce m) => Type -> m Bool
+ Agda.TypeChecking.Telescope.Path: isInterval :: MonadTCM m => Type -> m Bool
- Agda.TypeChecking.Unquote: runUnquoteM :: UnquoteM a -> TCM (Either UnquoteError (a, [QName]))
+ Agda.TypeChecking.Unquote: runUnquoteM :: [QName] -> UnquoteM a -> TCM (Either UnquoteError a)
- Agda.TypeChecking.Warnings: raiseWarningsOnUsage :: (MonadWarning m, ReadTCState m) => QName -> m ()
+ Agda.TypeChecking.Warnings: raiseWarningsOnUsage :: MonadWarning m => QName -> m ()
- Agda.Utils.BiMap: adjustPrecondition :: (Ord k, Eq v, Eq (Tag v), HasTag v) => (v -> v) -> k -> BiMap k v -> Bool
+ Agda.Utils.BiMap: adjustPrecondition :: (Ord k, Eq (Tag v), HasTag v) => (v -> v) -> k -> BiMap k v -> Bool
- Agda.Utils.BiMap: alterPrecondition :: (Ord k, Eq v, Eq (Tag v), HasTag v) => (Maybe v -> Maybe v) -> k -> BiMap k v -> Bool
+ Agda.Utils.BiMap: alterPrecondition :: (Ord k, Eq (Tag v), HasTag v) => (Maybe v -> Maybe v) -> k -> BiMap k v -> Bool
- Agda.Utils.BiMap: insertLookupWithKeyPrecondition :: (Ord k, Eq v, Eq (Tag v), HasTag v) => (k -> v -> v -> v) -> k -> v -> BiMap k v -> Bool
+ Agda.Utils.BiMap: insertLookupWithKeyPrecondition :: (Ord k, Eq (Tag v), HasTag v) => (k -> v -> v -> v) -> k -> v -> BiMap k v -> Bool
- Agda.Utils.BiMap: insertPrecondition :: (Eq k, Eq v, Eq (Tag v), HasTag v) => k -> v -> BiMap k v -> Bool
+ Agda.Utils.BiMap: insertPrecondition :: (Eq k, Eq (Tag v), HasTag v) => k -> v -> BiMap k v -> Bool
- Agda.Utils.BiMap: mapWithKeyFixedTagsPrecondition :: (Eq v, Eq (Tag v), HasTag v) => (k -> v -> v) -> BiMap k v -> Bool
+ Agda.Utils.BiMap: mapWithKeyFixedTagsPrecondition :: (Eq (Tag v), HasTag v) => (k -> v -> v) -> BiMap k v -> Bool
- Agda.Utils.BiMap: updatePrecondition :: (Ord k, Eq v, Eq (Tag v), HasTag v) => (v -> Maybe v) -> k -> BiMap k v -> Bool
+ Agda.Utils.BiMap: updatePrecondition :: (Ord k, Eq (Tag v), HasTag v) => (v -> Maybe v) -> k -> BiMap k v -> Bool
- Agda.Utils.GetOpt: usageInfo :: String -> [OptDescr a] -> String
+ Agda.Utils.GetOpt: usageInfo :: Int -> String -> [OptDescr a] -> String
- Agda.Utils.Graph.AdjacencyMap.Unidirectional: composeWith :: Ord n => (c -> d -> e) -> (e -> e -> e) -> Graph n c -> Graph n d -> Graph n e
+ Agda.Utils.Graph.AdjacencyMap.Unidirectional: composeWith :: forall c d e n. Ord n => (c -> d -> e) -> (e -> e -> e) -> Graph n c -> Graph n d -> Graph n e
- Agda.Utils.Graph.AdjacencyMap.Unidirectional: filterNodes :: Ord n => (n -> Bool) -> Graph n e -> Graph n e
+ Agda.Utils.Graph.AdjacencyMap.Unidirectional: filterNodes :: (n -> Bool) -> Graph n e -> Graph n e
- Agda.Utils.Graph.AdjacencyMap.Unidirectional: fromNodeSet :: Ord n => Set n -> Graph n e
+ Agda.Utils.Graph.AdjacencyMap.Unidirectional: fromNodeSet :: Set n -> Graph n e
- Agda.Utils.Graph.AdjacencyMap.Unidirectional: renameNodesMonotonic :: (Ord n1, Ord n2) => (n1 -> n2) -> Graph n1 e -> Graph n2 e
+ Agda.Utils.Graph.AdjacencyMap.Unidirectional: renameNodesMonotonic :: (n1 -> n2) -> Graph n1 e -> Graph n2 e
- Agda.Utils.HashTable: empty :: IO (HashTable k v)
+ Agda.Utils.HashTable: empty :: forall (ks :: Type -> Type -> Type) k (vs :: Type -> Type -> Type) v. (MVector ks k, MVector vs v) => IO (HashTable ks k vs v)
- Agda.Utils.HashTable: insert :: (Eq k, Hashable k) => HashTable k v -> k -> v -> IO ()
+ Agda.Utils.HashTable: insert :: forall k (vs :: Type -> Type -> Type) v (ks :: Type -> Type -> Type). (Hashable k, MVector vs v, MVector ks k) => HashTable ks k vs v -> k -> v -> IO ()
- Agda.Utils.HashTable: lookup :: (Eq k, Hashable k) => HashTable k v -> k -> IO (Maybe v)
+ Agda.Utils.HashTable: lookup :: forall k (ks :: Type -> Type -> Type) (vs :: Type -> Type -> Type) v. (Hashable k, MVector ks k, MVector vs v) => HashTable ks k vs v -> k -> IO (Maybe v)
- Agda.Utils.HashTable: toList :: (Eq k, Hashable k) => HashTable k v -> IO [(k, v)]
+ Agda.Utils.HashTable: toList :: forall k (ks :: Type -> Type -> Type) (vs :: Type -> Type -> Type) v. (Hashable k, MVector ks k, MVector vs v) => HashTable ks k vs v -> IO [(k, v)]
- Agda.Utils.Lens: (%=) :: MonadState o m => Lens' o i -> (i -> i) -> m ()
+ Agda.Utils.Lens: (%=) :: MonadState s m => ASetter s s a b -> (a -> b) -> m ()
- Agda.Utils.Lens: (%==) :: MonadState o m => Lens' o i -> (i -> m i) -> m ()
+ Agda.Utils.Lens: (%==) :: MonadState s m => Lens' s a -> (a -> m a) -> m ()
- Agda.Utils.Lens: (.=) :: MonadState o m => Lens' o i -> i -> m ()
+ Agda.Utils.Lens: (.=) :: MonadState s m => ASetter s s a b -> b -> m ()
- Agda.Utils.Lens: (^.) :: o -> Lens' o i -> i
+ Agda.Utils.Lens: (^.) :: s -> Getting a s a -> a
- Agda.Utils.Lens: infix 4 %%=
+ Agda.Utils.Lens: infix 4 %%=!
- Agda.Utils.Lens: infixl 1 <&>
+ Agda.Utils.Lens: infixl 1 &
- Agda.Utils.Lens: lens :: LensGet o i -> LensSet o i -> Lens' o i
+ Agda.Utils.Lens: lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
- Agda.Utils.Lens: locally :: MonadReader o m => Lens' o i -> (i -> i) -> m a -> m a
+ Agda.Utils.Lens: locally :: MonadReader r m => ASetter r r a b -> (a -> b) -> m c -> m c
- Agda.Utils.Lens: over :: Lens' o i -> LensMap o i
+ Agda.Utils.Lens: over :: ASetter s t a b -> (a -> b) -> s -> t
- Agda.Utils.Lens: set :: Lens' o i -> LensSet o i
+ Agda.Utils.Lens: set :: ASetter s t a b -> b -> s -> t
- Agda.Utils.Lens: use :: MonadState o m => Lens' o i -> m i
+ Agda.Utils.Lens: use :: MonadState s m => Getting a s a -> m a
- Agda.Utils.Lens: view :: MonadReader o m => Lens' o i -> m i
+ Agda.Utils.Lens: view :: MonadReader s m => Getting a s a -> m a
- Agda.Utils.List: nubFavouriteOn :: forall a b c. (Ord b, Eq c, Hashable c) => (a -> b) -> (a -> c) -> [a] -> [a]
+ Agda.Utils.List: nubFavouriteOn :: forall a b c. (Ord b, Hashable c) => (a -> b) -> (a -> c) -> [a] -> [a]
- Agda.Utils.List: zipWith' :: (a -> b -> c) -> [a] -> [b] -> Maybe [c]
+ Agda.Utils.List: zipWith' :: (a -> b -> c) -> [a] -> [b] -> [c]
- Agda.Utils.Memo: memoUnsafeH :: (Eq a, Hashable a) => (a -> b) -> a -> b
+ Agda.Utils.Memo: memoUnsafeH :: Hashable a => (a -> b) -> a -> b
- Agda.Utils.Monad: embedWriter :: forall w (m :: Type -> Type) a. (Monoid w, Monad m) => Writer w a -> WriterT w m a
+ Agda.Utils.Monad: embedWriter :: forall (m :: Type -> Type) w a. Monad m => Writer w a -> WriterT w m a
- Agda.Utils.Monad: guardM :: (Monad m, MonadPlus m) => m Bool -> m ()
+ Agda.Utils.Monad: guardM :: MonadPlus m => m Bool -> m ()
- Agda.Utils.Monad: orEitherM :: (Monoid e, Monad m, Functor m) => [m (Either e b)] -> m (Either e b)
+ Agda.Utils.Monad: orEitherM :: (Monoid e, Monad m) => [m (Either e b)] -> m (Either e b)
- Agda.Utils.Monad: partitionM :: (Functor m, Applicative m) => (a -> m Bool) -> [a] -> m ([a], [a])
+ Agda.Utils.Monad: partitionM :: Applicative m => (a -> m Bool) -> [a] -> m ([a], [a])
- Agda.Utils.Monad: tell1 :: (Monoid ws, Singleton w ws, MonadWriter ws m) => w -> m ()
+ Agda.Utils.Monad: tell1 :: (Singleton w ws, MonadWriter ws m) => w -> m ()
- Agda.Utils.Monad: tryCatch :: (MonadError e m, Functor m) => m () -> m (Maybe e)
+ Agda.Utils.Monad: tryCatch :: MonadError e m => m () -> m (Maybe e)
- Agda.Utils.Monad: tryMaybe :: (MonadError e m, Functor m) => m a -> m (Maybe a)
+ Agda.Utils.Monad: tryMaybe :: MonadError e m => m a -> m (Maybe a)
- Agda.Utils.Permutation: Drop :: Int -> a -> Drop a
+ Agda.Utils.Permutation: Drop :: !Int -> a -> Drop a
- Agda.Utils.Permutation: Perm :: Int -> [Int] -> Permutation
+ Agda.Utils.Permutation: Perm :: !Int -> ![Int] -> Permutation
- Agda.Utils.Permutation: [dropN] :: Drop a -> Int
+ Agda.Utils.Permutation: [dropN] :: Drop a -> !Int
- Agda.Utils.Permutation: [permPicks] :: Permutation -> [Int]
+ Agda.Utils.Permutation: [permPicks] :: Permutation -> ![Int]
- Agda.Utils.Permutation: [permRange] :: Permutation -> Int
+ Agda.Utils.Permutation: [permRange] :: Permutation -> !Int
- Agda.Utils.SmallSet: (\\) :: SmallSetElement a => SmallSet a -> SmallSet a -> SmallSet a
+ Agda.Utils.SmallSet: (\\) :: SmallSet a -> SmallSet a -> SmallSet a
- Agda.Utils.SmallSet: complement :: SmallSetElement a => SmallSet a -> SmallSet a
+ Agda.Utils.SmallSet: complement :: SmallSet a -> SmallSet a
- Agda.Utils.SmallSet: difference :: SmallSetElement a => SmallSet a -> SmallSet a -> SmallSet a
+ Agda.Utils.SmallSet: difference :: SmallSet a -> SmallSet a -> SmallSet a
- Agda.Utils.SmallSet: empty :: SmallSetElement a => SmallSet a
+ Agda.Utils.SmallSet: empty :: SmallSet a
- Agda.Utils.SmallSet: intersection :: SmallSetElement a => SmallSet a -> SmallSet a -> SmallSet a
+ Agda.Utils.SmallSet: intersection :: SmallSet a -> SmallSet a -> SmallSet a
- Agda.Utils.SmallSet: null :: SmallSetElement a => SmallSet a -> Bool
+ Agda.Utils.SmallSet: null :: SmallSet a -> Bool
- Agda.Utils.SmallSet: total :: SmallSetElement a => SmallSet a
+ Agda.Utils.SmallSet: total :: SmallSet a
- Agda.Utils.SmallSet: union :: SmallSetElement a => SmallSet a -> SmallSet a -> SmallSet a
+ Agda.Utils.SmallSet: union :: SmallSet a -> SmallSet a -> SmallSet a
- Agda.Utils.Update: ifDirty :: (Monad m, MonadChange m) => m a -> (a -> m b) -> (a -> m b) -> m b
+ Agda.Utils.Update: ifDirty :: MonadChange m => m a -> (a -> m b) -> (a -> m b) -> m b
- Agda.Utils.VarSet: delete :: Key -> IntSet -> IntSet
+ Agda.Utils.VarSet: delete :: Int -> VarSet -> VarSet
- Agda.Utils.VarSet: difference :: IntSet -> IntSet -> IntSet
+ Agda.Utils.VarSet: difference :: VarSet -> VarSet -> VarSet
- Agda.Utils.VarSet: disjoint :: IntSet -> IntSet -> Bool
+ Agda.Utils.VarSet: disjoint :: VarSet -> VarSet -> Bool
- Agda.Utils.VarSet: empty :: IntSet
+ Agda.Utils.VarSet: empty :: VarSet
- Agda.Utils.VarSet: fromList :: [Key] -> IntSet
+ Agda.Utils.VarSet: fromList :: [Int] -> VarSet
- Agda.Utils.VarSet: insert :: Key -> IntSet -> IntSet
+ Agda.Utils.VarSet: insert :: Int -> VarSet -> VarSet
- Agda.Utils.VarSet: intersection :: IntSet -> IntSet -> IntSet
+ Agda.Utils.VarSet: intersection :: VarSet -> VarSet -> VarSet
- Agda.Utils.VarSet: isSubsetOf :: IntSet -> IntSet -> Bool
+ Agda.Utils.VarSet: isSubsetOf :: VarSet -> VarSet -> Bool
- Agda.Utils.VarSet: member :: Key -> IntSet -> Bool
+ Agda.Utils.VarSet: member :: Int -> VarSet -> Bool
- Agda.Utils.VarSet: null :: IntSet -> Bool
+ Agda.Utils.VarSet: null :: VarSet -> Bool
- Agda.Utils.VarSet: singleton :: Key -> IntSet
+ Agda.Utils.VarSet: singleton :: Int -> VarSet
- Agda.Utils.VarSet: toAscList :: IntSet -> [Key]
+ Agda.Utils.VarSet: toAscList :: VarSet -> [Int]
- Agda.Utils.VarSet: toDescList :: IntSet -> [Key]
+ Agda.Utils.VarSet: toDescList :: VarSet -> [Int]
- Agda.Utils.VarSet: union :: IntSet -> IntSet -> IntSet
+ Agda.Utils.VarSet: union :: VarSet -> VarSet -> VarSet
- Agda.Utils.VarSet: unions :: Foldable f => f IntSet -> IntSet
+ Agda.Utils.VarSet: unions :: Foldable f => f VarSet -> VarSet
- Agda.Utils.WithDefault: setDefault :: forall a (b :: Bool). Boolean a => a -> WithDefault' a b -> WithDefault' a b
+ Agda.Utils.WithDefault: setDefault :: forall a (b :: Bool). a -> WithDefault' a b -> WithDefault' a b
This diff is very large; some files are shown as “too large to diff”. Download the raw patch for the complete diff.
Files
- Agda.cabal +197/−150
- CHANGELOG.md +1378/−11
- README.md +1/−1
- doc/release-notes/2.8.0.2.md +11/−0
- src/data/JS/agda-rts.amd.js +4/−1
- src/data/JS/agda-rts.js +4/−1
- src/data/JS/agda-rts.mjs +4/−1
- src/data/MAlonzo/src/MAlonzo/RTE/Float.hs +1/−1
- src/data/emacs-mode/agda-input.el +81/−0
- src/data/emacs-mode/agda2-abbrevs.el +15/−15
- src/data/emacs-mode/agda2-highlight.el +48/−29
- src/data/emacs-mode/agda2-mode-pkg.el +1/−1
- src/data/emacs-mode/agda2-mode.el +649/−220
- src/data/emacs-mode/agda2.el +35/−0
- src/data/emacs-mode/annotation.el +54/−32
- src/data/latex/agda.sty +34/−15
- src/data/lib/prim/Agda/Builtin/Bool.agda +1/−1
- src/data/lib/prim/Agda/Builtin/Char.agda +18/−1
- src/data/lib/prim/Agda/Builtin/Char/Properties.agda +1/−1
- src/data/lib/prim/Agda/Builtin/Cubical/Equiv.agda +10/−4
- src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda +1/−1
- src/data/lib/prim/Agda/Builtin/Cubical/HCompU.agda +10/−4
- src/data/lib/prim/Agda/Builtin/Cubical/Path.agda +1/−1
- src/data/lib/prim/Agda/Builtin/Cubical/Sub.agda +1/−1
- src/data/lib/prim/Agda/Builtin/Equality.agda +1/−1
- src/data/lib/prim/Agda/Builtin/Equality/Erase.agda +1/−1
- src/data/lib/prim/Agda/Builtin/Equality/Rewrite.agda +3/−1
- src/data/lib/prim/Agda/Builtin/Erased/Box-cong.agda +33/−0
- src/data/lib/prim/Agda/Builtin/Erased/Erased.agda +32/−0
- src/data/lib/prim/Agda/Builtin/Erased/Funext.agda +25/−0
- src/data/lib/prim/Agda/Builtin/Erased/Propext.agda +28/−0
- src/data/lib/prim/Agda/Builtin/Erased/Quotient.agda +78/−0
- src/data/lib/prim/Agda/Builtin/Float.agda +1/−1
- src/data/lib/prim/Agda/Builtin/Float/Properties.agda +1/−1
- src/data/lib/prim/Agda/Builtin/FromNat.agda +1/−1
- src/data/lib/prim/Agda/Builtin/FromNeg.agda +1/−1
- src/data/lib/prim/Agda/Builtin/FromString.agda +1/−1
- src/data/lib/prim/Agda/Builtin/IO.agda +1/−1
- src/data/lib/prim/Agda/Builtin/Int.agda +1/−3
- src/data/lib/prim/Agda/Builtin/List.agda +2/−2
- src/data/lib/prim/Agda/Builtin/Maybe.agda +1/−1
- src/data/lib/prim/Agda/Builtin/Nat.agda +41/−2
- src/data/lib/prim/Agda/Builtin/Reflection.agda +1/−1
- src/data/lib/prim/Agda/Builtin/Reflection/External.agda +1/−1
- src/data/lib/prim/Agda/Builtin/Reflection/Properties.agda +1/−1
- src/data/lib/prim/Agda/Builtin/Sigma.agda +1/−1
- src/data/lib/prim/Agda/Builtin/Size.agda +1/−1
- src/data/lib/prim/Agda/Builtin/Strict.agda +1/−1
- src/data/lib/prim/Agda/Builtin/String.agda +1/−1
- src/data/lib/prim/Agda/Builtin/String/Properties.agda +1/−1
- src/data/lib/prim/Agda/Builtin/TrustMe.agda +1/−1
- src/data/lib/prim/Agda/Builtin/Unit.agda +1/−1
- src/data/lib/prim/Agda/Builtin/Word.agda +1/−1
- src/data/lib/prim/Agda/Builtin/Word/Properties.agda +1/−1
- src/data/lib/prim/Agda/Primitive.agda +1/−1
- src/data/lib/prim/Agda/Primitive/Cubical.agda +1/−4
- src/full/Agda/Benchmarking.hs +18/−9
- src/full/Agda/Compiler/Backend.hs +8/−9
- src/full/Agda/Compiler/Backend/Base.hs +19/−13
- src/full/Agda/Compiler/Common.hs +22/−15
- src/full/Agda/Compiler/JS/Compiler.hs +234/−119
- src/full/Agda/Compiler/JS/Pretty.hs +6/−10
- src/full/Agda/Compiler/JS/Substitution.hs +34/−19
- src/full/Agda/Compiler/JS/Syntax.hs +35/−18
- src/full/Agda/Compiler/MAlonzo/Coerce.hs +2/−2
- src/full/Agda/Compiler/MAlonzo/Compiler.hs +145/−88
- src/full/Agda/Compiler/MAlonzo/HaskellTypes.hs +39/−23
- src/full/Agda/Compiler/MAlonzo/Misc.hs +6/−4
- src/full/Agda/Compiler/MAlonzo/Pragmas.hs +15/−4
- src/full/Agda/Compiler/MAlonzo/Primitives.hs +69/−55
- src/full/Agda/Compiler/MAlonzo/Strict.hs +6/−6
- src/full/Agda/Compiler/ToTreeless.hs +117/−78
- src/full/Agda/Compiler/Treeless/AsPatterns.hs +1/−1
- src/full/Agda/Compiler/Treeless/Builtin.hs +27/−10
- src/full/Agda/Compiler/Treeless/Compare.hs +5/−5
- src/full/Agda/Compiler/Treeless/EliminateDefaults.hs +27/−20
- src/full/Agda/Compiler/Treeless/EliminateLiteralPatterns.hs +1/−1
- src/full/Agda/Compiler/Treeless/Erase.hs +33/−19
- src/full/Agda/Compiler/Treeless/GuardsToPrims.hs +1/−1
- src/full/Agda/Compiler/Treeless/Identity.hs +2/−2
- src/full/Agda/Compiler/Treeless/NormalizeNames.hs +1/−1
- src/full/Agda/Compiler/Treeless/Pretty.hs +39/−20
- src/full/Agda/Compiler/Treeless/Simplify.hs +204/−80
- src/full/Agda/Compiler/Treeless/Subst.hs +14/−5
- src/full/Agda/Compiler/Treeless/Uncase.hs +3/−3
- src/full/Agda/Compiler/Treeless/Unused.hs +23/−18
- src/full/Agda/Interaction/Base.hs +40/−3
- src/full/Agda/Interaction/BasicOps.hs +156/−97
- src/full/Agda/Interaction/BuildLibrary.hs +51/−31
- src/full/Agda/Interaction/CommandLine.hs +12/−9
- src/full/Agda/Interaction/Emacs/Lisp.hs +52/−0
- src/full/Agda/Interaction/EmacsCommand.hs +46/−71
- src/full/Agda/Interaction/EmacsTop.hs +282/−179
- src/full/Agda/Interaction/ExitCode.hs +2/−2
- src/full/Agda/Interaction/FindFile.hs +15/−29
- src/full/Agda/Interaction/Highlighting/Dot/Backend.hs +1/−1
- src/full/Agda/Interaction/Highlighting/Emacs.hs +24/−13
- src/full/Agda/Interaction/Highlighting/FromAbstract.hs +19/−23
- src/full/Agda/Interaction/Highlighting/Generate.hs +86/−52
- src/full/Agda/Interaction/Highlighting/HTML/Base.hs +12/−5
- src/full/Agda/Interaction/Highlighting/HTML/Forester.hs +147/−0
- src/full/Agda/Interaction/Highlighting/JSON.hs +9/−6
- src/full/Agda/Interaction/Highlighting/LaTeX.hs +1/−0
- src/full/Agda/Interaction/Highlighting/LaTeX/Backend.hs +12/−6
- src/full/Agda/Interaction/Highlighting/LaTeX/Base.hs +38/−17
- src/full/Agda/Interaction/Highlighting/Precise.hs +4/−14
- src/full/Agda/Interaction/Highlighting/Range.hs +8/−106
- src/full/Agda/Interaction/Highlighting/Vim.hs +7/−7
- src/full/Agda/Interaction/Imports.hs +528/−246
- src/full/Agda/Interaction/Imports.hs-boot +1/−1
- src/full/Agda/Interaction/InteractionTop.hs +174/−99
- src/full/Agda/Interaction/JSON.hs +20/−16
- src/full/Agda/Interaction/JSONTop.hs +108/−100
- src/full/Agda/Interaction/Library.hs +204/−39
- src/full/Agda/Interaction/Library/Base.hs +75/−3
- src/full/Agda/Interaction/Library/Parse.hs +54/−30
- src/full/Agda/Interaction/MakeCase.hs +127/−48
- src/full/Agda/Interaction/Monad.hs +1/−5
- src/full/Agda/Interaction/Options/Arguments.hs +102/−0
- src/full/Agda/Interaction/Options/Base.hs +2221/−1869
- src/full/Agda/Interaction/Options/BashCompletion.hs +158/−0
- src/full/Agda/Interaction/Options/Default.hs +140/−0
- src/full/Agda/Interaction/Options/Errors.hs +29/−20
- src/full/Agda/Interaction/Options/HasOptions.hs +6/−0
- src/full/Agda/Interaction/Options/Lenses.hs +1/−19
- src/full/Agda/Interaction/Options/ProfileOptions.hs +115/−0
- src/full/Agda/Interaction/Options/Types.hs +30/−6
- src/full/Agda/Interaction/Options/Warnings.hs +87/−12
- src/full/Agda/Interaction/Response/Base.hs +7/−2
- src/full/Agda/Interaction/SearchAbout.hs +13/−13
- src/full/Agda/Main.hs +86/−31
- src/full/Agda/Mimer/Mimer.hs +661/−1748
- src/full/Agda/Mimer/Monad.hs +789/−0
- src/full/Agda/Mimer/Options.hs +0/−1
- src/full/Agda/Mimer/Types.hs +412/−0
- src/full/Agda/Syntax/Abstract.hs +166/−122
- src/full/Agda/Syntax/Abstract/Name.hs +431/−105
- src/full/Agda/Syntax/Abstract/Pattern.hs +3/−3
- src/full/Agda/Syntax/Abstract/PatternSynonyms.hs +31/−24
- src/full/Agda/Syntax/Abstract/Pretty.hs +1/−1
- src/full/Agda/Syntax/Abstract/UsedNames.hs +33/−28
- src/full/Agda/Syntax/Abstract/Views.hs +92/−63
- src/full/Agda/Syntax/Builtin.hs +13/−1
- src/full/Agda/Syntax/Common.hs +427/−64
- src/full/Agda/Syntax/Common/Aspect.hs +61/−37
- src/full/Agda/Syntax/Common/Pretty.hs +120/−23
- src/full/Agda/Syntax/Common/Pretty/ANSI.hs +85/−33
- src/full/Agda/Syntax/Concrete.hs +233/−161
- src/full/Agda/Syntax/Concrete/Attribute.hs +45/−7
- src/full/Agda/Syntax/Concrete/Definitions.hs +496/−303
- src/full/Agda/Syntax/Concrete/Definitions/Errors.hs +181/−94
- src/full/Agda/Syntax/Concrete/Definitions/Monad.hs +43/−42
- src/full/Agda/Syntax/Concrete/Definitions/Types.hs +75/−57
- src/full/Agda/Syntax/Concrete/Fixity.hs +56/−14
- src/full/Agda/Syntax/Concrete/Generic.hs +20/−13
- src/full/Agda/Syntax/Concrete/Glyph.hs +38/−13
- src/full/Agda/Syntax/Concrete/Name.hs +28/−2
- src/full/Agda/Syntax/Concrete/Operators.hs +213/−141
- src/full/Agda/Syntax/Concrete/Operators/Parser.hs +20/−17
- src/full/Agda/Syntax/Concrete/Operators/Parser/Monad.hs +42/−6
- src/full/Agda/Syntax/Concrete/Pattern.hs +16/−12
- src/full/Agda/Syntax/Concrete/Pretty.hs +133/−136
- src/full/Agda/Syntax/DoNotation.hs +13/−8
- src/full/Agda/Syntax/Fixity.hs +2/−0
- src/full/Agda/Syntax/IdiomBrackets.hs +13/−10
- src/full/Agda/Syntax/Info.hs +8/−8
- src/full/Agda/Syntax/Internal.hs +676/−149
- src/full/Agda/Syntax/Internal/Blockers.hs +18/−18
- src/full/Agda/Syntax/Internal/Defs.hs +98/−74
- src/full/Agda/Syntax/Internal/Elim.hs +21/−3
- src/full/Agda/Syntax/Internal/Generic.hs +8/−4
- src/full/Agda/Syntax/Internal/MetaVars.hs +15/−4
- src/full/Agda/Syntax/Internal/Names.hs +68/−32
- src/full/Agda/Syntax/Internal/Pattern.hs +13/−8
- src/full/Agda/Syntax/Internal/SanityCheck.hs +2/−2
- src/full/Agda/Syntax/Literal.hs +6/−4
- src/full/Agda/Syntax/Notation.hs +18/−5
- src/full/Agda/Syntax/Parser.hs +26/−10
- src/full/Agda/Syntax/Parser/Alex.hs +16/−10
- src/full/Agda/Syntax/Parser/Comments.hs +1/−1
- src/full/Agda/Syntax/Parser/Helpers.hs +189/−86
- src/full/Agda/Syntax/Parser/LexActions.hs +37/−15
- src/full/Agda/Syntax/Parser/LexActions.hs-boot +6/−6
- src/full/Agda/Syntax/Parser/Lexer.x +27/−24
- src/full/Agda/Syntax/Parser/Literate.hs +26/−17
- src/full/Agda/Syntax/Parser/Monad.hs +205/−60
- src/full/Agda/Syntax/Parser/Parser.y +240/−220
- src/full/Agda/Syntax/Parser/Tokens.hs +59/−12
- src/full/Agda/Syntax/Position.hs +145/−41
- src/full/Agda/Syntax/Reflected.hs +5/−4
- src/full/Agda/Syntax/Scope/Base.hs +581/−355
- src/full/Agda/Syntax/Scope/Flat.hs +0/−141
- src/full/Agda/Syntax/Scope/Monad.hs +232/−153
- src/full/Agda/Syntax/Scope/Operator.hs +220/−0
- src/full/Agda/Syntax/Scope/State.hs +52/−0
- src/full/Agda/Syntax/Scope/UnusedImports.hs +327/−0
- src/full/Agda/Syntax/TopLevelModuleName.hs +5/−13
- src/full/Agda/Syntax/TopLevelModuleName/Boot.hs +6/−5
- src/full/Agda/Syntax/Translation/AbstractToConcrete.hs +105/−51
- src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs +4010/−3638
- src/full/Agda/Syntax/Translation/InternalToAbstract.hs +283/−188
- src/full/Agda/Syntax/Translation/ReflectedToAbstract.hs +14/−23
- src/full/Agda/Syntax/Treeless.hs +76/−15
- src/full/Agda/Termination/CallGraph.hs +54/−17
- src/full/Agda/Termination/CallMatrix.hs +9/−0
- src/full/Agda/Termination/CutOff.hs +20/−2
- src/full/Agda/Termination/Monad.hs +167/−86
- src/full/Agda/Termination/Order.hs +8/−0
- src/full/Agda/Termination/RecCheck.hs +19/−11
- src/full/Agda/Termination/SparseMatrix.hs +22/−2
- src/full/Agda/Termination/TermCheck.hs +362/−263
- src/full/Agda/Termination/Termination.hs +43/−17
- src/full/Agda/TypeChecking/Abstract.hs +50/−27
- src/full/Agda/TypeChecking/CheckInternal.hs +107/−60
- src/full/Agda/TypeChecking/CheckInternal.hs-boot +10/−25
- src/full/Agda/TypeChecking/CompiledClause.hs +76/−27
- src/full/Agda/TypeChecking/CompiledClause/Compile.hs +63/−50
- src/full/Agda/TypeChecking/CompiledClause/Match.hs +44/−34
- src/full/Agda/TypeChecking/Constraints.hs +120/−91
- src/full/Agda/TypeChecking/Constraints.hs-boot +1/−4
- src/full/Agda/TypeChecking/Conversion.hs +532/−408
- src/full/Agda/TypeChecking/Conversion.hs-boot +17/−31
- src/full/Agda/TypeChecking/Conversion/Errors.hs +842/−0
- src/full/Agda/TypeChecking/Conversion/Errors.hs-boot +7/−0
- src/full/Agda/TypeChecking/Conversion/Pure.hs +71/−171
- src/full/Agda/TypeChecking/Coverage.hs +238/−162
- src/full/Agda/TypeChecking/Coverage/Cubical.hs +56/−44
- src/full/Agda/TypeChecking/Coverage/Match.hs +13/−135
- src/full/Agda/TypeChecking/Coverage/SplitClause.hs +31/−18
- src/full/Agda/TypeChecking/Coverage/SplitPattern.hs +137/−0
- src/full/Agda/TypeChecking/Coverage/SplitTree.hs +10/−4
- src/full/Agda/TypeChecking/Datatypes.hs +31/−22
- src/full/Agda/TypeChecking/Datatypes.hs-boot +5/−4
- src/full/Agda/TypeChecking/DeadCode.hs +86/−33
- src/full/Agda/TypeChecking/DiscrimTree.hs +8/−6
- src/full/Agda/TypeChecking/DisplayForm.hs +1/−1
- src/full/Agda/TypeChecking/DropArgs.hs +14/−12
- src/full/Agda/TypeChecking/Empty.hs +21/−14
- src/full/Agda/TypeChecking/Empty.hs-boot +3/−3
- src/full/Agda/TypeChecking/Errors.hs +430/−294
- src/full/Agda/TypeChecking/Errors.hs-boot +9/−1
- src/full/Agda/TypeChecking/Errors/Names.hs +22/−15
- src/full/Agda/TypeChecking/EtaContract.hs +11/−8
- src/full/Agda/TypeChecking/EtaContract.hs-boot +8/−0
- src/full/Agda/TypeChecking/Free.hs +436/−216
- src/full/Agda/TypeChecking/Free/Base.hs +317/−0
- src/full/Agda/TypeChecking/Free/Generic.hs +356/−0
- src/full/Agda/TypeChecking/Free/Lazy.hs +0/−613
- src/full/Agda/TypeChecking/Free/Precompute.hs +12/−4
- src/full/Agda/TypeChecking/Free/Reduce.hs +164/−95
- src/full/Agda/TypeChecking/Free/Reduce.hs-boot +13/−0
- src/full/Agda/TypeChecking/Functions.hs +14/−13
- src/full/Agda/TypeChecking/Generalize.hs +134/−133
- src/full/Agda/TypeChecking/IApplyConfluence.hs +16/−10
- src/full/Agda/TypeChecking/Implicit.hs +114/−44
- src/full/Agda/TypeChecking/Injectivity.hs +28/−24
- src/full/Agda/TypeChecking/Inlining.hs +2/−3
- src/full/Agda/TypeChecking/InstanceArguments.hs +138/−88
- src/full/Agda/TypeChecking/InstanceArguments.hs-boot +2/−1
- src/full/Agda/TypeChecking/Irrelevance.hs +82/−8
- src/full/Agda/TypeChecking/Level.hs +7/−3
- src/full/Agda/TypeChecking/LevelConstraints.hs +18/−10
- src/full/Agda/TypeChecking/Lock.hs +31/−20
- src/full/Agda/TypeChecking/MetaVars.hs +385/−302
- src/full/Agda/TypeChecking/MetaVars.hs-boot +9/−9
- src/full/Agda/TypeChecking/MetaVars/Mention.hs +20/−2
- src/full/Agda/TypeChecking/MetaVars/Occurs.hs +356/−190
- src/full/Agda/TypeChecking/Modalities.hs +7/−11
- src/full/Agda/TypeChecking/Monad/Base.hs +7573/−6699
- src/full/Agda/TypeChecking/Monad/Base/Types.hs +92/−10
- src/full/Agda/TypeChecking/Monad/Benchmark.hs +123/−4
- src/full/Agda/TypeChecking/Monad/Builtin.hs +25/−6
- src/full/Agda/TypeChecking/Monad/Caching.hs +31/−12
- src/full/Agda/TypeChecking/Monad/Closure.hs +3/−4
- src/full/Agda/TypeChecking/Monad/Constraints.hs +90/−42
- src/full/Agda/TypeChecking/Monad/Context.hs +355/−121
- src/full/Agda/TypeChecking/Monad/Context.hs-boot +8/−2
- src/full/Agda/TypeChecking/Monad/Debug.hs +132/−122
- src/full/Agda/TypeChecking/Monad/Env.hs +38/−24
- src/full/Agda/TypeChecking/Monad/Imports.hs +28/−27
- src/full/Agda/TypeChecking/Monad/MetaVars.hs +121/−56
- src/full/Agda/TypeChecking/Monad/Modality.hs +69/−24
- src/full/Agda/TypeChecking/Monad/Mutual.hs +4/−4
- src/full/Agda/TypeChecking/Monad/Open.hs +15/−0
- src/full/Agda/TypeChecking/Monad/Options.hs +44/−25
- src/full/Agda/TypeChecking/Monad/Options.hs-boot +1/−2
- src/full/Agda/TypeChecking/Monad/Pure.hs +8/−0
- src/full/Agda/TypeChecking/Monad/Pure.hs-boot +1/−0
- src/full/Agda/TypeChecking/Monad/Signature.hs +412/−190
- src/full/Agda/TypeChecking/Monad/Signature.hs-boot +15/−10
- src/full/Agda/TypeChecking/Monad/SizedTypes.hs +4/−4
- src/full/Agda/TypeChecking/Monad/State.hs +141/−76
- src/full/Agda/TypeChecking/Monad/State.hs-boot +7/−0
- src/full/Agda/TypeChecking/Monad/Statistics.hs +57/−41
- src/full/Agda/TypeChecking/Monad/Trace.hs +35/−17
- src/full/Agda/TypeChecking/Names.hs +2/−2
- src/full/Agda/TypeChecking/Opacity.hs +23/−21
- src/full/Agda/TypeChecking/Opacity.hs-boot +1/−1
- src/full/Agda/TypeChecking/Patterns/Abstract.hs +2/−2
- src/full/Agda/TypeChecking/Patterns/Match.hs +100/−59
- src/full/Agda/TypeChecking/Patterns/Match.hs-boot +4/−1
- src/full/Agda/TypeChecking/Polarity.hs +85/−59
- src/full/Agda/TypeChecking/Polarity.hs-boot +3/−13
- src/full/Agda/TypeChecking/Positivity.hs +358/−912
- src/full/Agda/TypeChecking/Positivity/Occurrence.hs +110/−154
- src/full/Agda/TypeChecking/Positivity/OccurrenceAnalysis.hs +989/−0
- src/full/Agda/TypeChecking/Positivity/Warnings.hs +137/−0
- src/full/Agda/TypeChecking/Pretty.hs +166/−12
- src/full/Agda/TypeChecking/Pretty.hs-boot +2/−1
- src/full/Agda/TypeChecking/Pretty/Call.hs +14/−6
- src/full/Agda/TypeChecking/Pretty/Constraint.hs +4/−2
- src/full/Agda/TypeChecking/Pretty/Warning.hs +253/−109
- src/full/Agda/TypeChecking/Primitive.hs +46/−4
- src/full/Agda/TypeChecking/Primitive.hs-boot +2/−1
- src/full/Agda/TypeChecking/Primitive/Base.hs +25/−10
- src/full/Agda/TypeChecking/Primitive/Cubical.hs +19/−46
- src/full/Agda/TypeChecking/Primitive/Cubical/Base.hs +9/−8
- src/full/Agda/TypeChecking/Primitive/Cubical/Glue.hs +1/−2
- src/full/Agda/TypeChecking/Primitive/Cubical/HCompU.hs +3/−4
- src/full/Agda/TypeChecking/ProjectionLike.hs +88/−60
- src/full/Agda/TypeChecking/Quote.hs +10/−13
- src/full/Agda/TypeChecking/ReconstructParameters.hs +13/−6
- src/full/Agda/TypeChecking/RecordPatterns.hs +33/−18
- src/full/Agda/TypeChecking/Records.hs +132/−127
- src/full/Agda/TypeChecking/Records.hs-boot +8/−4
- src/full/Agda/TypeChecking/Reduce.hs +590/−350
- src/full/Agda/TypeChecking/Reduce.hs-boot +20/−2
- src/full/Agda/TypeChecking/Reduce/Fast.hs +1630/−1473
- src/full/Agda/TypeChecking/Reduce/Monad.hs +17/−33
- src/full/Agda/TypeChecking/Rewriting.hs +232/−149
- src/full/Agda/TypeChecking/Rewriting.hs-boot +1/−0
- src/full/Agda/TypeChecking/Rewriting/Clause.hs +14/−14
- src/full/Agda/TypeChecking/Rewriting/Confluence.hs +175/−147
- src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs +93/−60
- src/full/Agda/TypeChecking/Rewriting/NonLinPattern.hs +130/−109
- src/full/Agda/TypeChecking/Rules/Application.hs +259/−233
- src/full/Agda/TypeChecking/Rules/Application.hs-boot +1/−3
- src/full/Agda/TypeChecking/Rules/Builtin.hs +58/−44
- src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs +9/−8
- src/full/Agda/TypeChecking/Rules/Data.hs +190/−159
- src/full/Agda/TypeChecking/Rules/Decl.hs +166/−122
- src/full/Agda/TypeChecking/Rules/Decl.hs-boot +0/−1
- src/full/Agda/TypeChecking/Rules/Def.hs +154/−146
- src/full/Agda/TypeChecking/Rules/Def.hs-boot +1/−1
- src/full/Agda/TypeChecking/Rules/Display.hs +28/−22
- src/full/Agda/TypeChecking/Rules/LHS.hs +357/−243
- src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs +3/−3
- src/full/Agda/TypeChecking/Rules/LHS/Problem.hs +18/−4
- src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs +15/−4
- src/full/Agda/TypeChecking/Rules/LHS/Unify.hs +151/−114
- src/full/Agda/TypeChecking/Rules/LHS/Unify/LeftInverse.hs +223/−188
- src/full/Agda/TypeChecking/Rules/LHS/Unify/Types.hs +22/−20
- src/full/Agda/TypeChecking/Rules/Record.hs +102/−257
- src/full/Agda/TypeChecking/Rules/Record/Cubical.hs +208/−0
- src/full/Agda/TypeChecking/Rules/Term.hs +341/−174
- src/full/Agda/TypeChecking/Serialise.hs +200/−224
- src/full/Agda/TypeChecking/Serialise/Base.hs +460/−322
- src/full/Agda/TypeChecking/Serialise/Instances.hs +2/−2
- src/full/Agda/TypeChecking/Serialise/Instances/Abstract.hs +83/−90
- src/full/Agda/TypeChecking/Serialise/Instances/Common.hs +196/−332
- src/full/Agda/TypeChecking/Serialise/Instances/Compilers.hs +0/−1
- src/full/Agda/TypeChecking/Serialise/Instances/Errors.hs +345/−179
- src/full/Agda/TypeChecking/Serialise/Instances/General.hs +355/−0
- src/full/Agda/TypeChecking/Serialise/Instances/Highlighting.hs +83/−56
- src/full/Agda/TypeChecking/Serialise/Instances/Internal.hs +290/−214
- src/full/Agda/TypeChecking/Serialise/Node.hs +133/−0
- src/full/Agda/TypeChecking/SizedTypes.hs +33/−39
- src/full/Agda/TypeChecking/SizedTypes/Solve.hs +23/−20
- src/full/Agda/TypeChecking/SizedTypes/Syntax.hs +1/−1
- src/full/Agda/TypeChecking/SizedTypes/Utils.hs +5/−5
- src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs +1/−1
- src/full/Agda/TypeChecking/Sort.hs +39/−62
- src/full/Agda/TypeChecking/Substitute.hs +570/−280
- src/full/Agda/TypeChecking/Substitute/Class.hs +25/−21
- src/full/Agda/TypeChecking/Substitute/DeBruijn.hs +7/−1
- src/full/Agda/TypeChecking/SyntacticEquality.hs +127/−99
- src/full/Agda/TypeChecking/Telescope.hs +157/−101
- src/full/Agda/TypeChecking/Telescope/Path.hs +1/−2
- src/full/Agda/TypeChecking/Unquote.hs +86/−51
- src/full/Agda/TypeChecking/Warnings.hs +21/−12
- src/full/Agda/TypeChecking/With.hs +21/−14
- src/full/Agda/Utils/AssocList.hs +3/−3
- src/full/Agda/Utils/Atomic.hs +75/−0
- src/full/Agda/Utils/Bag.hs +9/−9
- src/full/Agda/Utils/Benchmark.hs +25/−6
- src/full/Agda/Utils/BiMap.hs +8/−9
- src/full/Agda/Utils/BinTree.hs +40/−0
- src/full/Agda/Utils/BinTree1.hs +31/−0
- src/full/Agda/Utils/BoolSet.hs +1/−1
- src/full/Agda/Utils/Boolean.hs +2/−1
- src/full/Agda/Utils/ByteArray.hs +165/−0
- src/full/Agda/Utils/CallStack/Pretty.hs +3/−2
- src/full/Agda/Utils/Cluster.hs +1/−1
- src/full/Agda/Utils/CompactRegion.hs +30/−0
- src/full/Agda/Utils/CompressedTrie.hs +186/−0
- src/full/Agda/Utils/DocTree.hs +318/−0
- src/full/Agda/Utils/Either.hs +1/−1
- src/full/Agda/Utils/ExpandCase.hs +95/−0
- src/full/Agda/Utils/Favorites.hs +6/−6
- src/full/Agda/Utils/FileId.hs +36/−19
- src/full/Agda/Utils/FileName.hs too large to diff
- src/full/Agda/Utils/Float.hs too large to diff
- src/full/Agda/Utils/Function.hs too large to diff
- src/full/Agda/Utils/Functor.hs too large to diff
- src/full/Agda/Utils/GetOpt.hs too large to diff
- src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs too large to diff
- src/full/Agda/Utils/Graph/TopSort.hs too large to diff
- src/full/Agda/Utils/Hash.hs too large to diff
- src/full/Agda/Utils/HashTable.hs too large to diff
- src/full/Agda/Utils/Haskell/Syntax.hs too large to diff
- src/full/Agda/Utils/IArray.hs too large to diff
- src/full/Agda/Utils/IO/Directory.hs too large to diff
- src/full/Agda/Utils/IO/TempFile.hs too large to diff
- src/full/Agda/Utils/IO/Terminal.hs too large to diff
- src/full/Agda/Utils/IO/UTF8.hs too large to diff
- src/full/Agda/Utils/IORef/Strict.hs too large to diff
- src/full/Agda/Utils/IndexMap.hs too large to diff
- src/full/Agda/Utils/IntMap.hs too large to diff
- src/full/Agda/Utils/IntSet/Infinite.hs too large to diff
- src/full/Agda/Utils/Lens.hs too large to diff
- src/full/Agda/Utils/List.hs too large to diff
- src/full/Agda/Utils/List1.hs too large to diff
- src/full/Agda/Utils/List2.hs too large to diff
- src/full/Agda/Utils/ListInf.hs too large to diff
- src/full/Agda/Utils/ListT.hs too large to diff
- src/full/Agda/Utils/Map.hs too large to diff
- src/full/Agda/Utils/Map1.hs too large to diff
- src/full/Agda/Utils/Maybe.hs too large to diff
- src/full/Agda/Utils/Maybe/Strict.hs too large to diff
- src/full/Agda/Utils/Maybe/Unboxable.hs too large to diff
- src/full/Agda/Utils/Memo.hs too large to diff
- src/full/Agda/Utils/MinimalArray/Lifted.hs too large to diff
- src/full/Agda/Utils/MinimalArray/MutableLifted.hs too large to diff
- src/full/Agda/Utils/MinimalArray/MutablePrim.hs too large to diff
- src/full/Agda/Utils/MinimalArray/Prim.hs too large to diff
- src/full/Agda/Utils/Monad.hs too large to diff
- src/full/Agda/Utils/Monoid.hs too large to diff
- src/full/Agda/Utils/Null.hs too large to diff
- src/full/Agda/Utils/Parser/MemoisedCPS.hs too large to diff
- src/full/Agda/Utils/PartialOrd.hs too large to diff
- src/full/Agda/Utils/Permutation.hs too large to diff
- src/full/Agda/Utils/ProfileOptions.hs too large to diff
- src/full/Agda/Utils/Range.hs too large to diff
- src/full/Agda/Utils/RangeMap.hs too large to diff
- src/full/Agda/Utils/Semigroup.hs too large to diff
- src/full/Agda/Utils/Serialize.hs too large to diff
- src/full/Agda/Utils/Set.hs too large to diff
- src/full/Agda/Utils/Set1.hs too large to diff
- src/full/Agda/Utils/Singleton.hs too large to diff
- src/full/Agda/Utils/Size.hs too large to diff
- src/full/Agda/Utils/SmallSet.hs too large to diff
- src/full/Agda/Utils/StrictEndo.hs too large to diff
- src/full/Agda/Utils/StrictFlipEndo.hs too large to diff
- src/full/Agda/Utils/StrictReader.hs too large to diff
- src/full/Agda/Utils/StrictState.hs too large to diff
- src/full/Agda/Utils/StrictState2.hs too large to diff
- src/full/Agda/Utils/StrictWriter.hs too large to diff
- src/full/Agda/Utils/String.hs too large to diff
- src/full/Agda/Utils/Suffix.hs too large to diff
- src/full/Agda/Utils/Three.hs too large to diff
- src/full/Agda/Utils/Time.hs too large to diff
- src/full/Agda/Utils/Trie.hs too large to diff
- src/full/Agda/Utils/Tuple.hs too large to diff
- src/full/Agda/Utils/Tuple/Strict.hs too large to diff
- src/full/Agda/Utils/TypeLevel.hs too large to diff
- src/full/Agda/Utils/Unsafe.hs too large to diff
- src/full/Agda/Utils/Update.hs too large to diff
- src/full/Agda/Utils/VarSet.hs too large to diff
- src/full/Agda/Utils/WithDefault.hs too large to diff
- src/full/Agda/Utils/Word.hs too large to diff
- src/full/Agda/Utils/Zip.hs too large to diff
- src/full/Agda/Utils/Zipper.hs too large to diff
- src/setup/Agda/Setup.hs too large to diff
- src/setup/Agda/Setup/DataFiles.hs too large to diff
- src/setup/Agda/Setup/LockFile.hs too large to diff
- src/setup/Agda/VersionCommit.hs too large to diff
- stack-8.10.7.yaml too large to diff
- stack-8.8.4.yaml too large to diff
- stack-9.0.2.yaml too large to diff
- stack-9.10.3.yaml too large to diff
- stack-9.12.4.yaml too large to diff
- stack-9.14.1.yaml too large to diff
- stack-9.2.8.yaml too large to diff
- stack-9.4.8.yaml too large to diff
Agda.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: Agda-version: 2.8.0.2+version: 2.9.0 build-type: Simple license: MIT license-file: LICENSE@@ -37,14 +37,12 @@ GHC == 9.6.7 GHC == 9.4.8 GHC == 9.2.8- GHC == 9.0.2- GHC == 8.10.7- GHC == 8.8.4 extra-doc-files: CHANGELOG.md README.md doc/user-manual/agda.svg+ doc/release-notes/2.8.0.2.md doc/release-notes/2.8.0.1.md doc/release-notes/2.8.0.md doc/release-notes/2.7.0.1.md@@ -99,9 +97,6 @@ stack-9.6.7.yaml stack-9.4.8.yaml stack-9.2.8.yaml- stack-9.0.2.yaml- stack-8.10.7.yaml- stack-8.8.4.yaml -- Agda's data files, embedded by module Agda.Setup. -- Keep in sync with the list in Agda.Setup.DataFiles and below. src/data/emacs-mode/agda-input.el@@ -133,6 +128,11 @@ src/data/lib/prim/Agda/Builtin/Equality.agda src/data/lib/prim/Agda/Builtin/Equality/Erase.agda src/data/lib/prim/Agda/Builtin/Equality/Rewrite.agda+ src/data/lib/prim/Agda/Builtin/Erased/Box-cong.agda+ src/data/lib/prim/Agda/Builtin/Erased/Erased.agda+ src/data/lib/prim/Agda/Builtin/Erased/Funext.agda+ src/data/lib/prim/Agda/Builtin/Erased/Propext.agda+ src/data/lib/prim/Agda/Builtin/Erased/Quotient.agda src/data/lib/prim/Agda/Builtin/Float.agda src/data/lib/prim/Agda/Builtin/Float/Properties.agda src/data/lib/prim/Agda/Builtin/FromNat.agda@@ -191,6 +191,11 @@ lib/prim/Agda/Builtin/Equality.agda lib/prim/Agda/Builtin/Equality/Erase.agda lib/prim/Agda/Builtin/Equality/Rewrite.agda+ lib/prim/Agda/Builtin/Erased/Box-cong.agda+ lib/prim/Agda/Builtin/Erased/Erased.agda+ lib/prim/Agda/Builtin/Erased/Funext.agda+ lib/prim/Agda/Builtin/Erased/Propext.agda+ lib/prim/Agda/Builtin/Erased/Quotient.agda lib/prim/Agda/Builtin/Float.agda lib/prim/Agda/Builtin/Float/Properties.agda lib/prim/Agda/Builtin/FromNat.agda@@ -225,7 +230,7 @@ source-repository this type: git location: https://github.com/agda/agda.git- tag: v2.8.0.2+ tag: v2.9.0 -- Build flags ---------------------------------------------------------------------------@@ -282,6 +287,16 @@ description: Suffix version information with the Git commit hash when available. +flag ignore-build-tool-depends+ default: False+ manual: True+ description:+ Ignore the build-tool-depends stanza, and trust user-provided tools on the PATH.+ This is intended to be used in declarative build environemnts like Nix or Guix,+ which will manage the installation of build tools like alex or happy.+ See github.com/NixOS/nixpkgs/issues/130556 and https://github.com/haskell/cabal/issues/8434+ for more details.+ -- Common stanzas --------------------------------------------------------------------------- @@ -293,6 +308,7 @@ ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively+ -fstg-lift-lams if flag(use-xdg-data-home) cpp-options:@@ -309,8 +325,10 @@ -dsuppress-module-prefixes -ddump-to-file ghc-options:+ -- ASR (2022-05-31). Workaround to Issue #5932. -Wcpp-undef -Wdeprecated-flags+ -Wderiving-defaults -Wderiving-typeable -Wdodgy-exports -Wdodgy-foreign-imports@@ -319,7 +337,10 @@ -Wempty-enumerations -Widentities -Winaccessible-code+ -Wincomplete-patterns+ -Wincomplete-record-updates -Winline-rule-shadowing+ -Winvalid-haddock -Wmissed-extra-shared-lib -Wmissing-fields -Wmissing-home-modules@@ -328,9 +349,13 @@ -Wmissing-signatures -Wnoncanonical-monad-instances -Wnoncanonical-monoid-instances+ -Woperator-whitespace -Woverflowed-literals -Woverlapping-patterns--- -Wredundant-constraints+ -Woverlapping-patterns+ -Wredundant-bang-patterns+ -Wredundant-constraints+ -Wredundant-record-wildcards -Wsimplifiable-class-constraints -Wstar-binder -Wstar-is-type@@ -342,50 +367,22 @@ -Wunticked-promoted-constructors -Wunused-do-bind -Wunused-foralls+ -Wunused-packages+ -Wunused-record-wildcards -Wwarnings-deprecations -Wwrong-do-bind - -- The following warning is an error in GHC >= 8.10.- if impl(ghc < 8.10)- ghc-options:- -Wimplicit-kind-vars- -- #6623: Turn off this (nameless) warning:- -- "Pattern match checker exceeded (2000000) iterations in a case alternative."- -- See: https://gitlab.haskell.org/ghc/ghc/-/issues/13464- -Wno-incomplete-patterns- -Wno-overlapping-patterns- if impl(ghc < 9.10) ghc-options: -Wsemigroup -- The semigroup warning is deprecated in GHC 9.10 - if impl(ghc >= 8.10)- ghc-options:- -Wderiving-defaults- -Wredundant-record-wildcards- -Wunused-packages- -Wunused-record-wildcards-- if impl(ghc >= 9.0)- ghc-options:- -Winvalid-haddock- -- #6137: coverage checker works only sufficiently well from GHC 9.0- -Wincomplete-patterns- -Wincomplete-record-updates- -Woverlapping-patterns- -- 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 || >= 9.2.2)+ if impl(ghc >= 9.2.2) ghc-options: -Wunicode-bidirectional-format-characters - if impl(ghc >= 9.2)- ghc-options:- -Woperator-whitespace- -Wredundant-bang-patterns- if impl(ghc >= 9.4) ghc-options: -Wtype-equality-out-of-scope@@ -395,6 +392,11 @@ -Wforall-identifier -- The forall-identifier warning is deprecated in GHC 9.10 + if impl(ghc >= 9.8)+ ghc-options:+ -Wx-partial+ -- The x-partial warning was introduced in GHC 9.8 and is default in GHC 10+ default-language: Haskell2010 -- NOTE: If adding or removing default extensions, also change:@@ -414,6 +416,7 @@ DeriveTraversable DerivingStrategies DerivingVia+ DisambiguateRecordFields ExistentialQuantification FlexibleContexts FlexibleInstances@@ -428,7 +431,6 @@ OverloadedStrings PatternSynonyms RankNTypes- RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections@@ -437,6 +439,7 @@ TypeSynonymInstances ViewPatterns TypeApplications+ ImportQualifiedPost other-extensions: AllowAmbiguousTypes@@ -450,9 +453,9 @@ NondecreasingIndentation OverloadedLists PartialTypeSignatures- PatternGuards PolyKinds RebindableSyntax+ RecordWildCards TemplateHaskell UnboxedTuples UndecidableInstances@@ -500,82 +503,78 @@ build-depends: Win32 >= 2.6.1.0 && < 2.15 - -- We need instance TH.Lift ByteString in Agda.Setup.- -- bytestring-0.11.2.0 adds "Lift instances for all flavors of ByteString"- -- GHC 9.2 comes with bytestring-0.11.4.0- -- Older GHCs can get the instance from th-lift-instances.- if impl(ghc < 9.2)- build-depends:- th-lift-instances >= 0.1.18 && < 0.1.21- -- For libraries that come with GHC, we take the shipped version as default lower bound. -- For the other libraries, we take the lower bound from the oldest LTS we support.- -- This is currently LTS 16.31 (last for GHC 8.8.4).+ -- This is currently LTS 20.26 (last for GHC 9.2.8). build-depends: -- Please keep in alphabetical order!- , aeson >= 1.4.7.1 && < 2.4- , ansi-terminal >= 0.10.3 && < 1.2+ , aeson >= 2.0.3.0 && < 2.4+ , ansi-terminal >= 0.11.4 && < 1.2 , array >= 0.5.4.0 && < 0.6- , async >= 2.2.2 && < 2.3- , base >= 4.13.0.0 && < 4.23- , binary >= 0.8.7.0 && < 0.9+ , async >= 2.2.4 && < 2.3+ , base >= 4.16.4.0 && < 4.24 , blaze-html >= 0.9.1.2 && < 0.10+ , blaze-markup >= 0.8 && < 0.9 , boxes >= 0.1.5 && < 0.2- , bytestring >= 0.10.10.1 && < 0.13+ , bytestring >= 0.11.4.0 && < 0.13 , case-insensitive >= 1.2.1.0 && < 1.3- , containers >= 0.6.2.1 && < 0.9- -- containers-0.6.3.1 adds IntSet.mapMonotonic, but its too young for GHC 8.8+ , containers >= 0.6.5.1 && < 0.9 , data-hash >= 0.2.0.1 && < 0.3- , deepseq >= 1.4.4.0 && < 1.6- , directory >= 1.3.6.0 && < 1.4- , dlist >= 0.8.0.8 && < 1.1+ , deepseq >= 1.4.6.1 && < 1.6+ , directory >= 1.3.6.2 && < 1.4+ , dlist >= 1.0 && < 1.1 , edit-distance >= 0.2.2.1 && < 0.3 , enummapset >= 0.6.0.3 && < 0.8- , equivalence >= 0.3.5 && < 0.5+ , equivalence >= 0.4.1 && < 0.5 , exceptions >= 0.10.4 && < 0.11- , filelock >= 0.1.1.5 && < 0.2 , filepath >= 1.4.2.1 && < 1.6 , filemanip >= 0.3.6.3 && < 0.4- , generic-data >= 0.9.2.0 && < 1.2- -- generic-data-0.9.2.0 adds instance of Bounded for FiniteEnumeration- , ghc-compact == 0.1.*- , hashable >= 1.3.0.0 && < 1.6- , haskeline >= 0.7.5.0 && < 0.9- , monad-control >= 1.0.2.3 && < 1.1+ , generic-data >= 1.0.0.1 && < 1.2+ , ghc-bignum >= 1.2 && < 2+ , ghc-prim >= 0.8 && < 0.15+ , hashable >= 1.4.2.0 && < 1.6+ , haskeline >= 0.8.2 && < 0.9+ -- GHC 9.2 ships with haskeline-0.8.2.1, but 9.4 backslid to 0.8.2+ , infinite-list >= 0.1.2 && < 0.2+ , monad-control >= 1.0.3.1 && < 1.1 , mtl >= 2.2.2 && < 2.4- , murmur-hash >= 0.1.0.9 && < 0.2- , nonempty-containers >= 0.3.4.1 && < 0.4+ , murmur-hash >= 0.1.0.10 && < 0.2+ , nonempty-containers >= 0.3.4.4 && < 0.5 , parallel >= 3.2.2.0 && < 3.4 , peano >= 0.1.0.1 && < 0.2- , pqueue >= 1.4.1.3 && < 1.8+ , pqueue >= 1.4.3.0 && < 1.8+ , primitive >= 0.7 && < 0.10 , pretty >= 1.1.3.6 && < 1.2- , process >= 1.6.9.0 && < 1.7+ , process >= 1.6.16.0 && < 1.7 , process-extras >= 0.7.4 && < 0.8- , regex-tdfa >= 1.3.1.0 && < 1.4- , split >= 0.2.3.4 && < 0.3- , stm >= 2.5.0.0 && < 2.6- , STMonadTrans >= 0.4.5 && < 0.5+ , regex-tdfa >= 1.3.2.1 && < 1.4+ , split >= 0.2.3.5 && < 0.3+ , stm >= 2.5.0.2 && < 2.6 , strict >= 0.4.0.1 && < 0.6- -- module Data.Strict.Classes entered in strict-0.4- , template-haskell >= 2.15.0.0 && < 2.25- , text >= 1.2.4.0 && < 2.2- , time >= 1.9.3 && < 1.16+ , template-haskell >= 2.18.0.0 && < 2.26+ , text >= 1.2.5.0 && < 2.3+ , time >= 1.11.1.1 && < 1.17 , transformers >= 0.5.6.2 && < 0.7- , unordered-containers >= 0.2.10.0 && < 0.3+ , unordered-containers >= 0.2.19.1 && < 0.3 , uri-encode >= 1.5.0.7 && < 1.6- , vector >= 0.12.1.2 && < 0.14- , vector-hashtables >= 0.1.1.1 && < 0.2- , zlib >= 0.6.2.2 && < 0.8+ , vector >= 0.12.3.1 && < 0.14+ , vector-hashtables >= 0.1.2.0 && < 0.2+ -- vector-hashtables-0.1.2 introduces performance gains+ , zstd >= 0.1.3.0 && < 0.2 + if !arch(wasm32)+ build-depends:+ , filelock >= 0.1.1.6 && < 0.2+ -- We don't write upper bounds for Alex nor Happy because the -- `build-tool-depends` field can not be modified in Hackage.- build-tool-depends:- , alex:alex >= 3.2.5- -- alex-3.2.5 contains fixes for building with GHC 8.8- , happy:happy >= 1.19.12- -- happy-1.19.12 contains fixes for building with GHC 8.8+ if !flag(ignore-build-tool-depends)+ build-tool-depends:+ , alex:alex >= 3.2.7.4+ , happy:happy >= 1.20.1.1 exposed-modules:+ -- Keep in alphabetical order, please! Agda.Benchmarking Agda.Compiler.Backend Agda.Compiler.Backend.Base@@ -583,9 +582,9 @@ Agda.Compiler.CallCompiler Agda.Compiler.Common Agda.Compiler.JS.Compiler- Agda.Compiler.JS.Syntax- Agda.Compiler.JS.Substitution Agda.Compiler.JS.Pretty+ Agda.Compiler.JS.Substitution+ Agda.Compiler.JS.Syntax Agda.Compiler.MAlonzo.Coerce Agda.Compiler.MAlonzo.Compiler Agda.Compiler.MAlonzo.Encode@@ -616,13 +615,11 @@ Agda.Interaction.BasicOps Agda.Interaction.BuildLibrary Agda.Interaction.Command- Agda.Interaction.SearchAbout Agda.Interaction.CommandLine+ Agda.Interaction.Emacs.Lisp Agda.Interaction.EmacsCommand Agda.Interaction.EmacsTop Agda.Interaction.ExitCode- Agda.Interaction.JSONTop- Agda.Interaction.JSON Agda.Interaction.FindFile Agda.Interaction.Highlighting.Common Agda.Interaction.Highlighting.Dot@@ -634,47 +631,59 @@ Agda.Interaction.Highlighting.HTML Agda.Interaction.Highlighting.HTML.Backend Agda.Interaction.Highlighting.HTML.Base+ Agda.Interaction.Highlighting.HTML.Forester Agda.Interaction.Highlighting.JSON- Agda.Interaction.Highlighting.Precise- Agda.Interaction.Highlighting.Range- Agda.Interaction.Highlighting.Vim Agda.Interaction.Highlighting.LaTeX Agda.Interaction.Highlighting.LaTeX.Backend Agda.Interaction.Highlighting.LaTeX.Base+ Agda.Interaction.Highlighting.Precise+ Agda.Interaction.Highlighting.Range+ Agda.Interaction.Highlighting.Vim Agda.Interaction.Imports Agda.Interaction.InteractionTop- Agda.Interaction.Output- Agda.Interaction.Response- Agda.Interaction.Response.Base- Agda.Interaction.MakeCase- Agda.Interaction.Monad+ Agda.Interaction.JSON+ Agda.Interaction.JSONTop Agda.Interaction.Library Agda.Interaction.Library.Base Agda.Interaction.Library.Parse+ Agda.Interaction.MakeCase+ Agda.Interaction.Monad Agda.Interaction.Options+ Agda.Interaction.Options.Arguments+ Agda.Interaction.Options.BashCompletion+ Agda.Interaction.Options.Default Agda.Interaction.Options.Errors Agda.Interaction.Options.Help Agda.Interaction.Options.Lenses+ Agda.Interaction.Options.ProfileOptions Agda.Interaction.Options.Warnings+ Agda.Interaction.Output+ Agda.Interaction.Response+ Agda.Interaction.Response.Base+ Agda.Interaction.SearchAbout Agda.Main Agda.Mimer.Mimer+ Agda.Mimer.Monad Agda.Mimer.Options+ Agda.Mimer.Types Agda.Setup Agda.Setup.DataFiles Agda.Setup.EmacsMode+ Agda.Setup.LockFile+ Agda.Syntax.Abstract Agda.Syntax.Abstract.Name Agda.Syntax.Abstract.Pattern Agda.Syntax.Abstract.PatternSynonyms Agda.Syntax.Abstract.Pretty Agda.Syntax.Abstract.UsedNames Agda.Syntax.Abstract.Views- Agda.Syntax.Abstract Agda.Syntax.Builtin Agda.Syntax.Common Agda.Syntax.Common.Aspect Agda.Syntax.Common.KeywordRange Agda.Syntax.Common.Pretty Agda.Syntax.Common.Pretty.ANSI+ Agda.Syntax.Concrete Agda.Syntax.Concrete.Attribute Agda.Syntax.Concrete.Definitions Agda.Syntax.Concrete.Definitions.Errors@@ -684,12 +693,11 @@ Agda.Syntax.Concrete.Generic Agda.Syntax.Concrete.Glyph Agda.Syntax.Concrete.Name+ Agda.Syntax.Concrete.Operators Agda.Syntax.Concrete.Operators.Parser Agda.Syntax.Concrete.Operators.Parser.Monad- Agda.Syntax.Concrete.Operators Agda.Syntax.Concrete.Pattern Agda.Syntax.Concrete.Pretty- Agda.Syntax.Concrete Agda.Syntax.DoNotation Agda.Syntax.Fixity Agda.Syntax.IdiomBrackets@@ -706,6 +714,7 @@ Agda.Syntax.Internal.Univ Agda.Syntax.Literal Agda.Syntax.Notation+ Agda.Syntax.Parser Agda.Syntax.Parser.Alex Agda.Syntax.Parser.Comments Agda.Syntax.Parser.Helpers@@ -718,12 +727,13 @@ Agda.Syntax.Parser.Parser Agda.Syntax.Parser.StringLiterals Agda.Syntax.Parser.Tokens- Agda.Syntax.Parser Agda.Syntax.Position Agda.Syntax.Reflected Agda.Syntax.Scope.Base- Agda.Syntax.Scope.Flat Agda.Syntax.Scope.Monad+ Agda.Syntax.Scope.Operator+ Agda.Syntax.Scope.State+ Agda.Syntax.Scope.UnusedImports Agda.Syntax.TopLevelModuleName Agda.Syntax.TopLevelModuleName.Boot Agda.Syntax.Translation.AbstractToConcrete@@ -737,8 +747,8 @@ Agda.Termination.Monad Agda.Termination.Order Agda.Termination.RecCheck- Agda.Termination.SparseMatrix Agda.Termination.Semiring+ Agda.Termination.SparseMatrix Agda.Termination.TermCheck Agda.Termination.Termination Agda.TheTypeChecker@@ -749,27 +759,30 @@ Agda.TypeChecking.CompiledClause.Match Agda.TypeChecking.Constraints Agda.TypeChecking.Conversion+ Agda.TypeChecking.Conversion.Errors Agda.TypeChecking.Conversion.Pure Agda.TypeChecking.Coverage+ Agda.TypeChecking.Coverage.Cubical Agda.TypeChecking.Coverage.Match- Agda.TypeChecking.Coverage.SplitTree Agda.TypeChecking.Coverage.SplitClause- Agda.TypeChecking.Coverage.Cubical+ Agda.TypeChecking.Coverage.SplitPattern+ Agda.TypeChecking.Coverage.SplitTree Agda.TypeChecking.Datatypes Agda.TypeChecking.DeadCode- Agda.TypeChecking.DisplayForm- Agda.TypeChecking.DropArgs Agda.TypeChecking.DiscrimTree Agda.TypeChecking.DiscrimTree.Types+ Agda.TypeChecking.DisplayForm+ Agda.TypeChecking.DropArgs Agda.TypeChecking.Empty- Agda.TypeChecking.EtaContract Agda.TypeChecking.Errors Agda.TypeChecking.Errors.Names+ Agda.TypeChecking.EtaContract+ Agda.TypeChecking.Forcing Agda.TypeChecking.Free- Agda.TypeChecking.Free.Lazy+ Agda.TypeChecking.Free.Base+ Agda.TypeChecking.Free.Generic Agda.TypeChecking.Free.Precompute Agda.TypeChecking.Free.Reduce- Agda.TypeChecking.Forcing Agda.TypeChecking.Functions Agda.TypeChecking.Generalize Agda.TypeChecking.IApplyConfluence@@ -779,13 +792,14 @@ Agda.TypeChecking.InstanceArguments Agda.TypeChecking.Irrelevance Agda.TypeChecking.Level+ Agda.TypeChecking.Level.Solve Agda.TypeChecking.LevelConstraints Agda.TypeChecking.Lock- Agda.TypeChecking.Level.Solve Agda.TypeChecking.MetaVars Agda.TypeChecking.MetaVars.Mention Agda.TypeChecking.MetaVars.Occurs Agda.TypeChecking.Modalities+ Agda.TypeChecking.Monad Agda.TypeChecking.Monad.Base Agda.TypeChecking.Monad.Base.Types Agda.TypeChecking.Monad.Base.Warning@@ -809,7 +823,6 @@ Agda.TypeChecking.Monad.State Agda.TypeChecking.Monad.Statistics Agda.TypeChecking.Monad.Trace- Agda.TypeChecking.Monad Agda.TypeChecking.Names Agda.TypeChecking.Opacity Agda.TypeChecking.Patterns.Abstract@@ -818,6 +831,8 @@ Agda.TypeChecking.Polarity Agda.TypeChecking.Positivity Agda.TypeChecking.Positivity.Occurrence+ Agda.TypeChecking.Positivity.OccurrenceAnalysis+ Agda.TypeChecking.Positivity.Warnings Agda.TypeChecking.Pretty Agda.TypeChecking.Pretty.Call Agda.TypeChecking.Pretty.Constraint@@ -825,8 +840,8 @@ Agda.TypeChecking.Primitive Agda.TypeChecking.Primitive.Base Agda.TypeChecking.Primitive.Cubical- Agda.TypeChecking.Primitive.Cubical.Glue Agda.TypeChecking.Primitive.Cubical.Base+ Agda.TypeChecking.Primitive.Cubical.Glue Agda.TypeChecking.Primitive.Cubical.HCompU Agda.TypeChecking.ProjectionLike Agda.TypeChecking.Quote@@ -853,9 +868,10 @@ 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.LHS.Unify.Types Agda.TypeChecking.Rules.Record+ Agda.TypeChecking.Rules.Record.Cubical Agda.TypeChecking.Rules.Term Agda.TypeChecking.Serialise Agda.TypeChecking.Serialise.Base@@ -863,9 +879,11 @@ Agda.TypeChecking.Serialise.Instances.Abstract Agda.TypeChecking.Serialise.Instances.Common Agda.TypeChecking.Serialise.Instances.Compilers+ Agda.TypeChecking.Serialise.Instances.Errors+ Agda.TypeChecking.Serialise.Instances.General Agda.TypeChecking.Serialise.Instances.Highlighting Agda.TypeChecking.Serialise.Instances.Internal- Agda.TypeChecking.Serialise.Instances.Errors+ Agda.TypeChecking.Serialise.Node Agda.TypeChecking.SizedTypes Agda.TypeChecking.SizedTypes.Pretty Agda.TypeChecking.SizedTypes.Solve@@ -885,24 +903,32 @@ Agda.Utils.AffineHole Agda.Utils.Applicative Agda.Utils.AssocList+ Agda.Utils.Atomic Agda.Utils.Bag Agda.Utils.Benchmark Agda.Utils.BiMap- Agda.Utils.Boolean+ Agda.Utils.BinTree+ Agda.Utils.BinTree1 Agda.Utils.BoolSet+ Agda.Utils.Boolean+ Agda.Utils.ByteArray Agda.Utils.CallStack Agda.Utils.Char Agda.Utils.Cluster+ Agda.Utils.CompactRegion+ Agda.Utils.CompressedTrie+ Agda.Utils.DocTree+ Agda.Utils.Either Agda.Utils.Empty Agda.Utils.Environment- Agda.Utils.Either+ Agda.Utils.ExpandCase Agda.Utils.Fail Agda.Utils.Favorites- Agda.Utils.FileName Agda.Utils.FileId+ Agda.Utils.FileName Agda.Utils.Float- Agda.Utils.Functor Agda.Utils.Function+ Agda.Utils.Functor Agda.Utils.GetOpt Agda.Utils.Graph.AdjacencyMap.Unidirectional Agda.Utils.Graph.TopSort@@ -910,53 +936,74 @@ Agda.Utils.HashTable Agda.Utils.Haskell.Syntax Agda.Utils.IArray- Agda.Utils.Impossible- Agda.Utils.IndexedList- Agda.Utils.IntSet.Infinite Agda.Utils.IO Agda.Utils.IO.Binary Agda.Utils.IO.Directory Agda.Utils.IO.TempFile+ Agda.Utils.IO.Terminal Agda.Utils.IO.UTF8 Agda.Utils.IORef+ Agda.Utils.IORef.Strict+ Agda.Utils.Impossible+ Agda.Utils.IndexedList+ Agda.Utils.IndexMap+ Agda.Utils.IntMap+ Agda.Utils.IntSet.Infinite Agda.Utils.Lens Agda.Utils.Lens.Examples Agda.Utils.List Agda.Utils.List1 Agda.Utils.List2+ Agda.Utils.ListInf Agda.Utils.ListT Agda.Utils.Map Agda.Utils.Map1 Agda.Utils.Maybe Agda.Utils.Maybe.Strict+ Agda.Utils.Maybe.Unboxable Agda.Utils.Memo+ Agda.Utils.MinimalArray.Lifted+ Agda.Utils.MinimalArray.MutableLifted+ Agda.Utils.MinimalArray.MutablePrim+ Agda.Utils.MinimalArray.Prim Agda.Utils.Monad Agda.Utils.Monoid Agda.Utils.Null+ Agda.Utils.POMonoid Agda.Utils.Parser.MemoisedCPS Agda.Utils.PartialOrd Agda.Utils.Permutation- Agda.Utils.POMonoid- Agda.Utils.ProfileOptions+ Agda.Utils.Range Agda.Utils.RangeMap Agda.Utils.SemiRing Agda.Utils.Semigroup+ Agda.Utils.Serialize+ Agda.Utils.Set Agda.Utils.Set1 Agda.Utils.Singleton Agda.Utils.Size Agda.Utils.SmallSet+ Agda.Utils.StrictEndo+ Agda.Utils.StrictFlipEndo+ Agda.Utils.StrictReader+ Agda.Utils.StrictState+ Agda.Utils.StrictState2+ Agda.Utils.StrictWriter Agda.Utils.String Agda.Utils.Suffix Agda.Utils.Three Agda.Utils.Time Agda.Utils.Trie Agda.Utils.Tuple+ Agda.Utils.Tuple.Strict Agda.Utils.TypeLevel Agda.Utils.TypeLits Agda.Utils.Unsafe Agda.Utils.Update Agda.Utils.VarSet Agda.Utils.WithDefault+ Agda.Utils.Word+ Agda.Utils.Zip Agda.Utils.Zipper Agda.Version Agda.VersionCommit@@ -990,14 +1037,18 @@ -- However, we sometimes recommend people to use +RTS to control -- Agda's memory usage, so we want this functionality enabled by -- default.+ ghc-options:+ -rtsopts -- The threaded RTS by default starts a major GC after a program has -- been idle for 0.3 s. This feature turned out to be annoying, so -- the idle GC is now by default turned off (-I0).- ghc-options:- -threaded- -rtsopts- -with-rtsopts=-I0+ if !arch(wasm32)+ ghc-options:+ -threaded+ "-with-rtsopts=-I0 -N1 -qb0"+ else+ ghc-options: -with-rtsopts=-I0 -- agda-mode executable ---------------------------------------------------------------------------@@ -1014,26 +1065,22 @@ Agda.Setup Agda.Setup.DataFiles Agda.Setup.EmacsMode+ Agda.Setup.LockFile Agda.Version Agda.VersionCommit - -- We need instance TH.Lift ByteString in Agda.Setup.- -- bytestring-0.11.2.0 adds "Lift instances for all flavors of ByteString"- -- GHC 9.2 comes with bytestring-0.11.4.0- -- Older GHCs can get the instance from th-lift-instances.- if impl(ghc < 9.2)- build-depends:- th-lift-instances >= 0.1.18 && < 0.1.21- build-depends:- , base >= 4.13.0.0 && < 4.23- , bytestring >= 0.10.10.1 && < 0.13- , directory >= 1.3.6.0 && < 1.4- , filelock >= 0.1.1.5 && < 0.2- , filepath >= 1.4.2.1 && < 1.6- , process >= 1.6.9.0 && < 1.7- , template-haskell >= 2.15.0.0 && < 2.25+ , base >= 4.16.4.0 && < 4.24+ , bytestring >= 0.11.4.0 && < 0.13+ , directory >= 1.3.6.2 && < 1.4+ , filepath >= 1.4.2.2 && < 1.6+ , process >= 1.6.16.0 && < 1.7+ , template-haskell >= 2.18.0.0 && < 2.26 if flag(version-with-git-hash) build-depends: gitrev >= 1.3.1 && < 2++ if !arch(wasm32)+ build-depends:+ , filelock >= 0.1.1.6 && < 0.2
CHANGELOG.md view
@@ -1,11 +1,1378 @@-Release notes for Agda version 2.8.0.2-======================================--This version fixes two issues with the released binaries.-No non-installation related issues were fixed over 2.8.0 or 2.8.0.1.-So if you have installed 2.8.0 or 2.8.0.1 already there is no need to upgrade to 2.8.0.2.--* Fix problem with missing `zlib1.dll` in released Windows binary ([issue #8733](https://github.com/agda/agda/issues/8733))-* Remove commit hash from version number in released binaries ([issue #8716](https://github.com/agda/agda/issues/8716))--* Agda supports GHC versions 8.8.4 to 9.14.1.+Release notes for Agda version 2.9.0+====================================++Highlights+----------++* Option `-j` to type check modules in parallel in batch mode (experimental; Amélia Liao).+* Substantial performance improvements (András Kovács, Amélia Liao, Reed Mullanix).+* Agda on WASM (Jonathan Coates, Andy Pan).+* Qualified `do` (Amélia Liao).+* Local rewrite rules (experimental; Nathaniel Burke, Jesper Cockx).+* Improved termination checker for copatterns (Nate Soares).+* Warning about unused imports (experimental; Andreas Abel).+* Emacs: Syntax highlighting in the Agda information buffer (Andreas Abel, Amélia Liao).+* Improvements to automatic term synthesis, "Mimer" (Andreas Abel, Jesper Cockx).+* Forester backend (Lîm Tsú-thuàn).+* Around 60 fixes of inconsistencies, internal errors, and regressions.+* Around 130 other issues fixed.++Installation+------------++* Dropped support for GHC 8.8, 8.10, and 9.0.++* Agda supports GHC versions 9.2.8 to 9.14.1.++* The new Cabal flag `version-with-git-hash` controls whether version information+ is suffixed with the Git commit hash. It is disabled by default for cabal+ but enabled by default when using the Makefile.++Pragmas and options+-------------------++* New option `--parallel` (`-j` for short, as in `make`) lets Agda+ type-check imported modules in parallel. For large libraries, this can+ result in a speedup of ~3x, at the cost of roughly doubling the+ maximum memory usage.+ This option does not yet work well with `--interaction`+ ([issue #8477](https://github.com/agda/agda/issues/8477)).++* New option `--print-options` to print a simple list of all options.+ This list can e.g. be used to implement bash completion.++* The flavor of Cubical Agda can now be chosen by an argument to the `--cubical` option:++ | Old | New |+ | ---------------------- | ------------------------------------------------- |+ | `--cubical` | `--cubical`, or `--cubical=full` |+ | `--erased-cubical` | `--erased-cubical`, or `--cubical=erased` |+ | `--cubical-compatible` | `--cubical-compatible`, or `--cubical=compatible` |+ | - | `--cubical=no-glue` |++ For compatibility between modules using different variants of Cubical Agda, see+ [the documentation](https://agda.readthedocs.io/en/v2.9.0/language/cubical.html#variants).++* New flag `--no-write-interfaces`.++* New command-line option `--literate-markdown-only-agda-blocks` (off by default).+ When enabled, only code blocks explicitly marked with ` ```agda ` are treated as+ Agda code in literate Markdown (`.lagda.md`) and Typst (`.lagda.typ`) files.+ Unmarked code blocks (` ``` `) are treated as verbatim text and not type-checked.+ This option must be set via command line since it affects parsing.+ (See [#7971](https://github.com/agda/agda/issues/7971).)++* The flag `--termination-depth=N` now means _maximum_ termination depth and+ the termination checker now performs iterative deepening,+ starting with depth `1` and increasing it up to the given `N`, stopping early+ as soon as the termination check succeeds.+ Increasing `N` can thus slow down things only for failing termination checks.++ The default value of `N` has been increased from `1` to `3`, yet not higher,+ because cases requiring a termination depth `> 1` are already very rare in practice.++ There is also an internal change to the termination checker.+ Dot patterns are now taken into account from the beginning and not only when+ the termination check fails without taking them into account.+ The overhead to also mine dot patterns for structural descent was already+ negligible so it made sense to simplify the termination checking algorithm.++* The new flag `--no-occurrence-analysis` can be used to turn off the+ automated occurrence analysis for functions.++ By default Agda analyses how functions use their arguments. For+ instance, Agda can tell that `D` in the following code is strictly+ positive, because `Vec` uses its `Set` argument in a strictly+ positive way:+ ```agda+ open import Agda.Builtin.Nat+ open import Agda.Builtin.Unit++ data _×_ (A B : Set) : Set where+ _,_ : A → B → A × B++ Vec : Set → Nat → Set+ Vec A zero = ⊤+ Vec A (suc n) = A × Vec A n++ data D : Set where+ c : ∀ n → Vec D n → D+ ```+ However, this analysis can be slow, especially for big mutual+ blocks. Now it is possible to turn it off.++ The analysis is also used to detect unused function arguments. The+ following code is by default accepted, but it is rejected if the+ occurrence analysis is turned off:+ ```agda+ open import Agda.Builtin.Bool+ open import Agda.Builtin.Equality+ open import Agda.Builtin.Unit++ F : Bool → Set → Set+ F true _ = Bool+ F false _ = ⊤++ _ : {b : Bool} → F b Bool ≡ F b ⊤+ _ = refl+ ```++ Note that an alternative to the analysis is to use polarities. The+ following code is accepted:+ ```agda+ {-# OPTIONS --polarity --no-occurrence-analysis #-}++ open import Agda.Builtin.Bool+ open import Agda.Builtin.Equality+ open import Agda.Builtin.Nat+ open import Agda.Builtin.Unit++ data _×_ (@++ A B : Set) : Set where+ _,_ : A → B → A × B++ Vec : @++ Set → Nat → Set+ Vec A zero = ⊤+ Vec A (suc n) = A × Vec A n++ data D : Set where+ c : ∀ n → Vec D n → D++ F : Bool → @unused Set → Set+ F true _ = Bool+ F false _ = ⊤++ _ : {b : Bool} → F b Bool ≡ F b ⊤+ _ = refl+ ```++* Setting environment variable `NO_COLOR` now turns off coloring in the default `--color=auto` mode.+ It can be overwritten by `--color=always`.+ See also https://no-color.org/ .++* New option `--quote-metas` to allow for `quoteTerm` constraints to+ be solved even when the quoted term contains unsolved metas.+ This allows for elaborating macro applications with quoted arguments+ that still have interactive holes in them.+ See the [quote metas documentation](https://agda.readthedocs.io/en/v2.9.0/language/reflection.html#quote-metas).++* `{-# NO_POSITIVITY_CHECK #-}` pragmas are now recognized in `record` declarations and `where` blocks,+ and pertain to the following `data` or `record` declaration or mutual block.++* New option `--local-rewriting` which enables parameterising over computation rules by annotating module parameters with `@rewrite` attributes. See the [local rewriting documentation](https://agda.readthedocs.io/en/v2.9.0/language/local-rewriting.html) for more info.++* New `primRewriteNoMatch` primitive in `Agda.Builtin.Equality.Rewrite` for controlling rewrite rule matching. See the section in the [rewriting documentation](https://agda.readthedocs.io/en/v2.9.0/language/rewriting.html#controlling-rewrite-rule-matching-with-primrewritenomatch) for more info.++* The `ETA` pragma has been removed.++* Eta-equality for record types is no longer inferred.+ Previously Agda would switch off eta for a recursive record type automatically+ if there was a risk that the type checker could loop due to infinite eta expansion.+ Now, Agda will only flag it with an `UnguardedEtaRecord` error, so one has to add+ a `no-eta-equality` directive manually.+ If one wants eta enabled nevertheless, one can use the new `ETA_EQUALITY` pragma.+ This pragma replaces the old `ETA` pragma and can also be used to turn on eta for+ `coinductive` record types.+ See the documentation on+ [unguarded records](https://agda.readthedocs.io/en/v2.9.0/language/record-types.html#unguarded-records)+ and [the `ETA_EQUALITY` pragma](https://agda.readthedocs.io/en/v2.9.0/language/coinduction.html#eta-pragma).++* New options `--irrelevance` (default on) and `--no-irrelevance` to allow or+ disallow the irrelevance modality.++* (**BREAKING**.) Now `--erased-matches` takes an optional argument:++ * `--erased-matches=none`: Do not enable any erased matches (this+ can be overridden).++ * `--erased-matches=empty`: Enable erased matches for empty types.++ * `--erased-matches=non-dependent`: Enable erased matches for+ non-indexed, single-constructor types.++ * `--erased-matches=restricted`: Make it possible to import the+ module `Agda.Builtin.Erased.Box-cong`, which contains an+ implementation of `[]-cong` (the type `Erased` can be found in+ `Agda.Builtin.Erased.Erased`):++ ```agda+ record Erased (@0 A : Set a) : Set a where+ no-eta-equality+ constructor [_]+ field+ @0 erased : A++ []-cong : @0 x ≡ y → [ x ] ≡ [ y ]+ []-cong refl = refl+ ```++ In the future `--erased-matches=restricted` might make it possible+ to implement `[]-cong` in user code, but that is currently not+ allowed.++ * `--erased-matches=unrestricted`: Enable unrestricted erased+ matches for single-constructor types. If `--safe` is active, then+ this option is not allowed together with `--without-K`.++ One can also use comma-separated lists of options, for instance+ `--erased-matches=empty,restricted`. This has the same effect as+ giving the options separately (`--erased-matches=empty+ --erased-matches=restricted`). There is no way to turn off something+ that has been enabled, so it does not matter in what order the+ options are given. As an example, `--erased-matches=empty,none`+ means the same thing as `--erased-matches=empty`.++ If none of these options are given, then Agda behaves++ * as if `--erased-matches=none` had been used if `--erasure` is not+ turned on (directly or indirectly), otherwise++ * as if `--erased-matches=empty` had been used if `--without-K` is+ active, and otherwise++ * as if `--erased-matches=empty,unrestricted` had been used.++ Note that these defaults can be overridden by, for instance,+ `--erased-matches=none`.++ The option `--erased-matches` means almost the same thing as+ `--erased-matches=empty,non-dependent` if `--without-K` is active,+ and otherwise it means almost the same thing as+ `--erased-matches=empty,unrestricted`. However, any use of+ `--erased-matches` with explicit arguments takes precedence over+ `--erased-matches` without arguments. For instance,+ `--erased-matches=none --erased-matches` means the same thing as+ `--erased-matches=none`.++ The option `--no-erased-matches` is now a synonym for+ `--erased-matches=none`.++ All variants of `--erased-matches` except for+ `--erased-matches=none` enable `--erasure`.++ This change can lead to some breakage:++ * Previously `--no-erased-matches --erased-matches` meant the same+ thing as `--erased-matches`, now it means the same thing as+ `--erased-matches=none`.++ * Before `--with-K` overrode a previously given+ `--no-erased-matches` and turned on erased matches. That is no+ longer the case.++ Note that the new optional argument to `--erased-matches` is+ experimental: the design might change in the future.++* The new (experimental and possibly unstable) options+ `--erased-funext`, `--erased-propext` and `--erased-quotients`+ enable use of `Agda.Builtin.Erased.Funext`,+ `Agda.Builtin.Erased.Propext` and `Agda.Builtin.Erased.Quotient`,+ respectively.++ All options imply `--erasure`, and `--erased-quotients` implies+ `--erased-funext`.++ These modules contain erased postulates. The idea is that it should+ be safe to use these postulates (under `--safe` and in the absence+ of any Agda bugs):++ * If `--erased-matches=X` is not used, where `X` is one of `empty`,+ `non-dependent`, `restricted` and `unrestricted`, then canonicity+ should hold for non-erased terms (if all opaque definitions are+ made transparent and the context only contains erased+ assumptions).++ * If `--erased-matches=empty` is used, then canonicity should still+ hold if the context plus the postulates are jointly consistent.++ * If `--erased-matches=X` is used, where `X` is one of+ `non-dependent`, `restricted` and `unrestricted`, then reduction+ might get stuck, but compiled programs should still run correctly.++ `Agda.Builtin.Erased.Funext` postulates function extensionality,+ `Agda.Builtin.Erased.Propext` postulates propositional+ extensionality, and `Agda.Builtin.Erased.Quotient` gives access to+ an implementation of set quotients with an eliminator that computes+ for the point constructor.++Errors+------++* Error `ClashingDefinition` now gives the lineage of the previous definition of the same name.+ This helps when it is unclear how this name was imported. Example:+ ```+ error: [ClashingDefinition]+ Multiple definitions of A. Previous definition+ A is in scope as+ * a postulate Imports.A.A brought into scope by+ - the opening of Imports.A at ...+ - its definition at ...+ ```++* Errors `GenericError` and `GenericDocError` have been replaced by more specific errors.+ (Issue [#7225](https://github.com/agda/agda/issues/7225).)++* New error `NamedWhereModuleUnderWith` for named `where`-modules in clauses+ using with-abstraction; see the entry under _Language_.+ (Issue [#8698](https://github.com/agda/agda/issues/8698).)++* Generalisation failures due to unresolvable dependencies between a+ generalized variable and unsolved metavariables have new, specific+ errors.+ * `GeneralizationPrepruneErrorRefinedContext`, reproduced by Amélia Liao+ (see Issue [#8161](https://github.com/agda/agda/issues/8161#issuecomment-3696949816)).+ * `GeneralizationPrepruneErrorCyclicDependencies`, reproduced by Nils Anders Danielsson+ (see Issue [#3672](https://github.com/agda/agda/issues/3672#issuecomment-482715807)).++* New error `WrongNamedArgumentInLHS` for a named hidden argument on a left hand side+ that does not exist, replacing `WrongHidingInLHS` in this case.+ Like `WrongNamedArgument` on the right hand side, it lists the possible argument names+ (see [#8739](https://github.com/agda/agda/issues/8739)).+ Likewise, error `NoParameterOfName` now lists the possible parameter names.++Warnings+--------++* New warning `UnusedImports` when `open` brings identifiers or modules into scope+ that are definitely not used subsequently.+ A module counts as used if it is referred to,+ e.g. in a qualified name `M.x`, in `open M`, or in `module N = M`.++ If `using` or `renaming` directives are given, or in flavor `-WUnusedImports=all`,+ Agda warns about each name and module that is unused,+ except for modules of data and record types that are not mentioned+ explicitly in the directive.+ If no directive or only a `hiding` directive is given,+ and unless the flavor is `all`,+ Agda only warns if none of the imported names are used.++ Agda also warns about instances brought into scope+ unless `--no-qualified-instances` is on+ (which requires bringing instances into scope if they should be found by instance search).++* `UselessImport` warning instead of parse error when an module is instantiated+ but not opened during `import`, for instance:+ ```agda+ import Structures.IsMonoid Carrier Eq+ ```+ This does not bring module `Structures.IsMonoid` into scope and+ neither any of its exports.+ It either needs an `open` or an `as`-clause such as `as MyMonoid`.++* `UselessPragma` warning instead of hard error `NeedOptionRewriting` when a+ `REWRITE` or `BUILTIN REWRITE` pragma is encountered but `--rewriting` is off.++* Error warning `IllegalDeclarationInDataDefinition` instead of hard error+ when `data` definition contains declarations other than type signatures of+ constructors.++* Error `RecursiveRecordNeedsInductivity` turned into a error warning.++* New warning `DivergentModalityInClause` when modality of a clause diverges+ from that of the function. Example:+ ```agda+ A : Set₁+ @0 A = Set+ ```++* New warning `InvalidDataOrRecDefParameter` for information (e.g. type, attributes)+ attached to parameters in a `data` or `record` definition (that is separate of its+ data or record signature).+ This replaces errors:+ - `UnexpectedModalityAnnotationInParameter`+ - `UnexpectedTypeSignatureForParameter`++* New warning `InvalidTacticAttribute` for misplaced `@(tactic ...)` attributes.+ This was silently accepted up to Agda 2.8.0 but raises now the new warning:+ ```agda+ postulate+ @(tactic not-in-scope) _ : Set+ ```++* New warning `RewriteVariablesBoundInSingleton` for rewrite rules which bind+ at least one variable exclusively in patterns which might become of singleton+ type after a substitution. Rewrite rules of this form endanger subject+ reduction.+ - Unlike the other warnings about problematic rewrite rules, Agda will still+ try its best to apply rewrites which trigger this warning.+ This is because some very useful rewrite rules unfortunately do not preserve+ subject reduction in the presence of definitional singletons.++* `UnknownNamesInFixityDecl` and `UnknownNamesInPolarityPragmas` are now error warnings.++* The new warning `DefinitionBeforeDeclaration` is emitted if in a classic+ `mutual` block a data/record signature appears *after* the respective+ definition. This can happen since the nicifier bubbles signatures up.+ (See [issue #8435](https://github.com/agda/agda/issues/8435).)++* New warning `ShouldBeEtaRecordPattern`, raised for+ matches on record constructors in _binders_ (`λ`, `let`, parameter telescopes etc.)+ when the respective record does not have eta.+ For example, this module parameter match triggers the warning:+ ```agda+ record Wrap (A : Set) : Set where+ constructor wrap; no-eta-equality; pattern+ field unwrap : A++ module _ {A} (w@(wrap a) : Wrap A) where+ ```+ Reason for the warning:+ Such a binding is interpreted here as `a = unwrap w`.+ The user expectation that `w` is definitionally equal to `wrap a` is only met if `Wrap` admits `eta-equality`.++ Pattern matching on left hand sides of function definitions does not trigger the warning.++* New warning `FixityDeclarationForNonOperator` when a fixity declaration is attached to a name+ that is neither a pre-, post-, nor infix operator and neither has a pre-, post- or infix `syntax`+ attached to it.+ ```agda+ infixl 10 plus -- warning+ plus : ℕ → ℕ → ℕ+ plus = ...++ infix 42 [_] -- warning+ [_] : A → List A+ [_] = ...++ infix 255 abs+ syntax abs x = | x | -- warning++ infix 314 neg -- no warning+ syntax neg x = ¬ x++ open import Agda.Builtin.Nat+ renaming (_+_ to infixl 10 add) -- warning+ ```++* New warning `LibraryVersionConflict` when a project uses different versions of one library+ (see [#8875](https://github.com/agda/agda/issues/8875)).+ The warning shows the dependency tree leading to the conflicting versions+ and the involved `.agda-lib` files:+ ```+ Different versions of the library 'standard-library' depended on:+ [my-project]+ ├─ [standard-library-2.3]+ └─ [my-lib]+ └─ standard-library-2.4 as [standard-library]+ Library files:+ [my-project]: /path/to/my-project/my-project.agda-lib:<line>.<col>-<col>+ [my-lib]: /path/to/my-lib/my-lib.agda-lib:<line>.<col>-<col>+ [standard-library-2.3]: /path/to/agda-stdlib-2.3/standard-library.agda-lib:1:1+ [standard-library]: /path/to/agda-stdlib-2.4/standard-library.agda-lib:1:1+ ```++Syntax+------++Changes to the Agda syntax.++* **Breaking:** The parser will reject ASCII opening delimiters which+ are closed by a Unicode delimiter, and vice-versa. Concretely, this+ means the mismatched pairs `⦃ ... }}`/`{{ ... ⦄` and+ `⦇ … |)`/`(| … ⦈` are now parse errors.++* Modality annotations in aliases and let-bindings are now supported+ (PR [#7990](https://github.com/agda/agda/pull/7990)).+ Example:+ ```agda+ split : {A B C : Set} (@0 p : A × B) (k : @0 A → @0 B → C) → C+ split p k = let @0 (x , y) = q in k x y+ where+ @0 q = p+ ```++* Postfix projections cannot be surrounded by parentheses anymore.+ E.g. these postfix projection applications are now illegal in expressions:+ ```agda+ r (.proj)+ r .(proj)+ ```++* Idiom brackets and `do` notation may now appear *qualified*, as in+ `M.do` or `M.(| f x y z |)`, in which case the functions needed for+ desugaring these are looked up in `M` rather than in the surrounding+ scope ([PR #8280](https://github.com/agda/agda/pull/8280)).++Language+--------++Changes to type checker and other components defining the Agda language.++* (**BREAKING**) Named `where`-modules (`module M where`) are no longer+ allowed in clauses that use with-abstraction, i.e. clauses with `with`,+ `rewrite`, or `with p ← e`. Such a clause is now rejected with the new+ error `NamedWhereModuleUnderWith`:+ ```agda+ f : Bool → Bool+ f x with x+ ... | true = local+ module M where -- rejected+ local = false+ ... | false = true+ ```+ With-abstraction can change the types of the module parameters that `M`+ inherits from its parent module, so the telescope of `M` lies about them.+ Since `M` is visible outside of the clause, it could then be instantiated+ with ill-typed arguments, which allowed a proof of `⊥`.++ Ordinary anonymous `where`-blocks are unaffected, and so is+ `using p ← e`, which does not with-abstract but introduces a let-binding.+ (Issue [#8698](https://github.com/agda/agda/issues/8698).)++* (**BREAKING**) The pseudo-name `R.constructor`, which refers to the+ constructor of record `R`, is now resolved by the ordinary scope lookup:+ `constructor` is a name bound in the record module `R`.+ (It can never be written unqualified, since `constructor` is a keyword;+ in particular, `open R` does not bring it into scope, and a module+ application `module M = R` does not provide `M.constructor`.)++ Consequently, the qualification `R` in `R.constructor` is now interpreted+ as the name of the record *module* rather than the name of the record+ *type*. Thus, this now succeeds:+ ```agda+ module M where+ record R : Set where++ open M using (module R)++ t = R.constructor -- used to fail+ ```+ while this now fails:+ ```agda+ module M where+ record R : Set where++ open M using (R) hiding (module R)++ t = R.constructor -- used to succeed+ ```++ This also fixes [Issue #8625](https://github.com/agda/agda/issues/8625):+ an internal error when referring to `R.constructor` from the interaction+ top level.++* (**BREAKING**): In the presence of `--erasure`, types of lambdas expressions+ are not inferred unless every lambda-bound variable has been given its erasure+ status (`@0` or `@ω`) explicitely.+ The reason is that otherwise Agda might infer the wrong erasure status, see, e.g.,+ [Issue #7001](https://github.com/agda/agda/issues/7001).++ Now we have the following behavior:+ ```agda+ fails = λ x → x + x+ succeeds = λ (@ω x) → x + x+ alsoOK = λ (@ω A : Set) (@0 B : Set) → A+ ```+ With that change `--erasure` gets more akin to Cubical Agda that categorically+ refuses to infer lambdas (since they could construct either functions or paths).++* (**BREAKING**): Instance search will no longer eta-expand non-instance+ (visible and hidden) variables of record type in the context to find+ instance fields ([PR #8367](https://github.com/agda/agda/pull/8367)).++ This change means that instance search can now happen even when the types of+ non-instance arguments are yet-unsolved metavariables. Specifically, instance+ search now works in functions with a type signature of the form `∀ x → ...`,+ where previously it would require the type of `x` to be annotated.++ It also means that instance search no longer requires head-normalising the+ types of non-instance function arguments, which may have a positive effect on+ type checking performance.++ Due to this change, code that relied on eta-expanding visible argument (like+ `r : R` in the example below) to find the instance field will no longer work.++ ```agda+ postulate+ T : Set+ use : ⦃ t : T ⦄ → Set++ record R : Set where+ field ⦃ inst ⦄ : T++ fails : R → Set+ fails r = use+ ```++ In this case the code can be repaired by explicitly eta-expanding the record+ pattern:++ ```agda+ succeeds : R → Set+ succeeds r@record{} = use -- or just record{}, if r is unused+ ```++ In other cases more substantial changes might be required. For example, in the+ code below the record values `Aa` and `Bb` are parameters so they cannot be+ eta-expanded directly:++ ```agda+ record IsPointed (A : Set) : Set where+ field+ point : A+ open IsPointed {{...}}++ record PointedSet : Set1 where+ field+ Carrier : Set+ {{IsPointed[Carrier]}} : IsPointed Carrier+ open PointedSet++ record PointedFunction (Aa Bb : PointedSet) : Set where+ field+ run : Aa .Carrier -> Bb .Carrier+ preserves-point : run point ≡ point+ ```++ Here it is possible to work around the problem by marking the projection+ `IsPointed[Carrier]` as an `instance` and then applying the record module+ `PointedSet` to the respective values `Aa` and `Bb`:++ ```agda+ record PointedSet : Set1 where+ field+ Carrier : Set+ instance+ {{IsPointed[Carrier]}} : IsPointed Carrier+ open PointedSet++ record PointedFunction (Aa Bb : PointedSet) : Set where+ open PointedSet Aa renaming (Carrier to AA)+ open PointedSet Bb renaming (Carrier to BB)+ field+ run : AA -> BB+ preserves-point : run point ≡ point+ ```++ In general, instance search is intended to work well with unbundled structures+ such as `IsPointed`, while using it with bundled structures such as+ `PointedSet` might require some more creative workarounds such as the one+ above.++* Instance search now finds instance fields in *functions* that produce+ eta records ([Issue #8337](github.com/agda/agda/issues/8337)), as+ long as these functions are in the context with instance visibility.++ In effect, this means that a family of instances of a "subclass" also+ provides a family of instances for the "superclass". For example, the+ following code is now accepted:++ ```agda+ record Eq (A : Set) : Set where+ field+ _==_ : A → A → Bool++ record Ord (A : Set) : Set where+ field+ ⦃ eq ⦄ : Eq A+ _<=_ : A → A → Bool++ open Ord ⦃ ... ⦄+ open Eq ⦃ ... ⦄++ test+ : {I : Set} {F : I → Set} ⦃ ordi : ∀ {i} → Ord (F i) ⦄+ → (i : I) → F i → F i → Bool+ test i x y = x == y+ ```++* Functions defined using with-abstraction equality (`with … in eq`) can now be+ reasoned about using the same with-abstraction equality: the equality proof+ is correctly generalised over. This should make most (if not all) uses of the+ old-style `inspect` idioms for the built-in equality type unnecessary.++* Added support for [Cubical Agda without Glue Types](https://agda.readthedocs.io/en/v2.9.0/language/cubical.html#cubical-agda-without-glue)+ by using the flag `--cubical=no-glue`,+ a variant of Cubical Agda which disables the Glue types.+ For compatibility with modules using `--cubical[=full]` and `--cubical=erased`, see+ [variants](https://agda.readthedocs.io/en/v2.9.0/language/cubical.html#variants).++* Added the [Sharp modality](https://agda.readthedocs.io/en/v2.9.0/language/flat.html#the-sharp-modality),+ which adds a right adjoint to the existing flat modality enabled via the+ `--cohesion` flag. This also enables the use of attributes in record+ fields for any cohesion modality which has a left adjoint (currently+ just sharp and continuous).++Builtins+--------++* (**BREAKING**): The fixity declarations for `Agda.Builtin.Int.pos` and for+ `primINeg`, `primIMin`, and `primIMax`, in `Agda.Primitive.Cubical` have been removed.+ Reason: they trigger the new warning `FixityDeclarationForNonOperator`.+ If you want to use these builtins as operators, supply a fixity in the `renaming` directive, e.g.:+ ```agda+ open import Agda.Builtin.Int renaming (pos to infix 8 +_)+ open import Agda.Primitive.Cubical renaming+ ( primINeg to infix 30 ~_+ ; primIMin to infixr 20 _∧_+ ; primIMax to infixr 20 _∨_+ )+ ```++Reflection+----------++* `tcTypeError` now throws `UserError` instead of `GenericDocError`.++* Tactic arguments (`@tactic`) are now supported in module telescopes.++* `unquoteDecl` and `unquoteDef` now check that the meta-program+ actually defines all the given identifiers+ (issue [#8851](https://github.com/agda/agda/issues/8851)).++Library management+------------------++* Suppport for version-specific `defaults` files: a file whose name is+ of the form `defaults-X.Y.Z` will take precedence over the standard+ `defaults` one for the `X.Y.Z` version of the compiler. This can be+ used to have default libraries that are only compatible with a given+ version of the compiler.++Interaction and emacs mode+--------------------------++* The JSON interaction protocol (`--interaction-json`) no longer loses+ information that the Emacs frontend displays:++ - `GoalAndHave` responses now include a `boundary` field with the+ boundary faces of the checked expression+ ("Boundary (actual)" in the Emacs mode).++ - `NormalForm` and `InferredType` responses now pretty-print the+ expression in the command state captured when the command ran, as+ the Emacs frontend does, instead of in the current state+ (fixes [Issue #5665](https://github.com/agda/agda/issues/5665)).++ - `Mimer` responses now include the `interactionPoint` the solution+ refers to.++* Proof search (Mimer, `C-c C-a` in Emacs) now also uses functions+ defined in the same `mutual` block as the function being defined,+ without having to give them as hints.+ As for recursive calls to the function itself, they are only applied+ to structurally smaller arguments+ (Issue [#8783](https://github.com/agda/agda/issues/8783)).++* Syntax highlighting and go-to-definition now also works in the Agda+ information and debug buffers in Emacs where goals etc. are displayed.+ This fixes long-standing [Issue #706](https://github.com/agda/agda/issues/706).++* By temporarily turning on printing of hidden arguments+ (`OPTION --show-implicit`, `C-c C-x C-h` in Emacs)+ and then splitting on result in a hole+ (`C-c C-c RET` in Emacs, the whole sequence being `C-c C-x C-h C-c C-c RET`),+ hidden arguments can be introduced in the left hand side of a clause.+ In the presence of generalized variables, this used to introduce unparsable names.+ For instance:+ ```agda+ variable+ l : Level+ A : Set l++ id : A → A+ id = {!!}+ ```+ Here, `id {A.l} {A} x = ?` was produced, triggering an error.+ Now, the correct `id {A = A} x = ?` is produced+ (Issue [#8153](https://github.com/agda/agda/issue/8153)).++* The implicit (hidden and instance) fields of a record pattern are+ no longer printed by default.+ They are only printed with option `--show-implicit`+ (`C-c C-x C-h` in Emacs), or if the user wrote them in the first place.+ For instance, case splitting on `x` in+ ```agda+ record R : Set where+ field+ {n} : Nat+ rf : n ≡ n++ f : R → Set+ f x = {!x!} -- C-c C-c x+ ```+ now produces `f record { rf = rf } = ?` instead of+ `f record { n = n ; rf = rf } = ?`.+ This conforms the treatment of record patterns to the+ situation where the record type has a constructor, in which case the+ hidden arguments were already omitted+ (Issue [#8787](https://github.com/agda/agda/issue/8787)).++* Catch-all copattern clauses are now tolerated as unreachable clauses+ rather than being outright rejected with a `CosplitCatchall` error.+ They can be used as jumpboard for further result splitting.+ (A scenario is a record type that got extended with new fields,+ and definitions producing record values need to be extended as well.)+ Example:+ ```agda+ test : Σ A B+ test .fst = a+ test = {!!} -- C-c C-c RET+ ```+ This split produces the clause `test .snd = ?`.+ (Issue [#8139](https://github.com/agda/agda/issue/8139)).+++* A normalization level can now also passed to command `Cmd_constraints`+ ("show constraints", `C-c C-=` in Emacs).+ In Emacs, the normalization level is given as usual by `C-u` prefixes.++ This interface change is **breaking** for frontends to `agda --interaction`+ such as the VSCode `agda-mode`, which need updating.++* Fixed an internal error in `Cmd_helper_function` (`C-c C-h` in Emacs)+ (Issue [#8103](https://github.com/agda/agda/issue/8103)).+ Changed the type of `Goal_HelperFunction` which might be **breaking**+ 3rd-party interaction frontends.++* `NON_TERMINATING` functions now only reduce in `IgnoreAbstract` mode of+ commands `Cmd_compute(_toplevel)` (`C-u C-c C-n` in Emacs)+ regardless of whether invoked at toplevel or in a hole+ (Issue [#2410](https://github.com/agda/agda/issue/2410)).++* _Go-to-definition_ (`M-.`) is now implemented using Emacs' built-in+ [Xref]. Basic usage stays the same (`M-.` or using the mouse), but+ now also includes searching for definitions by exact (`C-u M-.`) or+ approximate names (`C-M-.`) and listing references (`M-?`) in loaded+ files.++[Xref]: https://www.gnu.org/software/emacs/manual/html_node/emacs/Xref.html++Backends+--------++* `agda --html --html-highlight=code example.lagda.tree` now produces+ `html/example.tree`, which Forester can consume directly;+ no external tools needed.++* New option `--ghc-trace` for GHC Backend to instrument code+ such that the Agda name of the function is printed to `stderr`+ whenever a function is entered.++* The JS backend now explicitly lists all primitives that should compile+ to `undefined`. Primitives not in this list or the RTS trigger a new+ `UnknownJSPrimitive` warning+ (see [#8352](https://github.com/agda/agda/issues/8352)).++* The JS backend's CJS & AMD module styles are now deprecated.+ Please use ES6 module style instead (`--js-es6`).++* The JS backend now compiles constructors to string-tagged arrays.+ This change is **breaking** for hand-written JS code relying on the previous Scott-Encoding.+ Constructors for types with `COMPILE JS` pragmas are not affected.+ (see [#8720](https://github.com/agda/agda/pull/8720))++Issues closed+-------------++For 2.9.0, the following issues were+[closed](https://github.com/agda/agda/issues?q=is%3Aissue+milestone%3A2.9.0+is%3Aclosed)+(see [bug tracker](https://github.com/agda/agda/issues)):++### Consistency issues++- [Issue #7892](https://github.com/agda/agda/issues/7892): The telescope of a projection need not be the telescope of the record type+- [Issue #8341](https://github.com/agda/agda/issues/8341): Postulates in safe mode (regression in 2.8.0)+- [Issue #8453](https://github.com/agda/agda/issues/8453): False because the `SIGMA` builtin accepts types that are not Σ-types+- [Issue #8557](https://github.com/agda/agda/issues/8557): Proof of global choice and of false+- [Issue #8564](https://github.com/agda/agda/issues/8564): Function call tricks positivity checker+- [Issue #8565](https://github.com/agda/agda/issues/8565): Positivity bug with builtins+- [Issue #8587](https://github.com/agda/agda/issues/8587): Endpoints of paths are not checked without `--cubical`+- [Issue #8683](https://github.com/agda/agda/issues/8683): Cubical primitive side conditions are not checked when an application is inferred+- [Issue #8686](https://github.com/agda/agda/issues/8686): Projection-likeness drops arguments the principal argument's type does not determine+- [Issue #8687](https://github.com/agda/agda/issues/8687): The coverage checker infers missing clauses under the wrong module-parameter substitution+- [Issue #8688](https://github.com/agda/agda/issues/8688): Occurrence analysis ignores sorts: a Level argument used only in Set l is Nonvariant, giving universe resizing+- [Issue #8694](https://github.com/agda/agda/issues/8694): The unifier's cycle check looks inside irrelevant and Prop-typed constructor arguments+- [Issue #8695](https://github.com/agda/agda/issues/8695): The unifier's cycle rule checks only the head constructor for higher inductive types+- [Issue #8696](https://github.com/agda/agda/issues/8696): Data/record types copied by a module application inside a block get their arguments marked unused+- [Issue #8697](https://github.com/agda/agda/issues/8697): Interface serialiser conflates the Float literals 0.0 and -0.0+- [Issue #8698](https://github.com/agda/agda/issues/8698): Inconsistency with named `where` modules under `with` (regression in 2.5.2)+- [Issue #8699](https://github.com/agda/agda/issues/8699): Termination checker descends into irrelevant constructor arguments of dot patterns+- [Issue #8700](https://github.com/agda/agda/issues/8700): Clause-based matcher treats a MissingClauses-stuck argument as a definite mismatch (regression in 2.6.3)+- [Issue #8703](https://github.com/agda/agda/issues/8703): Clause-based reduction skips underapplied clauses, reducing differently than after compilation to case-trees+- [Issue #8704](https://github.com/agda/agda/issues/8704): Clause-based reduction falls through on a stuck lazy (forced) match, disagreeing with the case tree (regression in 2.7.0)+- [Issue #8834](https://github.com/agda/agda/issues/8834): Escape from sharp modality / negativity++### Internal errors++- [Issue #3123](https://github.com/agda/agda/issues/3123): Malformed projection definition+- [Issue #6173](https://github.com/agda/agda/issues/6173): Internal error at Agda/Syntax/Abstract/Name.hs:150:44 (regression in 2.6.2)+- [Issue #6770](https://github.com/agda/agda/issues/6770): Incorrect substitution when opening parameterised module with a generalised variable.+- [Issue #7564](https://github.com/agda/agda/issues/7564): Internal error when giving the unit type in a function on HITs+- [Issue #7629](https://github.com/agda/agda/issues/7629): Internal error with src/full/Agda/TypeChecking/Substitute.hs:140:33 using Cubical Agda+- [Issue #7964](https://github.com/agda/agda/issues/7964): Synthesis fails when given hint from a module opened as an instance+- [Issue #8068](https://github.com/agda/agda/issues/8068): `__IMPOSSIBLE__` on dependent pattern match + unrelated holes+- [Issue #8097](https://github.com/agda/agda/issues/8097): Internal error when trying Automatic Proof Search (regression in 2.8.0)+- [Issue #8103](https://github.com/agda/agda/issues/8103): Internal error when trying C-c C-h (helper function)+- [Issue #8215](https://github.com/agda/agda/issues/8215): Internal error triggered by instance declaration within record (regression in 2.8.0)+- [Issue #8263](https://github.com/agda/agda/issues/8263): Internal error in ProjectionLike.hs (regression in 2.6.4)+- [Issue #8298](https://github.com/agda/agda/issues/8298): `__IMPOSSIBLE__` for incomplete mixfix copattern definition in let binding (regression in 2.8.0)+- [Issue #8325](https://github.com/agda/agda/issues/8325): An internal error during refining (src/full/Agda/TypeChecking/Monad/Context.hs:672:26) (regression in 2.8.0)+- [Issue #8336](https://github.com/agda/agda/issues/8336): Internal error in double checker with projection-like functions (Non-exhaustive patterns in Just n) (regression in 2.6.4)+- [Issue #8365](https://github.com/agda/agda/issues/8365): Crash with `--rewriting` flag+- [Issue #8514](https://github.com/agda/agda/issues/8514): `__IMPOSSIBLE__` involving local rewrite rule and a with abstraction+- [Issue #8521](https://github.com/agda/agda/issues/8521): `__IMPOSSIBLE__` when pattern matching against irrelevant instance argument? (regression in 2.6.2)+- [Issue #8532](https://github.com/agda/agda/issues/8532): Missing in reduce in anti-unification causes `__IMPOSSIBLE__` in `TypeChecking/Reduce/Fast.hs:1417:43` (regression in 2.5.3)+- [Issue #8545](https://github.com/agda/agda/issues/8545): Internal error with instance and open-public in record (regression in 2.5.2)+- [Issue #8554](https://github.com/agda/agda/issues/8554): `__IMPOSSIBLE__` in Agda.TypeChecking.MetaVars triggered interactively+- [Issue #8577](https://github.com/agda/agda/issues/8577): IMPOSSIBLE during pattern matching in the presence of a local rewrite rule+- [Issue #8580](https://github.com/agda/agda/issues/8580): Unused implicit parameter in pattern synonym `__IMPOSSIBLE__`+- [Issue #8581](https://github.com/agda/agda/issues/8581): Internal error in TypeChecking/Monad/Context.hs when trying to load/type-check a malformed lambda parameter pattern inside an interaction hole+- [Issue #8621](https://github.com/agda/agda/issues/8621): Internal error (maybe related to instance arguments?) (regression in 2.8.0)+- [Issue #8625](https://github.com/agda/agda/issues/8625): agda2-infer-type-maybe-toplevel on anonymous record constructor causes an internal error+- [Issue #8626](https://github.com/agda/agda/issues/8626): `__IMPOSSIBLE__` at `Agda/TypeChecking/CompiledClause/Compile.hs`:180:20+- [Issue #8634](https://github.com/agda/agda/issues/8634): In Emacs, unknown `.agda-lib` field triggers `__IMPOSSIBLE__` at `Agda.TypeChecking.Serialise.Instances.Common`:101:34 (regression in 2.8.0)+- [Issue #8636](https://github.com/agda/agda/issues/8636): Internal error when an instance value is used as an index+- [Issue #8649](https://github.com/agda/agda/issues/8649): Internal error in confluence checker with rewrite rule for coinductive record projection+- [Issue #8680](https://github.com/agda/agda/issues/8680): Impossible state when unused pattern argument is also a variable declaration+- [Issue #8777](https://github.com/agda/agda/issues/8777): Crash due to unsound call to `canonicalName`+- [Issue #8808](https://github.com/agda/agda/issues/8808): Internal error during cubical boundary recovery+- [Issue #8851](https://github.com/agda/agda/issues/8851): `unquoteDecl` panics when the macro does not `declareDef` at all+- [Issue #8853](https://github.com/agda/agda/issues/8853): Internal error when using `withReconstructed`+- [Issue #8888](https://github.com/agda/agda/issues/8888): `__IMPOSSIBLE__` reached with `--flat-split` and `--double-check`++### Other regressions++- [Issue #3054](https://github.com/agda/agda/issues/3054): Reduction missing during LHS checking (regression in 2.6.0)+- [Issue #4150](https://github.com/agda/agda/issues/4150): Not in scope error instead of missing type signature error (regression in 2.5.4)+- [Issue #7595](https://github.com/agda/agda/issues/7595): `with` compiles 40x slower than `case_of_` (regression in 2.6.4.2)+- [Issue #8094](https://github.com/agda/agda/issues/8094): Backends that are enabled by default can no longer print help (regression in 2.8.0)+- [Issue #8096](https://github.com/agda/agda/issues/8096): Performance regression for test/Succeed/Issue6097-5 (regression in 2.6.4)+- [Issue #8150](https://github.com/agda/agda/issues/8150): Generate helper function reorders arguments (regression in 2.6.1, regression in 2.6.4)+- [Issue #8168](https://github.com/agda/agda/issues/8168): Mimer triggers a ParseError (regression in 2.8.0)+- [Issue #8300](https://github.com/agda/agda/issues/8300): Instanceness of principal argument dropped by postfix projection (regression in 2.6.0)+- [Issue #8435](https://github.com/agda/agda/issues/8435): In `mutual` blocks `data`/`record` signatures can be given after their definition (regression in 2.6.0)+- [Issue #8559](https://github.com/agda/agda/issues/8559): Copattern definition gives UnequalTerms for equal terms (regression in 2.6.0)+- [Issue #8771](https://github.com/agda/agda/issues/8771): Regression in 2.6.4 with `--projection-like` (regression in 2.6.4)+- [Issue #8811](https://github.com/agda/agda/issues/8811): Can't give: `metaOccurs` check too strict with `--prop`, `--polarity`, or `--experimental-irrelevance` (regression in 2.6.2)++### Other issues++- [Issue #706](https://github.com/agda/agda/issues/706): syntax highlighting and definition location etc. for definitions in goal/error buffer+- [Issue #1120](https://github.com/agda/agda/issues/1120): Improve operator parsing performance+- [Issue #1680](https://github.com/agda/agda/issues/1680): Simple termination checking fails with --without-K+- [Issue #2369](https://github.com/agda/agda/issues/2369): “Module cannot be imported since it has open interaction points” should always point to module+- [Issue #2410](https://github.com/agda/agda/issues/2410): `C-c C-n` unfolds non-terminating functions+- [Issue #2503](https://github.com/agda/agda/issues/2503): On warning about redundant imports+- [Issue #2591](https://github.com/agda/agda/issues/2591): Operator parse error should be scope error+- [Issue #2636](https://github.com/agda/agda/issues/2636): The positivity checker complains when a new definition is added in the same where clause+- [Issue #3218](https://github.com/agda/agda/issues/3218): termination checking failure in copattern-style definition+- [Issue #3355](https://github.com/agda/agda/issues/3355): NO_POSITIVITY_CHECK pragma ignored in local `where` block+- [Issue #3677](https://github.com/agda/agda/issues/3677): Operator parse error should include "nullary operators"+- [Issue #4228](https://github.com/agda/agda/issues/4228): Wrong context for solved interaction point in generalized type+- [Issue #4271](https://github.com/agda/agda/issues/4271): Make module names into links in error messages+- [Issue #4339](https://github.com/agda/agda/issues/4339): Qualified `do` (Resolving the monad instance for `do` notation)+- [Issue #5305](https://github.com/agda/agda/issues/5305): Generalisation fails with --no-syntactic-equality+- [Issue #5411](https://github.com/agda/agda/issues/5411): `open` in module telescope goes wrong with generalization+- [Issue #5524](https://github.com/agda/agda/issues/5524): duplicate identifiers ignored in fixity declarations+- [Issue #5618](https://github.com/agda/agda/issues/5618): More precise wording of warning "Instance applies only to declarations that introduce new identifiers"+- [Issue #5665](https://github.com/agda/agda/issues/5665): agda --interaction-json gives unnecessarily qualified names after opening modules+- [Issue #5670](https://github.com/agda/agda/issues/5670): OperatorsExpr parsing blows up on large file+- [Issue #5791](https://github.com/agda/agda/issues/5791): Error message only mentions .agda and .lagda+- [Issue #5808](https://github.com/agda/agda/issues/5808): --interaction-json: interaction points with empty ranges after refine+- [Issue #5836](https://github.com/agda/agda/issues/5836): JSON interaction doesn't give ranges for newly refined goals+- [Issue #5839](https://github.com/agda/agda/issues/5839): Incorrect usage of underscore in names breaks parsing+- [Issue #6198](https://github.com/agda/agda/issues/6198): Canonicity failure with --cubical (?)+- [Issue #6240](https://github.com/agda/agda/issues/6240): Weird type generated for record field opened in telescope with generalized variable+- [Issue #6425](https://github.com/agda/agda/issues/6425): Not-in-scope constructors make patterns parse-failed+- [Issue #6825](https://github.com/agda/agda/issues/6825): Irrefutable matching in binders does not deliver expected results for non-eta patterns+- [Issue #6847](https://github.com/agda/agda/issues/6847): On dropping GHC versions 9.0 and lower+- [Issue #6861](https://github.com/agda/agda/issues/6861): Parallelize build+- [Issue #6939](https://github.com/agda/agda/issues/6939): Non-dependent tactic argument fails to run tactic+- [Issue #6940](https://github.com/agda/agda/issues/6940): Add flag to direct output of GHC backend+- [Issue #7001](https://github.com/agda/agda/issues/7001): Agda treats lambdas that are not annotated with `@ω` as non-erased+- [Issue #7139](https://github.com/agda/agda/issues/7139): Mangled trX/Con clause for indexed type with green slime+- [Issue #7225](https://github.com/agda/agda/issues/7225): Named errors instead of Generic[Doc]Error+- [Issue #7562](https://github.com/agda/agda/issues/7562): The script `install_agda_user.bat` for Windows uses the dangerous `setx` command+- [Issue #7664](https://github.com/agda/agda/issues/7664): Agda ignores constructor parameters but only if they're copied under a parameterised module+- [Issue #7691](https://github.com/agda/agda/issues/7691): Custom treeless pipeline is ignored for "recursive" calls+- [Issue #7805](https://github.com/agda/agda/issues/7805): Inscrutable error with `record where` + implicit arguments+- [Issue #7829](https://github.com/agda/agda/issues/7829): Fields with signature not highlighted in `record where`+- [Issue #7836](https://github.com/agda/agda/issues/7836): `record where` silently ignores postulated field values+- [Issue #7837](https://github.com/agda/agda/issues/7837): `record where` handles duplicate names in open directive in non-standard way+- [Issue #7838](https://github.com/agda/agda/issues/7838): `record where`'s interpretation of `open` is very syntactic+- [Issue #7876](https://github.com/agda/agda/issues/7876): Internal error with `--rewriting` and dependent identity type+- [Issue #7893](https://github.com/agda/agda/issues/7893): Confluence check misses critical pair+- [Issue #7906](https://github.com/agda/agda/issues/7906): Manually eta-expanding clause makes termination checking fail+- [Issue #7941](https://github.com/agda/agda/issues/7941): Denial of case split in the presence of known values+- [Issue #7968](https://github.com/agda/agda/issues/7968): Undefined `Char`-related primitives when compiled to JS+- [Issue #7972](https://github.com/agda/agda/issues/7972): Mimer has problems instantiating predicates+- [Issue #7976](https://github.com/agda/agda/issues/7976): Soft error for `{-# REWRITE ... #-}` without `--rewriting`+- [Issue #7987](https://github.com/agda/agda/issues/7987): Allow erased `let`s+- [Issue #7988](https://github.com/agda/agda/issues/7988): Declarations before top-level module in a library give wrong error message+- [Issue #7989](https://github.com/agda/agda/issues/7989): Weird error for irrelevant clause+- [Issue #7994](https://github.com/agda/agda/issues/7994): `tactic` attributes at declarations are parsed, then silently dropped+- [Issue #7998](https://github.com/agda/agda/issues/7998): `instance` silently dropped from `primitive` and `variable` blocks+- [Issue #8016](https://github.com/agda/agda/issues/8016): Nix build fails on aarch64-darwin+- [Issue #8033](https://github.com/agda/agda/issues/8033): Coloring lost in warnings+- [Issue #8035](https://github.com/agda/agda/issues/8035): Optimising module copying+- [Issue #8037](https://github.com/agda/agda/issues/8037): checkParameters is defeated by not copying the record+- [Issue #8048](https://github.com/agda/agda/issues/8048): Guarded Cubical: Using instance arguments for tick variables enables proving join+- [Issue #8074](https://github.com/agda/agda/issues/8074): GHC 9.14+- [Issue #8078](https://github.com/agda/agda/issues/8078): piSort case of documentation+- [Issue #8080](https://github.com/agda/agda/issues/8080): std-lib-test spends ~5% of runtime rendering warnings that are never displayed+- [Issue #8092](https://github.com/agda/agda/issues/8092): COMPILE pragmas on declared-but-not-yet-defined symbols are discarded+- [Issue #8098](https://github.com/agda/agda/issues/8098): Agda deletes read-only interface files+- [Issue #8100](https://github.com/agda/agda/issues/8100): Non-normalized level printed for interactive "show constraints" and "solve"+- [Issue #8105](https://github.com/agda/agda/issues/8105): For ClashingDefinition also highlight the first definition+- [Issue #8112](https://github.com/agda/agda/issues/8112): Can not eliminate [type blocked on meta] forces very silly extended lambdas+- [Issue #8126](https://github.com/agda/agda/issues/8126): Generalizable `variable`s presented as projections in error message+- [Issue #8128](https://github.com/agda/agda/issues/8128): Poor error for duplicate definition in mutual block+- [Issue #8132](https://github.com/agda/agda/issues/8132): Error SolvedButOpenHoles should provide means to jump to module with open goals+- [Issue #8134](https://github.com/agda/agda/issues/8134): Caching is broken+- [Issue #8139](https://github.com/agda/agda/issues/8139): Fail soft on catch-all for copatterns+- [Issue #8144](https://github.com/agda/agda/issues/8144): Improve error message when trying to open record in a mutual block+- [Issue #8153](https://github.com/agda/agda/issues/8153): Result splitting should not introduce indirectly generalized variables+- [Issue #8157](https://github.com/agda/agda/issues/8157): Case split makes instance clause vanish+- [Issue #8170](https://github.com/agda/agda/issues/8170): Increase `--termination-depth` to 2 or infinity+- [Issue #8171](https://github.com/agda/agda/issues/8171): "Failed to give" with `--polarity`+- [Issue #8191](https://github.com/agda/agda/issues/8191): [ question/bug ] are infix names allowed for parametrised modules?+- [Issue #8206](https://github.com/agda/agda/issues/8206): `interleaved mutual` does not check consistency of parameters (hiding / typing)+- [Issue #8218](https://github.com/agda/agda/issues/8218): Unequal terms despite rewrite rule (across modules)+- [Issue #8228](https://github.com/agda/agda/issues/8228): Parse Error with Display Pragma and Mixfix Operator+- [Issue #8231](https://github.com/agda/agda/issues/8231): Rewrite rule matching does not respect irrelevance+- [Issue #8249](https://github.com/agda/agda/issues/8249): Literate Markdown: Option to only treat `agda`-code blocks as agda code+- [Issue #8256](https://github.com/agda/agda/issues/8256): `M-.` does not work in the information buffer+- [Issue #8269](https://github.com/agda/agda/issues/8269): Documentation: Is ETA for Colists Safe?+- [Issue #8273](https://github.com/agda/agda/issues/8273): Confluence Checking Error After Reloading File/Importing+- [Issue #8281](https://github.com/agda/agda/issues/8281): Literate programming Forester potential improvement+- [Issue #8308](https://github.com/agda/agda/issues/8308): Support turning off colored output via `NO_COLOR` environment variable+- [Issue #8312](https://github.com/agda/agda/issues/8312): `with … in` functions cannot reason about themselves+- [Issue #8326](https://github.com/agda/agda/issues/8326): Importing file with --cubical reports error about --two-level+- [Issue #8327](https://github.com/agda/agda/issues/8327): Splitting on a prop in between record fields fails with `SplitInProp` error+- [Issue #8337](https://github.com/agda/agda/issues/8337): Agda instance search cannot find nested instances+- [Issue #8344](https://github.com/agda/agda/issues/8344): C-c C-, shows a binding that is not there+- [Issue #8352](https://github.com/agda/agda/issues/8352): JS backend: unknown primitives silently compiled to Undefined+- [Issue #8370](https://github.com/agda/agda/issues/8370): Putting a `pattern` `record` in an index kills canonicity for cubical+- [Issue #8374](https://github.com/agda/agda/issues/8374): Allow fixity decls for anonymous modules outside module+- [Issue #8380](https://github.com/agda/agda/issues/8380): Weird behavior with comment parsing+- [Issue #8388](https://github.com/agda/agda/issues/8388): `in` suggests to use no longer used {-# BUILTIN REFL name #-}+- [Issue #8398](https://github.com/agda/agda/issues/8398): JS backend: use tagged arrays instead of Scott encoding for data types+- [Issue #8400](https://github.com/agda/agda/issues/8400): No error highlighting for InstanceWithExplicitArg+- [Issue #8402](https://github.com/agda/agda/issues/8402): LaTeX backend uses unknown command`\AgdaDeadcode`+- [Issue #8420](https://github.com/agda/agda/issues/8420): Direct support for `[]-cong`+- [Issue #8431](https://github.com/agda/agda/issues/8431): Error RecursiveRecordNeedsInductivity switched off by NO_POSITIVITY_CHECK+- [Issue #8440](https://github.com/agda/agda/issues/8440): Cubical Agda prints `IsOne (A ∨ ~ A)` in an error where `A : Set`+- [Issue #8478](https://github.com/agda/agda/issues/8478): Lines/second in profiling output+- [Issue #8479](https://github.com/agda/agda/issues/8479): Agda.Interaction.InteractionTop highlights the fatal import in the wrong buffer+- [Issue #8494](https://github.com/agda/agda/issues/8494): Emacs mode gets confused on goal position with certain strings+- [Issue #8495](https://github.com/agda/agda/issues/8495): Emacs goals are non-interactive in literate forester files+- [Issue #8519](https://github.com/agda/agda/issues/8519): Rewrite rule does not apply after doing a path abstraction on LHS+- [Issue #8526](https://github.com/agda/agda/issues/8526): ETA pragma silently does nothing for imported (coinductive) records+- [Issue #8529](https://github.com/agda/agda/issues/8529): Bug (cut-and-paste error) allows NO_UNIVERSE_CHECK to attach to mutual blocks+- [Issue #8570](https://github.com/agda/agda/issues/8570): Meta-variable instantiated with ill-resourced type+- [Issue #8583](https://github.com/agda/agda/issues/8583): (Co)InfectiveImport error should provide jumpable link to imported module+- [Issue #8591](https://github.com/agda/agda/issues/8591): Quotient types, erased function and propositional extensionality+- [Issue #8596](https://github.com/agda/agda/issues/8596): Termination checker rejects program when field takes 2 or 4 (but not 0, 1, 3, 5, or 6) trivial ⊤ arguments+- [Issue #8599](https://github.com/agda/agda/issues/8599): [ with ] nested irrefutable `with`s cause a parse error!?+- [Issue #8638](https://github.com/agda/agda/issues/8638): GHC backend erases patterns on datatypes indexed by erased datatypes+- [Issue #8639](https://github.com/agda/agda/issues/8639): JS backend mis-compiles list cons (`_∷_`)+- [Issue #8647](https://github.com/agda/agda/issues/8647): FOREIGN GHC pragma changes lost by caching+- [Issue #8666](https://github.com/agda/agda/issues/8666): Make `--irrelevance` infective+- [Issue #8710](https://github.com/agda/agda/issues/8710): The second imported rewriting relation is ignored+- [Issue #8739](https://github.com/agda/agda/issues/8739): Error "unexpected implicit argument" should print the available implicit arguments+- [Issue #8759](https://github.com/agda/agda/issues/8759): Crashes due to missing cases in strict bindings+- [Issue #8767](https://github.com/agda/agda/issues/8767): The strict GHC backend generates slow code+- [Issue #8783](https://github.com/agda/agda/issues/8783): Mimer (C-c C-a) does not automatically use mutually defined functions+- [Issue #8787](https://github.com/agda/agda/issues/8787): Case splitting producing `record` patterns does not omit the implicit fields+- [Issue #8815](https://github.com/agda/agda/issues/8815): Mimer rejects candidate if it generates constraints it would solve in the next step+- [Issue #8828](https://github.com/agda/agda/issues/8828): Meta solutions leak from abstract and opaque blocks+- [Issue #8830](https://github.com/agda/agda/issues/8830): Instance resolution should not ignore available instances+- [Issue #8841](https://github.com/agda/agda/issues/8841): Support Emacs 31+- [Issue #8847](https://github.com/agda/agda/issues/8847): Instance search does not find unquoted definitions in instance blocks+- [Issue #8858](https://github.com/agda/agda/issues/8858): `Cmd_highlight` after Give/Refine emits stale disambiguated names from `stDisambiguatedNames`+- [Issue #8875](https://github.com/agda/agda/issues/8875): Warn if one includes several versions of the same library+- [Issue #8881](https://github.com/agda/agda/issues/8881): Regression in 2.9.0-rc1 and 2.9.0-rc2: level meta left with only inequalities after instance search under a λ+- [Issue #8898](https://github.com/agda/agda/issues/8898): `primFloatDecode` does not terminate on `0.0` and `-0.0` (type checker, GHC and JS backends)++Pull requests merged for 2.9.0+------------------------------++- [PR #6911](https://github.com/agda/agda/issues/6911): Reopen PR "Add `record where` syntax sugar (#6603)"+- [PR #7861](https://github.com/agda/agda/issues/7861): Implement a --cubical=no-glue option+- [PR #7877](https://github.com/agda/agda/issues/7877): `record where`, again, again (again?)+- [PR #7881](https://github.com/agda/agda/issues/7881): [ fix #7876 ] Check meta instantiation in constraintMetas+- [PR #7908](https://github.com/agda/agda/issues/7908): Drop GHC 9.0 and below and bump dependencies to LTS 20.26+- [PR #7909](https://github.com/agda/agda/issues/7909): Fix #7906: use compiled clause reducer in termination checker+- [PR #7922](https://github.com/agda/agda/issues/7922): Mimer refactor+- [PR #7951](https://github.com/agda/agda/issues/7951): Improve module checkpointing performance+- [PR #7974](https://github.com/agda/agda/issues/7974): [workflows] run agda after building it (cabal & stack)+- [PR #7985](https://github.com/agda/agda/issues/7985): Fix #7976: warning on REWRITE pragmas when --rewriting is off+- [PR #7986](https://github.com/agda/agda/issues/7986): New option --ghc-trace to instrument code with call trace+- [PR #7990](https://github.com/agda/agda/issues/7990): Modalities in aliases and let-bindings+- [PR #7995](https://github.com/agda/agda/issues/7995): Fix #7994: warn about @tactic attributes ignored in declarations+- [PR #8000](https://github.com/agda/agda/issues/8000): Fix #7998: `instance` silently dropped in `primitive`/`variable` blocks+- [PR #8003](https://github.com/agda/agda/issues/8003): hotfix: support 'record where' in contexts+- [PR #8004](https://github.com/agda/agda/issues/8004): Re #7954: disallow postfix projections in parentheses+- [PR #8008](https://github.com/agda/agda/issues/8008): flake: fix overlay+- [PR #8009](https://github.com/agda/agda/issues/8009): New option --print-options and --bash-complete+- [PR #8014](https://github.com/agda/agda/issues/8014): doc: use the correct format for short options+- [PR #8017](https://github.com/agda/agda/issues/8017): nix: fix build on aarch64-darwin+- [PR #8020](https://github.com/agda/agda/issues/8020): record where: Fix impossible with named module copy+- [PR #8022](https://github.com/agda/agda/issues/8022): fixup: eta for cubical primitives against neutrals+- [PR #8025](https://github.com/agda/agda/issues/8025): Re #1499 #5277 better formatting for error AmbiguousFunClauses+- [PR #8027](https://github.com/agda/agda/issues/8027): Fix #5524: report (with range) duplicate name in fixity declaration+- [PR #8028](https://github.com/agda/agda/issues/8028): [ opt ] Optimize free variable sets+- [PR #8029](https://github.com/agda/agda/issues/8029): Benchmarking and profiling for module application+- [PR #8030](https://github.com/agda/agda/issues/8030): fixup: range of InlineNoExactSplit warning+- [PR #8038](https://github.com/agda/agda/issues/8038): Only generate copies for used names+- [PR #8040](https://github.com/agda/agda/issues/8040): Fix #8033: color warnings by keeping Doc over rendering to String+- [PR #8041](https://github.com/agda/agda/issues/8041): deepseq-1.5.2.0 no longer derives NFData with embedded functions+- [PR #8044](https://github.com/agda/agda/issues/8044): Hyperlink warning names on OSC 8 terminals+- [PR #8047](https://github.com/agda/agda/issues/8047): Highlighting in Emacs Agda information buffer+- [PR #8049](https://github.com/agda/agda/issues/8049): Fix #8048 by generating lock constraints also for implicit arguments+- [PR #8050](https://github.com/agda/agda/issues/8050): MAlonzo: avoid emitting duplicate import statements+- [PR #8052](https://github.com/agda/agda/issues/8052): Re #8024: alert user that --build-library does not accept backends+- [PR #8055](https://github.com/agda/agda/issues/8055): Fix issue #7001: no longer infer lambdas that have no erasure status on their arguments+- [PR #8056](https://github.com/agda/agda/issues/8056): Fix #6939: warn when parser drops misplaced tactic in `Fun`+- [PR #8057](https://github.com/agda/agda/issues/8057): Emacs mode: clean `agda2-forget-all-goals`+- [PR #8058](https://github.com/agda/agda/issues/8058): Structured output of `--help`: options sorted into topics+- [PR #8063](https://github.com/agda/agda/issues/8063): fixup: caching with copy trimming+- [PR #8065](https://github.com/agda/agda/issues/8065): Medium-sized serialization optimizations+- [PR #8069](https://github.com/agda/agda/issues/8069): Bubble transpSysTel' failures upwards+- [PR #8071](https://github.com/agda/agda/issues/8071): Go-to-definition in information buffer+- [PR #8073](https://github.com/agda/agda/issues/8073): globally cache small Term variables+- [PR #8079](https://github.com/agda/agda/issues/8079): Fix operator parsing asymptotics+- [PR #8081](https://github.com/agda/agda/issues/8081): [ fix #8078 ] Fix documentation for piSort+- [PR #8084](https://github.com/agda/agda/issues/8084): Inverse scope optimization+- [PR #8085](https://github.com/agda/agda/issues/8085): containers 0.8+- [PR #8089](https://github.com/agda/agda/issues/8089): Simplify "Installation" documentation+- [PR #8093](https://github.com/agda/agda/issues/8093): [ fix #8092 ] Preserve compiler pragmas when overwriting a definition+- [PR #8095](https://github.com/agda/agda/issues/8095): Fix #8094: run getInteractor after executing `--help` (regression in 2.8.0)+- [PR #8099](https://github.com/agda/agda/issues/8099): Fix #8098: don't delete readonly .agdai files+- [PR #8101](https://github.com/agda/agda/issues/8101): [ fix #8096 ] Redo implementation of LevelUniv infrastructure+- [PR #8102](https://github.com/agda/agda/issues/8102): Normalization level for Cmd_constraints (C-c C-=)+- [PR #8104](https://github.com/agda/agda/issues/8104): Fix #8103 by removing the parsing hack in BasicOps.metaHelperType+- [PR #8107](https://github.com/agda/agda/issues/8107): Fix #2410: only reduce NON_TERMINATING functions with C-u prefix to C-c C-n+- [PR #8108](https://github.com/agda/agda/issues/8108): Fix #8105: highlight thing shadowed by a clashing definition+- [PR #8110](https://github.com/agda/agda/issues/8110): Remove unnecessary LHS.Unify.LeftInverse computation+- [PR #8115](https://github.com/agda/agda/issues/8115): Implement `{Char, Nat}` primitives for JS backend and add related tests+- [PR #8121](https://github.com/agda/agda/issues/8121): Fix #8119: Dotted expression not impossible+- [PR #8127](https://github.com/agda/agda/issues/8127): Fix #8126: don't error-report generalized variables as projections+- [PR #8129](https://github.com/agda/agda/issues/8129): Fix #8128: point to previous definition in DuplicateDefinition error+- [PR #8135](https://github.com/agda/agda/issues/8135): Fix #8132 by adding SourceFile to SolvedButOpenHoles error+- [PR #8137](https://github.com/agda/agda/issues/8137): Fix #7941: allow splitting on a refined variable+- [PR #8141](https://github.com/agda/agda/issues/8141): Fix for issue #8097+- [PR #8146](https://github.com/agda/agda/issues/8146): Fix #8144: NoSuchModule X gives hint if there is a data/record X+- [PR #8147](https://github.com/agda/agda/issues/8147): Fix #4271: print filenames with modules in errors+- [PR #8149](https://github.com/agda/agda/issues/8149): Print lineage (`WhyInScope`) in `ClashingDefinition` error+- [PR #8151](https://github.com/agda/agda/issues/8151): Add Datatypes of Datatypes to tutorial list+- [PR #8155](https://github.com/agda/agda/issues/8155): Serialize Range in WhyInScope for lineage+- [PR #8156](https://github.com/agda/agda/issues/8156): Fix #8139: tolerate catch-all copatterns+- [PR #8158](https://github.com/agda/agda/issues/8158): Fix #7646 by synching goal command range with interaction range+- [PR #8159](https://github.com/agda/agda/issues/8159): Fix issue #5791: list all possible file extensions in FileNotFound error+- [PR #8160](https://github.com/agda/agda/issues/8160): Re #7225: remove some GenericDocErrors+- [PR #8162](https://github.com/agda/agda/issues/8162): Rename GenericDocErrors in Generalize.hs+- [PR #8169](https://github.com/agda/agda/issues/8169): Fix #8168 by catching ParseErrors in expressions Mimer produces+- [PR #8173](https://github.com/agda/agda/issues/8173): Do not set default input method to "Agda" globally+- [PR #8174](https://github.com/agda/agda/issues/8174): Add .agdai files to 'completion-ignored-extensions'+- [PR #8175](https://github.com/agda/agda/issues/8175): Remove usages of deprecated 'window-system' variable+- [PR #8176](https://github.com/agda/agda/issues/8176): Add custom setter to 'agda2-mode-abbrevs-use-defaults'+- [PR #8177](https://github.com/agda/agda/issues/8177): Allow disabling resizing of minibuffer due to input method+- [PR #8178](https://github.com/agda/agda/issues/8178): Check responses of commands issued by Agda to Emacs+- [PR #8179](https://github.com/agda/agda/issues/8179): Add support for 'repeat-mode'+- [PR #8181](https://github.com/agda/agda/issues/8181): Xref support for Agda2-mode+- [PR #8184](https://github.com/agda/agda/issues/8184): Reinterpret --termination-depth as max depth and do iterative deepening+- [PR #8194](https://github.com/agda/agda/issues/8194): UselessImport warning instead of ParseError for `import M x y`+- [PR #8195](https://github.com/agda/agda/issues/8195): Close #7225: remove Generic[Doc]Error for good+- [PR #8198](https://github.com/agda/agda/issues/8198): PR #8194 ctd.: move desugaring of `open import M args` into scope checker+- [PR #8200](https://github.com/agda/agda/issues/8200): Fix #8197: correct Range for "refine"+- [PR #8204](https://github.com/agda/agda/issues/8204): Fix #3123: instantiation of projection-like functions+- [PR #8205](https://github.com/agda/agda/issues/8205): Running Agda on WASM (resolving merge conflicts of #7561)+- [PR #8207](https://github.com/agda/agda/issues/8207): Fix #8206; refactor scope checker for RecDef a bit+- [PR #8210](https://github.com/agda/agda/issues/8210): Fix #8037 by copying record type along with its projection in module app+- [PR #8217](https://github.com/agda/agda/issues/8217): App range fix for operator application+- [PR #8220](https://github.com/agda/agda/issues/8220): Fix #8218: Update signature for imported rewrite rules+- [PR #8221](https://github.com/agda/agda/issues/8221): Treeless: don't mix up pipelines (#7691)+- [PR #8222](https://github.com/agda/agda/issues/8222): Optimize rewrite rule matching+- [PR #8226](https://github.com/agda/agda/issues/8226): New warning UnusedImports+- [PR #8232](https://github.com/agda/agda/issues/8232): Fix 8228: Parse Error with Display Pragma and Mixfix Operator+- [PR #8234](https://github.com/agda/agda/issues/8234): Fix #8231: Check relevance in `PTerm` matching+- [PR #8235](https://github.com/agda/agda/issues/8235): new feature: quote metas+- [PR #8238](https://github.com/agda/agda/issues/8238): New Warning to Fix #5929+- [PR #8239](https://github.com/agda/agda/issues/8239): [ fix #5315 ] Compile erased types to () in the GHC backend+- [PR #8243](https://github.com/agda/agda/issues/8243): [ fix #2691 ] Add basic documentation for simplification+- [PR #8250](https://github.com/agda/agda/issues/8250): Add --literate-markdown-only-agda-blocks option+- [PR #8267](https://github.com/agda/agda/issues/8267): Fix #8263: turn `__IMPOSSIBLE__` into `patternViolation` (regression in 2.6.4)+- [PR #8270](https://github.com/agda/agda/issues/8270): Fix #8269: doc: remove claim that ETA is safe for colists+- [PR #8274](https://github.com/agda/agda/issues/8274): Fix #8273: Consider interface to merge imported whilst checking confluence+- [PR #8278](https://github.com/agda/agda/issues/8278): Improve caching for (large) opaque blocks+- [PR #8279](https://github.com/agda/agda/issues/8279): Library management: support `defaults-X.Y.Z` files+- [PR #8280](https://github.com/agda/agda/issues/8280): Qualified `do` and qualified idiom brackets+- [PR #8292](https://github.com/agda/agda/issues/8292): Separately benchmark Polarity from Positivity; restore forcing of argOccurrences+- [PR #8293](https://github.com/agda/agda/issues/8293): Fix #3677: print names clashing with operators when parsing failed+- [PR #8295](https://github.com/agda/agda/issues/8295): Made it possible to turn off the occurrence analysis for functions+- [PR #8297](https://github.com/agda/agda/issues/8297): Doc on polarities: Cite the associated abstract.+- [PR #8303](https://github.com/agda/agda/issues/8303): GHC 9.14 compatibility+- [PR #8306](https://github.com/agda/agda/issues/8306): Re #8161: Split GeneralizePrepruneError into its three variants+- [PR #8309](https://github.com/agda/agda/issues/8309): Turn off colored terminal output when `NO_COLOR` is set.+- [PR #8310](https://github.com/agda/agda/issues/8310): Fix #8300: appViewM produces correct hiding for postfix projection+- [PR #8313](https://github.com/agda/agda/issues/8313): nix: bump nixpkgs+- [PR #8314](https://github.com/agda/agda/issues/8314): doc/user-manual: render maths as SVG instead of PNG+- [PR #8315](https://github.com/agda/agda/issues/8315): Reify an amount of backtrace when conversion checking fails+- [PR #8317](https://github.com/agda/agda/issues/8317): fix #8242: don't copy records to within themselves+- [PR #8318](https://github.com/agda/agda/issues/8318): #5833: make `with … in` generalise over `refl`+- [PR #8328](https://github.com/agda/agda/issues/8328): Fix #8327: check early for record constructor in let-pattern+- [PR #8329](https://github.com/agda/agda/issues/8329): Fix #8325 by changing an `__IMPOSSIBLE__` to a `fail` (regression in 2.8.0)+- [PR #8330](https://github.com/agda/agda/issues/8330): Fix #8326: handle the implication two-level <= cubical in isTwoLevelEnabled+- [PR #8332](https://github.com/agda/agda/issues/8332): Type check in parallel+- [PR #8333](https://github.com/agda/agda/issues/8333): Add link to "Let's play Agda" to user manual+- [PR #8338](https://github.com/agda/agda/issues/8338): #8337: Look for instance fields in eta records under binders+- [PR #8340](https://github.com/agda/agda/issues/8340): don't allow postulates in --safe lets+- [PR #8342](https://github.com/agda/agda/issues/8342): fix #8215: reduce candidate in its own state+- [PR #8345](https://github.com/agda/agda/issues/8345): Fix #8344: remember whether a LetBinding came from a LetAxiom+- [PR #8348](https://github.com/agda/agda/issues/8348): Erased levels [cubical]+- [PR #8353](https://github.com/agda/agda/issues/8353): Fix #8352: explicitly list JS primitives that should compile to Undefined+- [PR #8364](https://github.com/agda/agda/issues/8364): Support `@tactic` Module Parameters+- [PR #8369](https://github.com/agda/agda/issues/8369): Fix #8365: reduce in wrong context+- [PR #8376](https://github.com/agda/agda/issues/8376): Fix #7139: LeftInverse: reorder context in Solution steps+- [PR #8378](https://github.com/agda/agda/issues/8378): nix: enable cluster counting+- [PR #8381](https://github.com/agda/agda/issues/8381): Fix #8380: move line comment rule above block comment rule in lexer+- [PR #8382](https://github.com/agda/agda/issues/8382): Stop eta-expanding module applications+- [PR #8383](https://github.com/agda/agda/issues/8383): Free variable computation optimization+- [PR #8392](https://github.com/agda/agda/issues/8392): Progress reporting when checking in parallel+- [PR #8394](https://github.com/agda/agda/issues/8394): Fix --help claiming --type-in-type is the default+- [PR #8397](https://github.com/agda/agda/issues/8397): Make UnknownNamesIn{FixityDecl,PolarityPragmas} error warnings+- [PR #8401](https://github.com/agda/agda/issues/8401): Fix #8400 by remembering the range of the instance keyword+- [PR #8405](https://github.com/agda/agda/issues/8405): [ fix #8393 ] Normalise codomain of piSort when needed+- [PR #8406](https://github.com/agda/agda/issues/8406): Fix #8402: missing OtherAspects in agda.sty+- [PR #8407](https://github.com/agda/agda/issues/8407): JSONTop: avoid needless parentheses around types+- [PR #8409](https://github.com/agda/agda/issues/8409): Adding Sharp modality+- [PR #8410](https://github.com/agda/agda/issues/8410): Fix #7988: smarter figureOutTopLevelModule, prioritizes qualified module+- [PR #8413](https://github.com/agda/agda/issues/8413): Fix #5618: better wording of UselessInstance warning+- [PR #8414](https://github.com/agda/agda/issues/8414): Fix #5839 by adding conPartNotations to the OperatorInformation+- [PR #8416](https://github.com/agda/agda/issues/8416): Retain lineage (`AbstractName`) in `AmbiguousQName` for error reporting+- [PR #8433](https://github.com/agda/agda/issues/8433): Fix #3355: NO_POSITIVITY_CHECK pragmas in where and record+- [PR #8437](https://github.com/agda/agda/issues/8437): Fix #8435 by new warning DeclarationBeforeDefinition+- [PR #8438](https://github.com/agda/agda/issues/8438): Fix #4150 by sorting lone definitions up in a `mutual` block+- [PR #8439](https://github.com/agda/agda/issues/8439): Fix #6173 by inserting missing checkModuleName+- [PR #8444](https://github.com/agda/agda/issues/8444): fixup: traverse telescope properly in checkFibrantSplit+- [PR #8445](https://github.com/agda/agda/issues/8445): Remove transitive closure from positivity checking+- [PR #8447](https://github.com/agda/agda/issues/8447): Deprecate non-ES6 JS module styles+- [PR #8450](https://github.com/agda/agda/issues/8450): Mark all non-delimiter characters as word constituents in `agda2-mode-syntax-table`+- [PR #8451](https://github.com/agda/agda/issues/8451): [ #8283 ] Fix highlighting race condition in agda2-mode+- [PR #8458](https://github.com/agda/agda/issues/8458): [ #8452 ] Make agda2-maybe-goto jump across files+- [PR #8460](https://github.com/agda/agda/issues/8460): re. #8457: only ask if meta is an IP if cubical+- [PR #8462](https://github.com/agda/agda/issues/8462): Fix #8454+- [PR #8463](https://github.com/agda/agda/issues/8463): New `primRewriteNoMatch` primitive for controlling rewrite rule matching+- [PR #8466](https://github.com/agda/agda/issues/8466): Fix #8564: take definition site into account when serializing (Q)Name+- [PR #8469](https://github.com/agda/agda/issues/8469): Bump TeX-Live/setup-texlive-action from 3 to 4+- [PR #8471](https://github.com/agda/agda/issues/8471): Reverted two commits that made certain level arguments erased+- [PR #8473](https://github.com/agda/agda/issues/8473): Make Agda go faster+- [PR #8486](https://github.com/agda/agda/issues/8486): [ fix #7964 ] Properly handle projection-likeness in Mimer+- [PR #8488](https://github.com/agda/agda/issues/8488): Fix #8453: check field types of BUILTIN SIGMA+- [PR #8491](https://github.com/agda/agda/issues/8491): Add lines-per-second information to --profile=modules+- [PR #8498](https://github.com/agda/agda/issues/8498): [ emacs ] Overhaul goal lexer in agda2-goals-action+- [PR #8501](https://github.com/agda/agda/issues/8501): Bump GHC 9.12.2 to 9.12.4+- [PR #8502](https://github.com/agda/agda/issues/8502): Highlighting and go-to-definition in the debug buffer+- [PR #8503](https://github.com/agda/agda/issues/8503): Restrict pattern matching in binding position to eta-equality records (#6845 reopened)+- [PR #8506](https://github.com/agda/agda/issues/8506): [ emacs ] Only jump to an error in the selected window+- [PR #8508](https://github.com/agda/agda/issues/8508): User-manual: versionadded info for warnings+- [PR #8509](https://github.com/agda/agda/issues/8509): Dependencies: allow pqueue-1.7+- [PR #8512](https://github.com/agda/agda/issues/8512): Docs: why is --injective-type-constructors anti-classical & anti-univalent+- [PR #8515](https://github.com/agda/agda/issues/8515): `stripWithClausePatterns` in the right context+- [PR #8518](https://github.com/agda/agda/issues/8518): Serialize fewer generalization records+- [PR #8520](https://github.com/agda/agda/issues/8520): Update context in checkIApplyConfluence+- [PR #8522](https://github.com/agda/agda/issues/8522): Fix #8521 by remembering PossiblyProjectionPattern in DotP parsing+- [PR #8523](https://github.com/agda/agda/issues/8523): Remove inaccurate claim in two-level.lagda.rst+- [PR #8527](https://github.com/agda/agda/issues/8527): Update inaccurate Agda example in record-types.lagda.rst+- [PR #8528](https://github.com/agda/agda/issues/8528): [ emacs ] Fix goal detection in pattern lambdas+- [PR #8530](https://github.com/agda/agda/issues/8530): Fix #8529+- [PR #8533](https://github.com/agda/agda/issues/8533): No longer infer eta for records+- [PR #8541](https://github.com/agda/agda/issues/8541): Fix #6670 #5411 #6240 generalizeTel with open+- [PR #8542](https://github.com/agda/agda/issues/8542): Fix #7629 by correction countPatternVars for HITs+- [PR #8547](https://github.com/agda/agda/issues/8547): Fix #2877: doc: literal overloading is not allowed in patterns+- [PR #8555](https://github.com/agda/agda/issues/8555): Add mathematical bold fraktur to agda-input+- [PR #8556](https://github.com/agda/agda/issues/8556): Fix #4228: also prune genTel from solved interaction metas+- [PR #8560](https://github.com/agda/agda/issues/8560): Fix #3054 by introducing MatchPrio for constructor patterns (regression in 2.6.0)+- [PR #8567](https://github.com/agda/agda/issues/8567): Simplify fix of #6770: remove section updating+- [PR #8569](https://github.com/agda/agda/issues/8569): Fix occurrences in over-applied args, primitives and postulates+- [PR #8575](https://github.com/agda/agda/issues/8575): Add flag for irrelevance+- [PR #8576](https://github.com/agda/agda/issues/8576): [ fix #8557 ] Only resurrect irrelevant variables once+- [PR #8578](https://github.com/agda/agda/issues/8578): Fix #8577: Normalise under varTel in Unify.hs+- [PR #8584](https://github.com/agda/agda/issues/8584): Fix #8583: (Co)InfectiveError: report imported module with range+- [PR #8585](https://github.com/agda/agda/issues/8585): Fix #8580: internal error with _ in pattern synonym definition+- [PR #8588](https://github.com/agda/agda/issues/8588): [ re #8552 ] Add workaround to the release notes + test suite+- [PR #8593](https://github.com/agda/agda/issues/8593): Added `--erased-funext`, `--erased-propext` and `--erased-quotients`+- [PR #8594](https://github.com/agda/agda/issues/8594): Added a missing option to a list in the documentation+- [PR #8601](https://github.com/agda/agda/issues/8601): Fix #8596: termination checker respects copatterns+- [PR #8602](https://github.com/agda/agda/issues/8602): Fix #1680: Stratify termination masks by copattern+- [PR #8604](https://github.com/agda/agda/issues/8604): Bump actions/checkout from 6 to 7+- [PR #8606](https://github.com/agda/agda/issues/8606): Bump actions/cache from 5 to 6+- [PR #8612](https://github.com/agda/agda/issues/8612): Fix #8610+- [PR #8615](https://github.com/agda/agda/issues/8615): Fix #8587+- [PR #8617](https://github.com/agda/agda/issues/8617): Place -WShouldBeEtaRecordPattern under --exact-split.+- [PR #8628](https://github.com/agda/agda/issues/8628): Fixes #8626: treat lazy split pattern as dot pattern when there is nothing left to split in `compile`+- [PR #8632](https://github.com/agda/agda/issues/8632): Remove case-of-case optimization in compiler+- [PR #8635](https://github.com/agda/agda/issues/8635): Repair `nix build`+- [PR #8637](https://github.com/agda/agda/issues/8637): Bump actions/setup-python from 6 to 7+- [PR #8640](https://github.com/agda/agda/issues/8640): Allow aeson-2.3+- [PR #8643](https://github.com/agda/agda/issues/8643): Allow deepseq-1.5.2.0 (warns about rnf for functions)+- [PR #8646](https://github.com/agda/agda/issues/8646): Fix `COMPILE JS _∷_`+- [PR #8648](https://github.com/agda/agda/issues/8648): Fix #8647: for the sake of caching handle FOREIGN pragmas in the tc+- [PR #8652](https://github.com/agda/agda/issues/8652): Fix for #8636+- [PR #8657](https://github.com/agda/agda/issues/8657): [ fix #8649 ] Don't eta-expand no-eta records in confluence checker+- [PR #8658](https://github.com/agda/agda/issues/8658): Fix #8634: internal error with --interaction when .agda-lib file contains bogus fields+- [PR #8661](https://github.com/agda/agda/issues/8661): Upstream emacs mode fixes+- [PR #8662](https://github.com/agda/agda/issues/8662): Highlight ShouldBeEtaRecordPattern the same way as exactSplitWarnings+- [PR #8663](https://github.com/agda/agda/issues/8663): [wasm] nix: Bump nix pkgs for ghc-wasm to include critical bug fix for ghc/ghc#27447+- [PR #8667](https://github.com/agda/agda/issues/8667): Add missing flags to builtin modules+- [PR #8669](https://github.com/agda/agda/issues/8669): Fix #8638+- [PR #8671](https://github.com/agda/agda/issues/8671): Fix #8627: make --build-library on builtin library work+- [PR #8675](https://github.com/agda/agda/issues/8675): Dead code elimination: don't traverse meta judgement types+- [PR #8677](https://github.com/agda/agda/issues/8677): Fix #8599: classifyPattern: projection patterns only in LHSs+- [PR #8678](https://github.com/agda/agda/issues/8678): [ fix #5665 ] Close information gaps in the JSON interaction protocol+- [PR #8679](https://github.com/agda/agda/issues/8679): Fix #7564: Do not crash when trying eta-contraction on over-applied constructor.+- [PR #8681](https://github.com/agda/agda/issues/8681): Change R.constructor so that R is the record module rather than the type+- [PR #8682](https://github.com/agda/agda/issues/8682): Fix #8680 (pattern syn) by removing spurious `__IMPOSSIBLE__`+- [PR #8685](https://github.com/agda/agda/issues/8685): Fix #8683: check cubical side conditions also in inference mode+- [PR #8690](https://github.com/agda/agda/issues/8690): Fix #8686: False via projection-like due to non-injective type of principal argument+- [PR #8691](https://github.com/agda/agda/issues/8691): Fix #8688: positivity checker now also descends into Sort+- [PR #8701](https://github.com/agda/agda/issues/8701): Alternative fix of #8687+- [PR #8702](https://github.com/agda/agda/issues/8702): [ fix #8694 ] Take relevance into account for cycle rule in LHS unifier+- [PR #8706](https://github.com/agda/agda/issues/8706): Fix for #8700+- [PR #8707](https://github.com/agda/agda/issues/8707): Fix #8699 by masking irrelevant/Prop-sorted subterms in dot patterns in the termination checker+- [PR #8708](https://github.com/agda/agda/issues/8708): Fix #8697 by indexing the memo map for Double by their Word64 representation+- [PR #8709](https://github.com/agda/agda/issues/8709): Fix #8696 by eta-expanding data/recClauses before positivity checking+- [PR #8711](https://github.com/agda/agda/issues/8711): [ fix #8710 ] merge builtin rewrites when adding import+- [PR #8719](https://github.com/agda/agda/issues/8719): Small bugfix for Cubical Glue/HCompU (fixes #6198)+- [PR #8720](https://github.com/agda/agda/issues/8720): Compile constructors to string-tagged JS arrays+- [PR #8723](https://github.com/agda/agda/issues/8723): Add Agda Web to the manual+- [PR #8729](https://github.com/agda/agda/issues/8729): Fix #8532 by ensuring projectTyped gets a reduced type in antiUnify (regression in 2.5.3)+- [PR #8732](https://github.com/agda/agda/issues/8732): Fix #8698 by disallowing named where modules under with+- [PR #8736](https://github.com/agda/agda/issues/8736): [ #8591 ] Added a test case+- [PR #8738](https://github.com/agda/agda/issues/8738): Fix #1438: new warning FixityDeclarationForNonOperator+- [PR #8740](https://github.com/agda/agda/issues/8740): Fix issue 8336 by turning projection-like functions back into Defs (regression in 2.6.4)+- [PR #8743](https://github.com/agda/agda/issues/8743): Tried to fix a bug related to PR #8593+- [PR #8745](https://github.com/agda/agda/issues/8745): Support for `[]-cong`+- [PR #8768](https://github.com/agda/agda/issues/8768): Strict lets+- [PR #8770](https://github.com/agda/agda/issues/8770): Build with GHC 10.0.0+- [PR #8772](https://github.com/agda/agda/issues/8772): Fix #8771 by unspining also the transformed term in checkInternal (regression in 2.6.4)+- [PR #8774](https://github.com/agda/agda/issues/8774): Fix #8545 by storing data/recClause as just Term+- [PR #8778](https://github.com/agda/agda/issues/8778): Fix #8777: replace call to canonicalName by reduce+- [PR #8779](https://github.com/agda/agda/issues/8779): Fix #7664 checkParameters (revisit #8722)+- [PR #8789](https://github.com/agda/agda/issues/8789): Fix issue #8788+- [PR #8790](https://github.com/agda/agda/issues/8790): [ fix #8703 ] Treat underapplied functions as stuck+- [PR #8791](https://github.com/agda/agda/issues/8791): Fix #8787: drop hidden fields in record pattern when introduced by case-split+- [PR #8800](https://github.com/agda/agda/issues/8800): agda-mode: Rebind mouse-2 to 'agda2-goto-definition-mouse'+- [PR #8802](https://github.com/agda/agda/issues/8802): Makefile: new goal `fast-forward-ecosystem`; update submodules [ecosystem]+- [PR #8804](https://github.com/agda/agda/issues/8804): Fix #8783: Mimer: use functions from mutual block as default hints+- [PR #8806](https://github.com/agda/agda/issues/8806): Fix #8171 by creating metas at the unitPolarity (@++)+- [PR #8810](https://github.com/agda/agda/issues/8810): Fix #8808 by removing shortcut creating unbound de Bruijn indices+- [PR #8812](https://github.com/agda/agda/issues/8812): Fix #8811 by relaxing the modallity in the occurs check of sort annotations+- [PR #8816](https://github.com/agda/agda/issues/8816): Fix #8815 and #7972 by postponing constraints in Mimer+- [PR #8817](https://github.com/agda/agda/issues/8817): [ fix #8695 ] Treat occurrences in constructors of HITs as weakly rigid+- [PR #8822](https://github.com/agda/agda/issues/8822): Safer fix of #7181 (regression in 2.7.0)+- [PR #8833](https://github.com/agda/agda/issues/8833): [ fix #8765 ] Add separate response for errors in other files+- [PR #8837](https://github.com/agda/agda/issues/8837): [ fix #8828 ] Don't solve metas from outside current abstract block+- [PR #8840](https://github.com/agda/agda/issues/8840): [ #8839 ] Improved the detection of error/warning locations+- [PR #8843](https://github.com/agda/agda/issues/8843): Fix #8834 by checking cohesion and polarity when abstracting telescopes+- [PR #8850](https://github.com/agda/agda/issues/8850): Fix #8847 by not propagating `instance` to `unquoteDecl`s+- [PR #8852](https://github.com/agda/agda/issues/8852): Fix #8851: check that unquoteDecl invocation actually defines names+- [PR #8856](https://github.com/agda/agda/issues/8856): Fix #8853 by adding a case for `IApply` to `reconstructParameters`+- [PR #8869](https://github.com/agda/agda/issues/8869): Fix #8739: wrong implicit argument in LHS: also mention possible args+- [PR #8870](https://github.com/agda/agda/issues/8870): Decide whether pi is large based on original codomain sort+- [PR #8876](https://github.com/agda/agda/issues/8876): Fix #8875: warning to show dependency version conflicts+- [PR #8880](https://github.com/agda/agda/issues/8880): Fix #8858 as suggested: don't persists DisambiguatedNames during give+- [PR #8884](https://github.com/agda/agda/issues/8884): Fix #8881 by strengthening simplifyLevelConstraint+- [PR #8890](https://github.com/agda/agda/issues/8890): Fix #8888: constructor patterns keep the modality of the constructor+- [PR #8907](https://github.com/agda/agda/issues/8907): Fix #8898 by remove termination blunder in decodeFloat
README.md view
@@ -31,7 +31,7 @@ Contributing to Agda -------------------- -* Contribution how-to: [`HACKING`](https://github.com/agda/agda/blob/master/HACKING.md)+* [Contributing to Agda](https://github.com/agda/agda/blob/master/CONTRIBUTING.md) * [Haskell style-guide](https://github.com/andreasabel/haskell-style-guide/blob/master/haskell-style.md) [agdawiki]: http://wiki.portal.chalmers.se/agda/pmwiki.php
+ doc/release-notes/2.8.0.2.md view
@@ -0,0 +1,11 @@+Release notes for Agda version 2.8.0.2+======================================++This version fixes two issues with the released binaries.+No non-installation related issues were fixed over 2.8.0 or 2.8.0.1.+So if you have installed 2.8.0 or 2.8.0.1 already there is no need to upgrade to 2.8.0.2.++* Fix problem with missing `zlib1.dll` in released Windows binary ([issue #8733](https://github.com/agda/agda/issues/8733))+* Remove commit hash from version number in released binaries ([issue #8716](https://github.com/agda/agda/issues/8716))++* Agda supports GHC versions 8.8.4 to 9.14.1.
src/data/JS/agda-rts.amd.js view
@@ -147,7 +147,7 @@ mantissa *= 2.0; exponent -= 1; };- while (mantissa % 2.0 === 0) {+ while (mantissa % 2.0 === 0 && mantissa !== 0) { mantissa /= 2.0; exponent += 1; }@@ -350,6 +350,9 @@ exports.prim_glueU = _ => _ => _ => _ => _ => x => x; exports.prim_unglueU = _ => _ => _ => _ => x => x; exports.primFaceForall = f => f(true) == true && f(false) == false;++// Quotients.+exports.qrec = _ => _ => _ => _ => _ => _ => f => _ => _ => x => f(x); // Other stuff
src/data/JS/agda-rts.js view
@@ -145,7 +145,7 @@ mantissa *= 2.0; exponent -= 1; };- while (mantissa % 2.0 === 0) {+ while (mantissa % 2.0 === 0 && mantissa !== 0) { mantissa /= 2.0; exponent += 1; }@@ -347,6 +347,9 @@ exports.prim_glueU = _ => _ => _ => _ => _ => x => x; exports.prim_unglueU = _ => _ => _ => _ => x => x; exports.primFaceForall = f => f(true) == true && f(false) == false;++// Quotients.+exports.qrec = _ => _ => _ => _ => _ => _ => f => _ => _ => x => f(x); // Other stuff
src/data/JS/agda-rts.mjs view
@@ -147,7 +147,7 @@ mantissa *= 2.0; exponent -= 1; };- while (mantissa % 2.0 === 0) {+ while (mantissa % 2.0 === 0 && mantissa !== 0) { mantissa /= 2.0; exponent += 1; }@@ -349,6 +349,9 @@ exports.prim_glueU = _ => _ => _ => _ => _ => x => x; exports.prim_unglueU = _ => _ => _ => _ => x => x; exports.primFaceForall = f => f(true) == true && f(false) == false;++// Quotients.+exports.qrec = _ => _ => _ => _ => _ => _ => f => _ => _ => x => f(x); // Other stuff
src/data/MAlonzo/src/MAlonzo/RTE/Float.hs view
@@ -241,7 +241,7 @@ where normalise :: Integer -> Integer -> (Integer, Integer) normalise mantissa exponent- | even mantissa = normalise (mantissa `div` 2) (exponent + 1)+ | even mantissa, mantissa /= 0 = normalise (mantissa `div` 2) (exponent + 1) | otherwise = (mantissa, exponent) -- |Checks whether or not the Double is within a safe range of operation.
src/data/emacs-mode/agda-input.el view
@@ -1220,6 +1220,59 @@ ("Mfy" . ("𝔶")) ("Mfz" . ("𝔷")) + ("MFA" . ("𝕬"))+ ("MFB" . ("𝕭"))+ ("MFC" . ("𝕮"))+ ("MFD" . ("𝕯"))+ ("MFE" . ("𝕰"))+ ("MFF" . ("𝕱"))+ ("MFG" . ("𝕲"))+ ("MFH" . ("𝕳"))+ ("MFI" . ("𝕴"))+ ("MFJ" . ("𝕵"))+ ("MFK" . ("𝕶"))+ ("MFL" . ("𝕷"))+ ("MFM" . ("𝕸"))+ ("MFN" . ("𝕹"))+ ("MFO" . ("𝕺"))+ ("MFP" . ("𝕻"))+ ("MFQ" . ("𝕼"))+ ("MFR" . ("𝕽"))+ ("MFS" . ("𝕾"))+ ("MFT" . ("𝕿"))+ ("MFU" . ("𝖀"))+ ("MFV" . ("𝖁"))+ ("MFW" . ("𝖂"))+ ("MFX" . ("𝖃"))+ ("MFY" . ("𝖄"))+ ("MFZ" . ("𝖅"))+ ("MFa" . ("𝖆"))+ ("MFb" . ("𝖇"))+ ("MFc" . ("𝖈"))+ ("MFd" . ("𝖉"))+ ("MFe" . ("𝖊"))+ ("MFf" . ("𝖋"))+ ("MFg" . ("𝖌"))+ ("MFh" . ("𝖍"))+ ("MFi" . ("𝖎"))+ ("MFj" . ("𝖏"))+ ("MFk" . ("𝖐"))+ ("MFl" . ("𝖑"))+ ("MFm" . ("𝖒"))+ ("MFn" . ("𝖓"))+ ("MFo" . ("𝖔"))+ ("MFp" . ("𝖕"))+ ("MFq" . ("𝖖"))+ ("MFr" . ("𝖗"))+ ("MFs" . ("𝖘"))+ ("MFt" . ("𝖙"))+ ("MFu" . ("𝖚"))+ ("MFv" . ("𝖛"))+ ("MFw" . ("𝖜"))+ ("MFx" . ("𝖝"))+ ("MFy" . ("𝖞"))+ ("MFz" . ("𝖟"))+ ;; (Sub / Super) scripts. ;; ;; Unicode 12.1 omits several latin characters from sub/superscript.@@ -1510,6 +1563,34 @@ ;; Set up the input method. (agda-input-setup)++;; Allow disabling resizing of the minibuffer++(defun agda-input--fix-quail-newline (arglist)+ "Argument-filtering advice for `quail-minibuffer-message'.+This function takes the argument list ARGLIST before it is+applied to `quail-minibuffer-message', and makes sure the first+and only argument has no newline. This only has an effect if the+Agda input method is active."+ (save-match-data+ (pcase arglist+ ((and `(,(and (pred stringp) prompt))+ (guard (string-match+ (rx "[" (literal (cadr (assoc "Agda" quail-package-alist))) "]" (group "\n"))+ prompt)))+ (list (replace-match " " nil nil prompt 1)))+ (_ arglist))))++(defcustom agda-input-single-line nil+ "Avoid the Agda input method from resizing the minibuffer."+ :set (lambda (var val)+ (if val+ (advice-add #'quail-minibuffer-message :filter-args+ #'agda-input--fix-quail-newline)+ (advice-remove #'quail-minibuffer-message+ #'agda-input--fix-quail-newline))+ (custom-set-default var val))+ :type 'boolean) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Administrative details
src/data/emacs-mode/agda2-abbrevs.el view
@@ -78,27 +78,27 @@ ("oi" "open import ")) "Abbreviations defined by default in the Agda mode.") +(defvar agda2-mode-abbrev-table nil "Agda mode abbrev table.")+ (defcustom agda2-mode-abbrevs-use-defaults nil "If non-nil include the default Agda mode abbrevs in `agda2-mode-abbrev-table'. The abbrevs are designed to be expanded explicitly, so users of `abbrev-mode' probably do not want to include them. -Restart Emacs in order for this change to take effect."+You do not need to restart Emacs in order for this change to take+effect, if you adjust the value using the Customize UI or a macro like+`setopt'." :group 'agda2- :type '(choice (const :tag "Yes" t)- (const :tag "No" nil)))--(defvar agda2-mode-abbrev-table nil- "Agda mode abbrev table.")--(define-abbrev-table- 'agda2-mode-abbrev-table- (if agda2-mode-abbrevs-use-defaults- (mapcar (lambda (abbrev)- (append abbrev- (make-list (- 4 (length abbrev)) nil)- '((:system t))))- agda2-abbrevs-defaults)))+ :set (lambda (sym val)+ (custom-set-default sym val)+ (define-abbrev-table+ 'agda2-mode-abbrev-table+ (and val (mapcar (lambda (abbrev)+ (append abbrev+ (make-list (- 4 (length abbrev)) nil)+ '((:system t))))+ agda2-abbrevs-defaults))))+ :type 'boolean) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Administrative details
src/data/emacs-mode/agda2-highlight.el view
@@ -12,6 +12,7 @@ (require 'annotation) (require 'font-lock)+(require 'agda2) (defgroup agda2-highlight nil "Syntax highlighting for Agda."@@ -129,49 +130,49 @@ :background "light blue"))) ((equal group 'default-faces) (list (cons 'agda2-highlight-keyword-face- (list :inherit font-lock-keyword-face))+ (list :inherit 'font-lock-keyword-face)) (cons 'agda2-highlight-string-face- (list :inherit font-lock-string-face))+ (list :inherit 'font-lock-string-face)) (cons 'agda2-highlight-number-face- (list :inherit font-lock-constant-face))+ (list :inherit 'font-lock-constant-face)) (cons 'agda2-highlight-symbol-face- (list :inherit font-lock-keyword-face))+ (list :inherit 'font-lock-keyword-face)) (cons 'agda2-highlight-primitive-type-face- (list :inherit font-lock-keyword-face))+ (list :inherit 'font-lock-keyword-face)) (cons 'agda2-highlight-bound-variable-face- (list :inherit font-lock-variable-name-face))+ (list :inherit 'font-lock-variable-name-face)) (cons 'agda2-highlight-generalizable-variable-face- (list :inherit font-lock-variable-name-face))+ (list :inherit 'font-lock-variable-name-face)) (cons 'agda2-highlight-inductive-constructor-face- (list :inherit font-lock-type-face))+ (list :inherit 'font-lock-type-face)) (cons 'agda2-highlight-coinductive-constructor-face- (list :inherit font-lock-type-face))+ (list :inherit 'font-lock-type-face)) (cons 'agda2-highlight-datatype-face- (list :inherit font-lock-type-face))+ (list :inherit 'font-lock-type-face)) (cons 'agda2-highlight-field-face- (list :inherit font-lock-variable-name-face))+ (list :inherit 'font-lock-variable-name-face)) (cons 'agda2-highlight-function-face- (list :inherit font-lock-function-name-face))+ (list :inherit 'font-lock-function-name-face)) (cons 'agda2-highlight-module-face- (list :inherit font-lock-type-face))+ (list :inherit 'font-lock-type-face)) (cons 'agda2-highlight-postulate-face- (list :inherit font-lock-type-face))+ (list :inherit 'font-lock-type-face)) (cons 'agda2-highlight-primitive-face- (list :inherit font-lock-constant-face))+ (list :inherit 'font-lock-constant-face)) (cons 'agda2-highlight-macro-face- (list :inherit font-lock-function-name-face))+ (list :inherit 'font-lock-function-name-face)) (cons 'agda2-highlight-record-face- (list :inherit font-lock-variable-name-face))+ (list :inherit 'font-lock-variable-name-face)) (cons 'agda2-highlight-dotted-face- (list :inherit font-lock-variable-name-face))+ (list :inherit 'font-lock-variable-name-face)) (cons 'agda2-highlight-operator-face- (list :inherit font-lock-function-name-face))+ (list :inherit 'font-lock-function-name-face)) (cons 'agda2-highlight-error-face- (list :inherit font-lock-warning-face))+ (list :inherit 'font-lock-warning-face)) (cons 'agda2-highlight-typechecks-face- (list :inherit font-lock-type-face))+ (list :inherit 'font-lock-type-face)) (cons 'agda2-highlight-typechecking-face- (list :inherit font-lock-preprocessor-face)))))))+ (list :inherit 'font-lock-preprocessor-face))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Faces@@ -572,13 +573,22 @@ (apply 'annotation-load "Click mouse-2 to jump to definition" remove+ nil ;; apply highlighting to current buffer cmds))) -(defun agda2-highlight-add-annotations (remove &rest cmds)- "Like `agda2-highlight-apply'.-But only if `agda2-highlight-in-progress' is non-nil."+(defun agda2-highlight-add-annotations (file remove &rest cmds)+ "Apply highlighting CMDS to FILE, or to the current buffer if FILE is nil.+But only if `agda2-highlight-in-progress' is non-nil. If REMOVE is+non-nil, token-based highlighting is removed first. CMDS are annotation+commands as described by `agda2-highlight-apply'."+ (declare (agda2-command (t boolean &repeat list))) (if agda2-highlight-in-progress- (apply 'agda2-highlight-apply remove cmds)))+ (if file+ (let ((buffer (find-buffer-visiting file)))+ (when buffer+ (with-current-buffer buffer+ (apply 'agda2-highlight-apply remove cmds))))+ (apply 'agda2-highlight-apply remove cmds)))) (defun agda2-highlight-load (file) "Load syntax highlighting information from FILE.@@ -591,13 +601,21 @@ (read (current-buffer))))) (apply 'agda2-highlight-apply cmds))) -(defun agda2-highlight-load-and-delete-action (file)+(defun agda2-highlight-load-and-delete-action (file target) "Like `agda2-highlight-load', but deletes FILE when done. And highlighting is only updated if `agda2-highlight-in-progress'-is non-nil."+is non-nil. TARGET is the buffer's file, or nil for the current buffer."+ (declare (agda2-command (string t))) (unwind-protect (if agda2-highlight-in-progress- (agda2-highlight-load file))+ (let* ((coding-system-for-read 'utf-8)+ (cmds (with-temp-buffer+ (insert-file-contents file)+ (goto-char (point-min))+ (read (current-buffer)))))+ (if target+ (apply 'agda2-highlight-add-annotations target cmds)+ (apply 'agda2-highlight-apply cmds)))) (delete-file file))) (defun agda2-highlight-clear (&optional token-based)@@ -605,6 +623,7 @@ If TOKEN-BASED is non-nil, then only token-based highlighting is removed."+ (declare (agda2-command (boolean))) (interactive) (let ((inhibit-read-only t)) ; Ignore read-only status, otherwise this function may fail.
src/data/emacs-mode/agda2-mode-pkg.el view
@@ -1,3 +1,3 @@-(define-package "agda2-mode" "2.8.0.2"+(define-package "agda2-mode" "2.9.0" "interactive development for Agda, a dependently typed functional programming language" '((emacs "24.3"))) ;; dep defs for `annotation.el` and `eri.el` are not required if they are packaged together
src/data/emacs-mode/agda2-mode.el view
@@ -29,7 +29,7 @@ ;;; Code: -(defvar agda2-version "2.8.0.2"+(defvar agda2-version "2.9.0" "The version of the Agda mode. Note that the same version of the Agda executable must be used.") @@ -44,6 +44,7 @@ (require 'agda2-highlight) (require 'agda2-abbrevs) (require 'agda2-queue)+(require 'xref) (eval-and-compile ;; Load filladapt, if it is installed. (condition-case nil@@ -114,6 +115,15 @@ :type 'string :group 'agda2) +(defcustom agda2-restart-timeout+ 5+ "The number of seconds to wait before timing out restart attempts.++If nil, never time out."+ :type '(choice (const :tag "No timeout")+ (number :tag "Number of seconds"))+ :group 'agda2)+ (defcustom agda2-information-window-max-height 0.35 "The maximum height of the information window.@@ -122,16 +132,13 @@ :group 'agda2) (defcustom agda2-fontset-name- (unless (or (eq window-system 'mac)- ;; Emacs-23 uses a revamped font engine which should- ;; make agda2-fontset-name unnecessary in most cases.- ;; And if it turns out to be necessary, we should- ;; probably use face-remapping-alist rather than- ;; set-frame-font so the special font only applies to- ;; Agda buffers, and so it applies in all frames where- ;; Agda buffers are displayed.- (boundp 'face-remapping-alist))- "fontset-agda2")+ ;; Emacs-23 uses a revamped font engine which should make+ ;; agda2-fontset-name unnecessary in most cases. And if it turns+ ;; out to be necessary, we should probably use face-remapping-alist+ ;; rather than set-frame-font so the special font only applies to+ ;; Agda buffers, and so it applies in all frames where Agda buffers+ ;; are displayed.+ (and (not (boundp 'face-remapping-alist)) "fontset-agda2") "Default font to use in the selected frame when activating the Agda mode. This is only used if it's non-nil and Emacs is not running in a terminal.@@ -183,41 +190,79 @@ :group 'agda2 :type 'string) -(if (and (equal agda2-fontset-name "fontset-agda2") window-system)+(if (and (equal agda2-fontset-name "fontset-agda2") (display-graphic-p)) (create-fontset-from-fontset-spec agda2-fontset-spec-of-fontset-agda2 t t)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Global and buffer-local vars, initialization -(defvar agda2-mode-syntax-table- (let ((tbl (make-syntax-table)))- ;; Set the syntax of every char to "w" except for those whose default- ;; syntax in `standard-syntax-table' is `paren' or `whitespace'.- (map-char-table (lambda (keys val)- ;; `keys' here can be a normal char, a generic char- ;; (Emacs<23), or a char range (Emacs>=23).- (unless (memq (car val)- (eval-when-compile- (mapcar 'car- (list (string-to-syntax "(")- (string-to-syntax ")")- (string-to-syntax " ")))))- (modify-syntax-entry keys "w" tbl)))- (standard-syntax-table))- ;; Then override the remaining special cases.- (dolist (cs '((?- . "w 12") (?\n . ">")- (?. . ".") (?\; . ".") (?! . ".")))- (modify-syntax-entry (car cs) (cdr cs) tbl))- tbl)- "Syntax table used by the Agda mode:+(defconst agda2-mode-syntax-table+ (with-syntax-table (make-syntax-table)+ ;; The `standard-syntax-table' marks characters like "[" and "⟨" as delimiters.+ ;; This breaks `symbol-at-point' for identifiers like "[[X]]" when the point+ ;; is on the outer brackets. To fix this, we go through and mark all non-whitespace+ ;; characters as word constitutents, and then patch things up afterwards.+ (map-char-table+ (lambda (range val)+ (unless (memq (car val) (eval-when-compile (mapcar (lambda (c) (car (string-to-syntax c))) '(" " "w"))))+ (modify-syntax-entry range "w")))+ (char-table-parent (syntax-table))) -- | Comment character, word constituent.-\n | Comment ender.-.;! | Punctuation.+ ;; String literals+ ;;+ ;; We do not include ?\' as a quote char, as it can+ ;; be used in identifiers.+ (modify-syntax-entry ?\" "\"") + ;; Comments+ ;;+ ;; We use the "c" alternative comment style over "b", as "b"+ ;; only can be attached to the second char of a starting sequence+ ;; or the first char of an ending sequence. This leads to ambiguities,+ ;; as "{-" and "--" both have "-" as their second char.+ (modify-syntax-entry ?\{ "(}1nc")+ (modify-syntax-entry ?\} "){4nc")+ (modify-syntax-entry ?\n ">")+ ;; [HACK: Reed M, 04/03/2026]+ ;; We mark "-" as a word character so that `word-at-point' selects+ ;; whole identifiers in kebab-case like "foo-bar-baz". However, we+ ;; also mark the sequences "--", "{-", and "-}" as comment sequences.+ ;; This makes `comment-kill' function, but has the somewhat unintended+ ;; side effect of making killing off "--bar" in an identifier like "foo--bar".+ (modify-syntax-entry ?- "w 123")++ ;; Parens+ (modify-syntax-entry ?\( "()")+ (modify-syntax-entry ?\) ")(")+ ;; Adding ⦃⦄ and ⦇⦈ is a bit dubious here, as ⦃a⦄ and ⦇a⦈ are+ ;; valid identifers. However, it is more useful to be able+ ;; to get matching paren highlights then it is to support this+ ;; somewhat suspicious grammatical choice.+ (modify-syntax-entry ?⦃ "(⦄")+ (modify-syntax-entry ?⦄ ")⦃")+ (modify-syntax-entry ?⦇ "(⦈")+ (modify-syntax-entry ?⦈ ")⦇")++ ;; Punctuation+ (modify-syntax-entry ?. ".")+ (modify-syntax-entry ?\; ".")+ ;; [FIXME: Reed M, 04/03/2026]+ ;; Why is this marked as puncutation?+ (modify-syntax-entry ?! ".")++ (syntax-table))+ "Syntax table used by `agda2-mode':++\" | String delimiter.+- | Comment character, word constituent.+{} | Comment character, parentheses.+\n | Comment ender.+⦃⦄⦇⦈() | Parenthesis.+.;! | Punctuation.+ Remaining characters inherit their syntax classes from the-standard syntax table if that table treats them as matching-parentheses or whitespace. Otherwise they are treated as word+`standard-syntax-table' if that table treats them as matching+whitespace. Otherwise they are treated as word constituents.") (defconst agda2-command-table@@ -261,10 +306,7 @@ (eri-indent-reverse [S-iso-lefttab]) (eri-indent-reverse [S-lefttab]) (eri-indent-reverse [S-tab])- (agda2-goto-definition-mouse [mouse-2])- (agda2-goto-definition-keyboard "\M-.")- (agda2-go-back ,(if (version< emacs-version "25.1") "\M-*" "\M-,"))- )+ (agda2-goto-definition-mouse [mouse-2])) "Table of commands, used to build keymaps and menus. Each element has the form (CMD &optional KEYS WHERE DESC) where CMD is a command; KEYS is its key binding (if any); WHERE is a@@ -273,6 +315,44 @@ menu; and DESC is the description of the command used in the menus.") +(defvar agda2-movement-repeat-map (make-sparse-keymap))+(defcustom agda2-repeatable-commands+ '(agda2-next-goal+ agda2-previous-goal+ agda2-give+ agda2-refine+ agda2-make-case+ agda2-goal-and-context+ agda2-goal-and-context-and-inferred+ agda2-goal-and-context-and-checked)+ "List of commands that should be supported by `repeat-mode'.+This feature added in Emacs 28 enables a transient keymap after invoking+a command that binds shorter key chords. For Agda, the shorter keys+derived from the last key of the global key chord (so \"C-c C-f\" just+becomes \"C-f\" until you invoke a non-repeatable command). To make use+of this feature, the global minor mode `repeat-mode' must be enabled+separately."+ :set (lambda (sym val)+ (let ((m (make-sparse-keymap)))+ (map-keymap+ (lambda (_ev def)+ (when (symbolp def)+ (put def 'repeat-map nil)))+ agda2-movement-repeat-map)+ (dolist (fn val)+ (let* ((chord (cadr (assq fn agda2-command-table)))+ (key (aref chord (1- (length chord))))+ (kbd (vector key))+ (prev (lookup-key m kbd)))+ (when prev+ (error "Repeat-key duplicate: %S for `%S' already bound for `%S'"+ kbd fn prev))+ (define-key m kbd fn))+ (put fn 'repeat-map agda2-movement-repeat-map))+ (setq agda2-movement-repeat-map m))+ (custom-set-default sym val))+ :type '(repeat function))+ (defvar agda2-mode-map (let ((map (make-sparse-keymap "Agda mode"))) (define-key map [menu-bar Agda]@@ -367,14 +447,13 @@ "The Agda buffer. Note that this variable is not buffer-local.") -(defvar agda2-in-agda2-file-buffer nil- "Was `agda2-file-buffer' active when `agda2-output-filter' started?-Note that this variable is not buffer-local.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; agda2-mode ;;;###autoload+(add-to-list 'completion-ignored-extensions ".agdai")+;;;###autoload (add-to-list 'auto-mode-alist '("\\.l?agda\\'" . agda2-mode)) ;;;###autoload (modify-coding-system-alist 'file "\\.l?agda\\'" 'utf-8)@@ -394,6 +473,9 @@ Special commands: \\{agda2-mode-map}"+ :group 'agda2+ :interactive t+ :after-hook (agda2-initialize) (if (boundp 'agda2-include-dirs) (display-warning 'agda2 "Note that the variable agda2-include-dirs is@@ -413,37 +495,42 @@ (let ((l '(max-specpdl-size 2600 max-lisp-eval-depth 2800))) (while l (set (make-local-variable (pop l)) (pop l))))- (if (and window-system agda2-fontset-name)+ (if (and (display-graphic-p) agda2-fontset-name) (condition-case nil (set-frame-font agda2-fontset-name) (error (error "Unable to change the font; change agda2-fontset-name or tweak agda2-fontset-spec-of-fontset-agda2")))) ;; Deactivate highlighting if the buffer is edited before ;; typechecking is complete. (add-hook 'first-change-hook 'agda2-abort-highlighting nil 'local)- ;; If Agda is not running syntax highlighting does not work properly.- (unless (eq 'run (agda2-process-status))- (agda2-restart))++ ;; Make sure that Font Lock mode is not used. (font-lock-mode 0) (agda2-highlight-setup)- (condition-case err- (agda2-highlight-reload)- (error (message "Highlighting not loaded: %s"- (error-message-string err))))+ (agda2-comments-and-paragraphs-setup) (force-mode-line-update)- ;; Protect global value of default-input-method from set-input-method.- (make-local-variable 'default-input-method) ;; Don't take script into account when determining word boundaries (set (make-local-variable 'word-combining-categories) (cons '(nil . nil) word-combining-categories))- (set-input-method "Agda")+ (activate-input-method "Agda") ;; Highlighting etc. is removed when we switch from the Agda mode. ;; Use case: When a file M.lagda with a local variables list ;; including "mode: latex" is loaded chances are that the Agda mode ;; is activated before the LaTeX mode, and the LaTeX mode does not ;; seem to remove the text properties set by the Agda mode.- (add-hook 'change-major-mode-hook 'agda2-quit nil 'local))+ (add-hook 'change-major-mode-hook 'agda2-quit nil 'local)+ ;; Enable Xref+ (add-hook 'xref-backend-functions #'agda2-xref-backend -90 t)) +(defun agda2-initialize ()+ "Initialize the `agda2-process'."+ (unless (eq 'run (agda2-process-status))+ (agda2-restart))+ (condition-case err+ (agda2-highlight-reload)+ (error (message "Highlighting not loaded: %s"+ (error-message-string err)))))+ (defun agda2-restart () "Tries to start or restart the Agda process." (interactive)@@ -489,7 +576,7 @@ (set-process-coding-system agda2-process 'utf-8 'utf-8) (set-process-query-on-exit-flag agda2-process nil) (set-process-filter agda2-process 'agda2-output-filter)- (setq agda2-in-progress nil+ (setq agda2-in-progress 'busy agda2-file-buffer (current-buffer)) (with-current-buffer agda2-bufname@@ -498,6 +585,15 @@ agda2-last-responses nil) (set-buffer-file-coding-system 'utf-8)) + ;; Block until we see an initial prompt.+ ;;+ ;; This avoids a race condition triggered by sending a command before we've had+ ;; a chance to read any process output, which in turn makes `agda2-output-filter'+ ;; erroneously set `agda2-in-progress' to nil when it sees the initial prompt.+ (while agda2-in-progress+ (unless (accept-process-output agda2-process agda2-restart-timeout nil t)+ (error "Failed to start the Agda process")))+ (agda2-remove-annotations)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;@@ -612,6 +708,7 @@ "Resets certain variables. Intended to be used by the backend if an abort command was successful."+ (declare (agda2-command ())) (agda2-info-action "*Aborted*" "Aborted." t) (setq agda2-highlight-in-progress nil agda2-last-responses nil))@@ -649,9 +746,7 @@ ;; extract the fontified text and kill the temp buffer; so when Agda ;; finally answers, the temp buffer is long gone. (when (buffer-live-p agda2-file-buffer)- (setq agda2-in-agda2-file-buffer- (and agda2-file-buffer- (equal (current-buffer) agda2-file-buffer)))+ (let (;; The input lines in the current chunk. (lines (split-string chunk "\n")) @@ -789,17 +884,41 @@ (if input-from-goal (agda2-goal-Range o) (agda2-mkRange nil)) (agda2-string-quote txt) args)))) -;; Note that the following function is a security risk, since it-;; evaluates code without first inspecting it. The code (supposedly)-;; comes from the Agda backend, but there could be bugs in the backend-;; which can be exploited by an attacker which manages to trick-;; someone into type-checking compromised Agda code.- (defun agda2-exec-response (response)- "Interprets response."- (let ((inhibit-read-only t))- (eval response)))+ "Execute RESPONSE if recognised by `agda2-handler-alist'."+ (cl-assert (symbolp (car-safe response)))+ ;; Agda sends us a an S-expression that we can just `eval'uate. To+ ;; avoid arbitrary code execution and ensure that the commands Agda+ ;; sends us are well-formed, we use `apply' without evaluating any+ ;; arguments. The symbol of the invoked function must have a+ ;; `agda2-safe-function' symbol property asserting the expected+ ;; types of all arguments, w.r.t `cl-typep'.+ (let* ((inhibit-read-only t)+ (func (car response))+ (safe-p (plist-member (symbol-plist func) 'agda2-safe-function))+ (safe-data (cadr safe-p))+ (args '()))+ (unless safe-p+ (error "The function `%S' is not a valid Agda command" func))+ ;; Check each argument+ (dolist (arg (cdr response))+ (when (null safe-data)+ (error "More arguments than expected for `%S' (%S, got %S)"+ func safe-data response))+ (when (eq (car-safe arg) 'quote) ;unquote arguments+ (setq arg (cadr arg)))+ (let ((type (pop safe-data)))+ (unless (cl-typep arg type)+ (error "The function `%S' was invoked with %S which is not a %S"+ func arg type)))+ (push arg args))+ (condition-case err+ (with-local-quit+ (apply func (nreverse args)))+ (error (warn "Error while evaluating %S: %S" response err))))) ++ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; User commands and response processing @@ -882,6 +1001,10 @@ (defun agda2-give-action (old-g paren) "Update the goal OLD-G with the expression in it."+ (declare (agda2-command (integer (or (eql paren)+ (eql no-paren)+ string+ null)))) (let ;; Don't run modification hooks: we don't want this to ;; trigger agda2-abort-highlighting.@@ -915,6 +1038,7 @@ (defun agda2-make-case-action (newcls) "Replace the line at point with new clauses NEWCLS and reload."+ (declare (agda2-command (list))) (agda2-forget-all-goals);; we reload later anyway. (let* ((p0 (point)) (p1 (goto-char (+ (current-indentation) (line-beginning-position))))@@ -929,6 +1053,7 @@ (defun agda2-make-case-action-extendlam (newcls) "Replace definition of extended lambda with new clauses NEWCLS and reload."+ (declare (agda2-command (list))) (agda2-forget-all-goals);; we reload later anyway. (let* ((p0 (point)) (pmax (re-search-forward "!}"))@@ -956,10 +1081,11 @@ "Display the string STATUS in the current buffer's mode line. \(precondition: the current buffer has to use the Agda mode as the major mode)."+ (declare (agda2-command (string))) (setq agda2-buffer-external-status status) (force-mode-line-update)) -(defmacro agda2-information-buffer (buffer kind title)+(defmacro agda2-information-buffer (buffer kind name-of-mode title) "Used to define functions like `agda2-info-buffer'." `(defun ,buffer nil ,(concat "Creates the Agda " kind@@ -970,60 +1096,66 @@ (generate-new-buffer ,title)) (with-current-buffer ,buffer- (compilation-mode "AgdaInfo")+ (compilation-mode ,name-of-mode) ;; Support for jumping to positions mentioned in the text. (set (make-local-variable 'compilation-error-regexp-alist) '(("\\([\\\\/][^[:space:]]*\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\(\\([0-9]+\\)\\.\\)?\\([0-9]+\\)\\)?" 1 (2 . 6) (3 . 7))))++ ;; compilation-mode adds font-lock keywords for highlighting+ ;; things like "make: ", assuming that they're command output.+ ;;+ ;; This is annoying because sometimes our messages get+ ;; line-wrapped to start with "declaration:" (e.g. Issue2899).+ ;;+ ;; Conveniently all of these stupid highlights are in a variable+ ;; that we can just undo!+ (font-lock-remove-keywords nil compilation-mode-font-lock-keywords)+ (font-lock-flush)+ ;; Do not skip errors that start in the same position as the ;; current one. (set (make-local-variable 'compilation-skip-to-next-location) nil)+ ;; No support for recompilation. The key binding is removed, and ;; attempts to run `recompile' will (hopefully) result in an ;; error. (let ((map (copy-keymap (current-local-map))))- (define-key map (kbd "g") 'undefined)+ (define-key map (kbd "g") 'undefined)++ ;; Hijack the bindings for going to definition in the info+ ;; buffer, away from compilation-mode's, into something that+ ;; can read definition sites from highlighting info.+ (define-key map (kbd "RET") #'xref-find-definitions)+ (define-key map '[mouse-2] #'agda2-goto-definition-mouse)+ (use-local-map map))+ (set (make-local-variable 'compile-command) 'agda2-does-not-support-compilation-via-the-compilation-mode) (set-syntax-table agda2-mode-syntax-table) (set (make-local-variable 'word-combining-categories) (cons '(nil . nil) word-combining-categories))- (set-input-method "Agda")))-- ,buffer))+ (set-input-method "Agda")+ ;; Andreas, 2025-08-05, PR #8047.+ ;; We setup highlighting so that annotation-bindings is defined+ ;; and can be accessed by annotation-annotate.+ ;; This allows us to create Agda-style highlighting from aspects+ ;; also in the Agda information buffer.+ (agda2-highlight-setup) -(agda2-information-buffer agda2-info-buffer "info" "*Agda information*")+ ;; Use Xref+ (add-hook 'xref-backend-functions #'agda2-xref-backend -90 t))) -(defun agda2-info-action (name text &optional append)- "Insert TEXT into the Agda info buffer and display it.-NAME is displayed in the buffer's mode line.+ ,buffer)) -If APPEND is non-nil, then TEXT is appended at the end of the-buffer, and point placed after this text.+(agda2-information-buffer agda2-info-buffer "info" "AgdaInfo" "*Agda information*") -If APPEND is nil, then any previous text is removed before TEXT-is inserted, and point is placed before this text."+(defun agda2-display-information-buffer ()+ "Make sure the Agda information buffer is displayed in the current window.+Helper factored out from agda2-info-action." (interactive) (let ((buf (agda2-info-buffer)))- (with-current-buffer buf- ;; In some cases the jump-to-position-mentioned-in-text- ;; functionality (see compilation-error-regexp-alist above)- ;; didn't work: Emacs jumped to the wrong position. However, it- ;; seems to work if compilation-forget-errors is used. This- ;; problem may be related to Emacs bug #9679- ;; (http://debbugs.gnu.org/cgi/bugreport.cgi?bug=9679). The idea- ;; to use compilation-forget-errors comes from a comment due to- ;; Oleksandr Manzyuk- ;; (https://github.com/haskell/haskell-mode/issues/67).- (compilation-forget-errors)- (unless append (erase-buffer))- (save-excursion- (goto-char (point-max))- (insert text))- (put-text-property 0 (length name) 'face '(:weight bold) name)- (setq mode-line-buffer-identification name)- (force-mode-line-update)) ;; If the current window displays the information buffer, then the ;; window configuration is left untouched. (unless (equal (window-buffer) buf)@@ -1061,7 +1193,58 @@ (fit-window-to-buffer window (truncate (* (frame-height)- agda2-information-window-max-height))))))))+ agda2-information-window-max-height))))))))))++(defun agda2-info-action (name text append &rest annotations)+ "Insert TEXT plus a final newline into the Agda info buffer and display it.+NAME is displayed in the buffer's mode line.++The TEXT is highlighted by the given ANNOTATIONS+which come in the same format as for agda2-highlight-apply.++If APPEND is non-nil, then TEXT is appended at the end of the+buffer, and point placed after this text.++If APPEND is nil, then any previous text is removed before TEXT+is inserted, and point is placed before this text."+ (declare (agda2-command (string string boolean &repeat t))) ;+ (interactive)+ (let ((buf (agda2-info-buffer)))+ (with-current-buffer buf+ ;; In some cases the jump-to-position-mentioned-in-text+ ;; functionality (see compilation-error-regexp-alist above)+ ;; didn't work: Emacs jumped to the wrong position. However, it+ ;; seems to work if compilation-forget-errors is used. This+ ;; problem may be related to Emacs bug #9679+ ;; (http://debbugs.gnu.org/cgi/bugreport.cgi?bug=9679). The idea+ ;; to use compilation-forget-errors comes from a comment due to+ ;; Oleksandr Manzyuk+ ;; (https://github.com/haskell/haskell-mode/issues/67).+ (compilation-forget-errors)+ (unless append (erase-buffer))+ (unless (string-empty-p text)+ ;; (message "text = //%s//" text)+ (save-excursion+ (goto-char (point-max))+ ;; Andreas, 2025-08-04, PR #8047.+ ;; Experiment shows that 'face annotations do not survive in compilation-mode,+ ;; but 'font-lock-face is not removed.+ ;; https://emacs.stackexchange.com/questions/17141/how-do-i-insert-text-with-a-specific-face+ ;; (put-text-property 0 (max 0 (- (length text) 10)) 'font-lock-face '(:weight bold) text)+ ;; (message "text: %s" text)+ ;; (message "length: %i" (length text))+ ;; (message "annotations = %s" annotations)+ (apply 'annotation-load "Click to jump to definition" nil text annotations)+ ;; (pp (text-properties-at 0 text))+ (insert text)+ (newline)))+ ;; Update the mode line of the Agda information buffer,+ ;; displaying NAME in bold+ ;; in the place where usually the file name is displayed.+ (put-text-property 0 (length name) 'face '(:weight bold) name)+ (setq mode-line-buffer-identification name)+ (force-mode-line-update))+ (agda2-display-information-buffer) ;; Move point in every window displaying the information buffer. ;; Exception: If we are appending, don't move point in selected ;; windows.@@ -1075,13 +1258,10 @@ (defun agda2-info-action-and-copy (name text &optional append) "Same as agda2-info-action but also puts TEXT in the kill ring."+ (declare (agda2-command (string string t))) (kill-new text) (agda2-info-action name text append)) -(defun agda2-show-constraints()- "Show constraints." (interactive)- (agda2-go nil t 'busy t "Cmd_constraints"))- (defun agda2-remove-annotations () "Removes buffer annotations (overlays and text properties)." (interactive)@@ -1253,6 +1433,15 @@ ("HeadNormal" "head normalised") (global ,prompt))) +(defmacro agda2-maybe-normalised-toplevel-noprompt (name comment cmd)+ `(agda2-proto-maybe-normalised+ ,name ,comment ,cmd+ ("Simplified" "simplified")+ ("Instantiated" "neither explicitly normalised nor simplified")+ ("Normalised" "normalised")+ ("HeadNormal" "head normalised")+ (global nil)))+ (defmacro agda2-maybe-normalised-toplevel-asis-noprompt (name comment cmd) `(agda2-proto-maybe-normalised ,name ,comment ,cmd@@ -1424,6 +1613,16 @@ "Cmd_solveAll" ) +;; Andreas, 2025-09-12+;; Cmd_constraints has same normalization strategy as Cmd_solveOne+;; since after showing the meta solutions one might want to+;; apply them at the same normalization level.+(agda2-maybe-normalised-toplevel-noprompt+ agda2-show-constraints+ "Show meta solutions and constraints."+ "Cmd_constraints"+)+ (agda2-maybe-normalised agda2-solveOne "Solves the goal at point if it is already instantiated internally"@@ -1432,6 +1631,7 @@ ) (defun agda2-solveAll-action (iss)+ (declare (agda2-command (list))) (while iss (let* ((g (pop iss)) (txt (pop iss)) (cmd (cons 'agda2-solve-action (cons g (cons txt nil)))))@@ -1440,6 +1640,7 @@ (nconc agda2-last-responses (cons (cons 3 cmd) nil)))))) (defun agda2-solve-action (g txt)+ (declare (agda2-command (integer string))) (save-excursion (agda2-replace-goal g txt) (agda2-goto-goal g)@@ -1516,19 +1717,30 @@ "Cmd_load_highlighting_info" (agda2-string-quote (buffer-file-name))))) -(defun agda2-literate-p ()- "Is the current buffer a literate Agda buffer?"- (not (equal (file-name-extension (buffer-file-name)) "agda")))+(defun agda2-file-type (&optional path)+ "Determine the type of literate agda file based off of the file extension. -(defmacro agda2--case (exp &rest branches) ;FIXME: Use `pcase' instead!- (declare (debug t) (indent 1))- (let ((s (make-symbol "v")))- `(let ((,s ,exp))- (cond- ,@(mapcar (lambda (branch)- `((equal ,s ,(car branch)) ,@(cdr branch)))- branches)))))+If PATH is nil, use the filepath of the current buffer. +Will return one of the following options:++-- plain+-- latex+-- rst+-- markdown+-- org+-- typst+-- forester"+ (pcase (file-name-extension (or path (buffer-file-name)))+ ("agda" 'plain)+ ((or "lagda" "tex") 'latex)+ ("rst" 'rst)+ ("org" 'org)+ ("md" 'markdown)+ ("typ" 'typst)+ ("tree" 'forester)+ (ext (error "Unknown agda file extension %s" ext))))+ (defun agda2-goals-action (goals) "Annotates the goals in the current buffer with text properties. GOALS is a list of the buffer's goal numbers, in the order in@@ -1536,68 +1748,131 @@ be run /after/ syntax highlighting information has been loaded, because the two highlighting mechanisms interact in unfortunate ways."+ (declare (agda2-command (list))) (agda2-forget-all-goals) (agda2-let- ((literate (agda2-literate-p))- stk- top+ ((file-type (agda2-file-type))+ ;; All regexes in `code-start-rx' are headed by line-start (blank *) to avoid+ ;; creating interaction points in code blocks that are commented+ ;; out using the host languages comments (EG: % \begin{code})+ ;; See issue #1331.+ ;;+ ;; [TODO: Reed M, 14/04/2026] Literate RST support.+ (code-start-rx+ (pcase file-type+ ('latex+ (rx line-start (* blank) "\\begin{code}"))+ ('org+ (rx line-start (* blank) "#+begin_src" (+ blank) "agda2"))+ ((or 'typst 'markdown)+ (rx line-start (* blank) "```"))+ ('forester+ (rx line-start (* blank) "\\agda{"))))+ ;; We don't need to be as careful with comments in `code-end-rx', as+ ;; `code-rx' and the main lexer loop will handle comments for us.+ (code-end-rx+ (pcase file-type+ ('latex+ (rx "\\end{code}"))+ ('org+ (rx "#+end_src"))+ ((or 'typst 'markdown)+ (rx "```"))+ ;; Forester uses } to close out code blocks,+ ;; which requires special handling due to implicit+ ;; arguments.+ (_ (rx unmatchable))))+ (comment-rx+ (rx (or "{-" "-}")))+ (string-end-rx+ (rx (not "\\") "\""))+ (char-end-rx+ (rx (not "\\") "'"))+ (goal-end-rx+ (rx (or "{!" "!}")))+ (code-rx+ (rx (or+ (submatch-n 1 "\"")+ (and blank (submatch-n 1 "'"))+ ;; We want to make sure that we only match proper comments so that we don't+ ;; stop lexing on identifiers like foo--bar.+ (and (or bol (any "." "{" "}" "(" ")" ";" space)) (submatch-n 1 "--"))+ ;; Similar idea: don't match ? inside of an identifier name.+ (and (or bol (any "." "{" "}" "(" ")" ";" space))+ (submatch-n 1 "?")+ (or eol (any "." "{" "}" "(" ")" ";" space)))+ (submatch-n 1 (and "{" (? (any "-" "!"))))+ (submatch-n 1 "}")+ (submatch-n 1 (regexp code-end-rx))))) ;; Don't run modification hooks: we don't want this function to- ;; trigger agda2-abort-highlighting.- (inhibit-modification-hooks t))- ((delims() (re-search-forward "[?]\\|[{][-!]\\|[-!][}]\\|--\\|^%.*\\\\begin{code}\\|\\\\begin{code}\\|\\\\end{code}\\|```\\|\\#\\+begin_src agda2\\|\\#\\+end_src" nil t))- ;; is-proper checks whether string s (e.g. "?" or "--") is proper- ;; i.e., is not part of an identifier.- ;; comment-starter is true if s starts a comment (e.g. "--")- (is-proper (s comment-starter)- (save-excursion- (save-match-data- (backward-char (length s))- (unless (bolp) (backward-char 1)) ;; bolp = pointer at beginning of line- ;; Andreas, 2014-05-17 Issue 1132- ;; A questionmark can also follow immediately after a .- ;; for instance to be a place holder for a dot pattern.- (looking-at (concat "\\([.{}();]\\|^\\|\\s \\)" ;; \\s = whitespace- (regexp-quote s)- (unless comment-starter- "\\([{}();]\\|$\\|\\s \\)"))))))- (make(p) (agda2-make-goal p (point) (pop goals)))- (inside-comment() (and stk (null (car stk))))- (inside-goal() (and stk (integerp (car stk))))- (outside-code() (and stk (eq (car stk) 'outside)))- (inside-code() (not (outside-code)))- ;; inside a multi-line comment ignore everything but the multi-line comment markers- (safe-delims()- (if (inside-comment)- (re-search-forward "{-\\|-}" nil t)- (delims))))+ ;; trigger `agda2-abort-highlighting'.+ (inhibit-modification-hooks t)+ ;; Make sure that we don't use case-sensitive matching+ ;; so that we can pick up on all capitalizations of #+BEGIN_SRC.+ (case-fold-search t)+ (nbrackets 0))+ ((advance-to-code-block ()+ (when code-start-rx (re-search-forward code-start-rx nil t)))+ (advance-to-comment-end (n)+ (re-search-forward comment-rx nil t)+ (pcase (match-string 0)+ ("{-"+ (advance-to-comment-end (1+ n)))+ ("-}"+ (unless (zerop n)+ (advance-to-comment-end (1- n))))))+ (advance-to-string-end ()+ (re-search-forward string-end-rx nil t))+ (advance-to-char-end ()+ (re-search-forward char-end-rx nil t))+ (advance-to-goal-end (n)+ (re-search-forward goal-end-rx nil t)+ (pcase (match-string 0)+ ("{!"+ (advance-to-goal-end (1+ n)))+ ("!}"+ (if (zerop n)+ (point)+ (advance-to-goal-end (1- n))))))+ (end-of-code-block (str)+ (pcase file-type+ ('latex (equal str "\\end{code}"))+ ('org (equal (downcase str) "#+end_src"))+ ((or 'typst 'markdown) (equal str "```"))+ ('forester (and (equal str "}") (zerop nbrackets)))))) (save-excursion- ;; In literate mode we should start out in the "outside of code"- ;; state.- (if literate (push 'outside stk)) (goto-char (point-min))- (while (and goals (safe-delims))- (agda2--case (match-string 0)- ("\\begin{code}" (when (outside-code) (pop stk)))- ("\\end{code}" (when (not stk) (push 'outside stk)))- ("#+begin_src agda2" (when (outside-code) (pop stk)))- ("#+end_src" (when (not stk) (push 'outside stk)))- ("```" (if (outside-code) (pop stk)- (when (not stk) (push 'outside stk))))- ("--" (when (and (not stk)- (is-proper "--" t)) (end-of-line)))- ("{-" (when (and (inside-code)- (not (inside-goal))) (push nil stk)))- ("-}" (when (inside-comment) (pop stk)))- ("{!" (when (and (inside-code)- (not (inside-comment))) (push (- (point) 2) stk)))- ("!}" (when (inside-goal)- (setq top (pop stk))- (unless stk (make top))))- ("?" (progn- (when (and (not stk) (is-proper "?" nil))- (delete-char -1)- (insert "{!!}")- (make (- (point) 4))))))))))+ ;; This code assumes that all delimiters in Agda code+ ;; are properly matched, which may not hold if the user+ ;; performs a slow load and then starts insert/deleting+ ;; braces or quotes. However, this sort of problem is unavoidable+ ;; with our current synchronization strategy (or lack thereof).+ (advance-to-code-block)+ (while (and goals (re-search-forward code-rx nil t))+ (pcase (match-string 1)+ ((pred end-of-code-block)+ (advance-to-code-block))+ ("\""+ (advance-to-string-end))+ ("'"+ (advance-to-char-end))+ ("{-"+ (advance-to-comment-end 0))+ ("--"+ (end-of-line))+ ("{!"+ (let ((start (- (point) 2))+ (end (advance-to-goal-end 0)))+ (agda2-make-goal start end (pop goals))))+ ("?"+ (goto-char (match-beginning 1))+ (delete-char 1)+ (insert "{!!}")+ (agda2-make-goal (- (point) 4) (point) (pop goals)))+ ("{"+ (cl-incf nbrackets))+ ("}"+ (cl-decf nbrackets))))))) (defun agda2-make-goal (p q n) "Make a goal with number N at <P>{!...!}<Q>. Assume the region is clean."@@ -1764,17 +2039,12 @@ (insert-char ? indent) (backward-char (1+ indent))))))) (defun agda2-forget-all-goals ()- "Remove all goal annotations.-\(Including some text properties which might be used by other-\(minor) modes.)"+ "Remove all goal annotations." (annotation-preserve-mod-p-and-undo- (remove-text-properties (point-min) (point-max)- '(category nil agda2-delim2 nil agda2-delim3 nil- display nil rear-nonsticky nil)))- (let ((p (point-min)))- (while (< (setq p (next-single-char-property-change p 'agda2-gn))- (point-max))- (delete-overlay (car (agda2-goal-at p))))))+ (remove-text-properties (point-min) (point-max) '(category nil)))+ (dolist (ovl (overlays-in (point-min) (point-max)))+ (when (overlay-get ovl 'agda2-gn)+ (delete-overlay ovl)))) (defun agda2-decl-beginning () "Find the beginning point of the declaration containing the point.@@ -1807,14 +2077,24 @@ (defvar agda2-debug-buffer-name "*Agda debug*" "The name of the buffer used for Agda debug messages.") -(defun agda2-verbose (msg)- "Appends the string MSG to the `agda2-debug-buffer-name' buffer.+(defvar agda2-debug-buffer nil+ "Agda debug buffer.")++(agda2-information-buffer agda2-debug-buffer "debug" "AgdaDebug" agda2-debug-buffer-name)++(defun agda2-verbose (msg &rest annotations)+ "Appends the string MSG plus a final newline+to the `agda2-debug-buffer-name' buffer. Note that this buffer's contents is not erased automatically when a file is loaded."- (with-current-buffer (get-buffer-create agda2-debug-buffer-name)- (save-excursion- (goto-char (point-max))- (insert msg))))+ (declare (agda2-command (string &repeat t)))+ (unless (string-empty-p msg)+ (with-current-buffer (agda2-debug-buffer)+ (save-excursion+ (goto-char (point-max))+ (apply 'annotation-load "Click to jump to definition" nil msg annotations)+ (insert msg)+ (newline))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Comments and paragraphs@@ -1875,8 +2155,119 @@ "Keep"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;; Go to definition site+;; Xref integration +(defun agda2-xref-backend ()+ "Return an Xref backend."+ 'agda2)++(cl-defmethod xref-backend-identifier-at-point ((_ (eql agda2)))+ "Return the symbol at point with text properties."+ (and (consp (get-text-property (point) 'annotation-goto))+ (thing-at-point 'symbol)))++(defun agda2-make-xref (file point)+ "Return a `xref-item' pointing to FILE at POINT."+ (with-current-buffer (find-file-noselect file)+ (save-excursion+ (goto-char point)+ (xref-make+ (buffer-substring+ (line-beginning-position)+ (save-excursion+ (goto-char (line-end-position))+ (skip-syntax-backward " >")+ (point)))+ (xref-make-buffer-location+ (current-buffer)+ (point))))))++(defvar agda2-last-xref-ict (make-hash-table :test 'equal)+ "Cached table of unambiguous identifiers and their locations.")++(defun agda2-slurp-identifiers ()+ "Traverse the buffer for identifiers and update `agda2-last-xref-ict'."+ (save-excursion+ (let ((idents (make-hash-table)) start end)+ (goto-char (point-min))+ (catch 'done+ (while t+ (setq start (next-single-property-change+ (point) 'annotation-goto))+ (goto-char (or start (throw 'done t)))+ (cl-assert (get-text-property (point) 'annotation-goto))+ (setq end (next-single-property-change+ (point) 'annotation-goto))+ (goto-char (or end (throw 'done t)))+ (cl-assert (null (get-text-property (point) 'annotation-goto)))+ (when (< start end)+ (push (get-text-property (1- (point)) 'annotation-goto)+ (gethash (buffer-substring-no-properties start end)+ idents)))))+ (maphash+ (lambda (ident refs)+ (when (and (car refs) (null (cadr refs))) ;(length= refs 1)+ (puthash ident+ (agda2-make-xref (caar refs) (cdar refs))+ agda2-last-xref-ict)))+ idents)))+ agda2-last-xref-ict)++(cl-defmethod xref-backend-identifier-completion-table ((_ (eql agda2)))+ "Generate a list of possible candidates."+ ;; We clear and re-generate the hash-table mapping identifiers to+ ;; `xref-item' objects so that the completion is up-to-date and that+ ;; `xref-backend-definitions' can use the hash-table to lookup the+ ;; position of the identifier without a `annotation-goto'+ (clrhash agda2-last-xref-ict)+ (agda2-slurp-identifiers))++(cl-defmethod xref-backend-definitions ((_ (eql agda2)) ident)+ "Generate a list of definitions for identifier IDENT."+ (pcase (get-text-property 0 'annotation-goto ident)+ (`(,file . ,pos) (list (agda2-make-xref file pos)))+ ((pred null) ;`nil' is not backwards compatible...+ (let ((item (gethash ident agda2-last-xref-ict)))+ (and item (list item))))+ (prop (error "Unexpected `annotation-goto' on %S: %S" ident prop))))++(cl-defmethod xref-backend-references ((_ (eql agda2)) identifier)+ "Generate a list of references for IDENTIFIER."+ ;; TODO: Do not defer to the default implementation. This is just+ ;; grep, but we could also look through all open buffers as well.+ (xref-backend-references nil identifier))++;; Compatibility definition for releases of Emacs <28.1+(defalias 'agda2-mode-apropos-regexp+ (if (fboundp 'xref-apropos-regexp)+ 'xref-apropos-regexp+ (lambda (pattern)+ "Return an Emacs regexp from PATTERN similar to `apropos'."+ (require 'apropos)+ (declare-function+ apropos-parse-pattern "apropos"+ (pattern &optional multiline-p))+ (apropos-parse-pattern+ (if (string-equal (regexp-quote pattern) pattern)+ ;; Split into words+ (or (split-string pattern "[ \t]+" t)+ (user-error "No word list given"))+ pattern)))))++(cl-defmethod xref-backend-apropos ((_ (eql agda2)) pattern)+ "Generate a list of definitions matching PATTERN."+ (clrhash agda2-last-xref-ict)+ (dolist (buf (buffer-list))+ (with-current-buffer buf+ (when (derived-mode-p 'agda2-mode)+ (agda2-slurp-identifiers))))+ ;; TODO: add type annotations+ (cl-loop with regexp = (agda2-mode-apropos-regexp pattern)+ for ident being the hash-keys of agda2-last-xref-ict+ using (hash-values item)+ when (string-match-p regexp ident)+ collect item))+ (defun agda2-goto-definition-keyboard (&optional other-window) "Go to the definition site of the name under point (if any). If this function is invoked with a prefix argument then another window is used@@ -1888,15 +2279,39 @@ "Go to the definition site of the name clicked on, if any. Otherwise, yank (see `mouse-yank-primary')." (interactive "e")- (unless (annotation-goto-indirect ev)+ (if (consp (save-excursion+ (mouse-set-point ev)+ (get-text-property (point) 'annotation-goto)))+ (let ((xref-prompt-for-identifier nil))+ (mouse-set-point ev)+ (call-interactively #'xref-find-definitions)) ;; FIXME: Shouldn't we use something like ;; (call-interactively (key-binding ev))? --Stef (mouse-yank-primary ev))) +(defun agda2-info-goto-definition-mouse (ev)+ "While in the information buffer, to the definition site of the name+clicked on, if any.++Otherwise, invoke `compile-goto'."+ (interactive "e")++ ;; Always "use other window" because find-file-other-window will reuse+ ;; an existing window (i.e. the source file buffer) if it exists+ (unless (and agda2-file-buffer (annotation-goto-indirect ev t))+ (compile-goto-error ev)))++(defun agda2-info-goto-definition-keyboard ()+ "As `agda2-info-goto-definition-mouse', but at point."+ (declare (obsolete "Use `xref-find-definitions'" "2.9.0"))+ (interactive)+ (agda2-info-goto-definition-mouse (point)))+ (defun agda2-go-back nil "Go back to the previous position in which `agda2-goto-definition-keyboard' or `agda2-goto-definition-mouse' was invoked."+ (declare (obsolete "Use `xref-go-back'" "2.9.0")) (interactive) (annotation-go-back)) @@ -1904,30 +2319,45 @@ "Might move point to the given error. FILEPOS should have the form (FILE . POSITION). -If `agda2-highlight-in-progress' is nil, then nothing happens.-Otherwise, if the current buffer is the one that is connected to-the Agda process, then point is moved to POSITION in-FILE (assuming that the FILE is readable). Otherwise point is-moved to the given position in the buffer visiting the file, if-any, and in every window displaying the buffer, but the window-configuration and the selected window are not changed."+If `agda2-highlight-in-progress' is `nil', or if the selected+window does not visit (does not contain a buffer that visits)+`agda2-file-buffer', then nothing happens.++Otherwise:+* If the selected window visits FILE, or if no visible window+ visits FILE, then the selected window is made to visit FILE,+ and point is set to POSITION.+* Otherwise point is set to POSITION in every visible window that+ visits FILE."+ (declare (agda2-command (cons))) (when (and agda2-highlight-in-progress (consp filepos) (stringp (car filepos))- (integerp (cdr filepos)))- (if agda2-in-agda2-file-buffer- (annotation-goto-and-push (current-buffer) (point) filepos)- (save-excursion- (let ((buffer (find-buffer-visiting (car filepos))))- (when buffer- (let ((windows (get-buffer-window-list buffer- 'no-minibuffer t)))- (if windows- (dolist (window windows)- (with-selected-window window- (goto-char (cdr filepos))))- (with-current-buffer buffer- (goto-char (cdr filepos)))))))))))+ (integerp (cdr filepos))+ (eq (window-buffer) agda2-file-buffer))+ ;; We don't use `xref-show-xrefs', as we know that there is a+ ;; concrete position we want to jump to. nevertheless, we push+ ;; the current marker onto Xref' stack to make it seem like a Xref+ ;; jump.+ (xref-push-marker-stack)+ (if-let*+ ((buffer (find-buffer-visiting (car filepos)))+ (windows+ (get-buffer-window-list buffer 'no-minibuffer 'visible)))+ ;; Some visible window visits FILE.+ (if (eq buffer (window-buffer))+ ;; The selected window visits FILE.+ (goto-char (cdr filepos))+ ;; The selected window does not visit FILE. Update point in+ ;; all visible windows that visit FILE.+ (dolist (window windows)+ (with-selected-window window+ (goto-char (cdr filepos)))))+ ;; No visible window visits FILE. Make the current window visit+ ;; FILE.+ (switch-to-buffer+ (find-file-noselect (car filepos)) nil 'force-same-window)+ (goto-char (cdr filepos))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Implicit arguments@@ -2002,7 +2432,7 @@ If the version cannot be parsed, the answer is no. So e.g. agda-fast would be interpreted as not older than-agda-2.8.0.2"+agda-2.9.0" ;; If the given string does not have a numeric prefix, we answer no. (and (string-match "^[0-9][0-9.]*" version) (version< (match-string 0 version) "2.8")))@@ -2026,7 +2456,7 @@ If VERSION is empty or \"agda\", then agda is used. A prefix \"agda-\" is stripped from VERSION, so one can invoke this function e.g. with-\"agda-2.8.0.2\" instead of \"2.8.0.2\".+\"agda-2.9.0\" instead of \"2.9.0\". An attempt is made to preserve the default value of `agda2-mode-hook'." (interactive@@ -2047,7 +2477,7 @@ ;; * Replace version "agda" by just "". ;; ;; Rationale:- ;; The user might by accident enter "agda-2.8.0.2" instead of "2.8.0.2",+ ;; The user might by accident enter "agda-2.9.0" instead of "2.9.0", ;; or "agda" instead of "". (version (cond@@ -2092,9 +2522,8 @@ ;; Kill some buffers related to Agda. (when (buffer-live-p agda2-info-buffer) (kill-buffer agda2-info-buffer))- (when (and agda2-debug-buffer-name- (get-buffer agda2-debug-buffer-name))- (kill-buffer agda2-debug-buffer-name))+ (when (buffer-live-p agda2-debug-buffer)+ (kill-buffer agda2-debug-buffer)) ;; Remove the Agda mode directory from the load path. (setq load-path (delete agda2-directory load-path))
src/data/emacs-mode/agda2.el view
@@ -4,6 +4,40 @@ ;; loaded ;; SPDX-License-Identifier: MIT License +;;; Code:++;; By adding an `agda2--mark-as-safe' to `defun-declarations-alist',+;; we can use the `declare' syntax at the beginning of a `defun' to+;; denote that the function may be invoked and what form the arguments+;; ought to have.+(eval-and-compile+ (defun agda2--mark-as-safe (fn _args type)+ "Set the `agda2-safe-function' property for the function FN.+TYPE must be a list of `cl-typep'-compatible types that will+each be checked against the arguments when invoked. This+information is used by `agda2-exec-response' to safeguard the+execution."+ ;; Handle a `&repeat' in the safe argument spec by creating a+ ;; cyclic list. We copy the list to avoid destructively modifying+ ;; the argument list, which might be part of the physical code+ ;; structure.+ (dolist (arg type)+ (when (and (symbolp arg)+ (string-match-p "\\`&" (symbol-name arg))+ (not (eq '&repeat arg)))+ (error "%S: Unsupported keyword %S" fn arg)))+ (let* ((type (copy-sequence type))+ (rep (memq '&repeat type)))+ (when rep+ (setf (car rep) (cadr rep)+ (cdr rep) (cddr rep)+ (cdr (last rep)) rep))+ `(put ',fn 'agda2-safe-function ',type)))++ (add-to-list+ 'defun-declarations-alist+ (list 'agda2-command #'agda2--mark-as-safe)))+ (defvar agda2-directory (file-name-directory load-file-name) "Path to the directory that contains agda2.el(c).") @@ -11,6 +45,7 @@ (autoload 'agda2-mode "agda2-mode" "Major mode for editing Agda files (version ≥ 2)." t)+(add-to-list 'completion-ignored-extensions ".agdai") (add-to-list 'auto-mode-alist '("\\.l?agda\\'" . agda2-mode)) (modify-coding-system-alist 'file "\\.l?agda\\'" 'utf-8)
src/data/emacs-mode/annotation.el view
@@ -96,30 +96,43 @@ t) (error "File does not exist or is unreadable: %s." file))))) -(defun annotation-merge-faces (start end faces)+(defun annotation-merge-faces (start end faces &optional object) "Helper procedure used by `annotation-annotate'. For each position in the range the FACES are merged with the current value of the annotation-faces text property, and both the face and the annotation-faces text properties are set to the resulting list of faces. +If annotations are set in an OBJECT rather than in the current buffer,+we set the \='font-lock-face property rather than the \='face property,+as the latter is overwritten if we place the OBJECT in a buffer+that uses font-lock-mode, such as the Agda information buffer.+ Precondition: START and END must be numbers, and START must be less than END." (cl-assert (condition-case nil (< start end) (error nil))) (let ((pos start)+ ;; For the Agda buffers we use 'face,+ ;; but for putting annotated text in the Agda information buffer+ ;; we use 'font-lock-face, otherwise it is overwritten by font-lock.+ ;; In particular, compilation-mode as used in the Agda information buffer+ ;; will clear 'face annotations but preserve 'font-lock-face ones.+ ;; https://emacs.stackexchange.com/questions/17141/how-do-i-insert-text-with-a-specific-face+ (face-or-font-lock-face (if object 'font-lock-face 'face)) mid) (while (< pos end) (setq mid (next-single-property-change pos 'annotation-faces- nil end))- (let* ((old-faces (get-text-property pos 'annotation-faces))+ object end))+ (let* ((old-faces (get-text-property pos 'annotation-faces object)) (all-faces (cl-union old-faces faces)))- (mapc (lambda (prop) (put-text-property pos mid prop all-faces))- '(annotation-faces face))+ (put-text-property pos mid 'annotation-faces all-faces object)+ (put-text-property pos mid face-or-font-lock-face all-faces object) (setq pos mid))))) (defun annotation-annotate- (start end anns &optional token-based info goto)- "Annotate text between START and END in the current buffer.+ (start end anns &optional token-based info goto object)+ "Annotate text between START and END in the current buffer,+or in OBJECT if given. Nothing happens if either START or END are out of bounds for the current (possibly narrowed) buffer, or END <= START.@@ -157,33 +170,37 @@ that have been set; this ensures that the text properties can later be removed (if the annotation-* properties are not tampered with)."- (when (and (<= (point-min) start)- (< start end)- (<= end (point-max)))+ (when (and (< start end)+ (or object+ (and (<= (point-min) start)+ (<= end (point-max))))) (if (null anns)- (annotation-remove-annotations nil start end)+ (annotation-remove-annotations nil start end object) (let ((faces (delq nil (mapcar (lambda (ann) (cdr (assoc ann annotation-bindings))) anns))) (props nil))+ ;; (message "annotation-bindings = %s" annotation-bindings)+ ;; (message "anns = %s" anns)+ ;; (message "faces = %s" faces) (when faces- (annotation-merge-faces start end faces)+ (annotation-merge-faces start end faces object) (cl-pushnew 'face props) (cl-pushnew 'annotation-faces props)) (when token-based (add-text-properties start end- `(annotation-token-based t))+ `(annotation-token-based t) object) (cl-pushnew 'annotation-token-based props)) (when (consp goto) (add-text-properties start end- `(annotation-goto ,goto- mouse-face highlight))+ `(annotation-goto ,goto mouse-face highlight)+ object) (cl-pushnew 'annotation-goto props) (cl-pushnew 'mouse-face props)) (when info (add-text-properties start end- `(mouse-face highlight help-echo ,info))+ `(mouse-face highlight help-echo ,info) object) (cl-pushnew 'mouse-face props) (cl-pushnew 'help-echo props)) (when props@@ -192,11 +209,11 @@ mid) (while (< pos end) (setq mid (next-single-property-change pos- 'annotation-annotations nil end))- (let* ((old-props (get-text-property pos 'annotation-annotations))+ 'annotation-annotations object end))+ (let* ((old-props (get-text-property pos 'annotation-annotations object)) (all-props (cl-union old-props props))) (add-text-properties pos mid- `(annotation-annotated t annotation-annotations ,all-props))+ `(annotation-annotated t annotation-annotations ,all-props) object) (setq pos mid))))))))) (defmacro annotation-preserve-mod-p-and-undo (&rest code)@@ -215,10 +232,10 @@ (progn ,@code) (restore-buffer-modified-p ,modp))))) -(defun annotation-remove-annotations (&optional token-based start end)+(defun annotation-remove-annotations (&optional token-based start end object) "Remove text properties set by `annotation-annotate'. -In the current buffer. If START and END are given, then+In the current buffer or OBJECT. If START and END are given, then properties are only removed between these positions. If TOKEN-BASED is non-nil, then only token-based properties are removed.@@ -236,22 +253,23 @@ (let ((tag (if token-based 'annotation-token-based 'annotation-annotated))- (pos (or start (point-min)))- (end (or end (point-max)))+ (pos (or start (if object 0 (point-min))))+ (end (or end (if object (length object) (point-max)))) pos2) (while pos- (let ((props (get-text-property pos 'annotation-annotations)))- (setq pos2 (next-single-property-change pos tag nil end))+ (let ((props (get-text-property pos 'annotation-annotations object)))+ (setq pos2 (next-single-property-change pos tag object end)) (when (and props (or (not token-based) (member 'annotation-token-based props))) (remove-text-properties pos (or pos2 (point-max)) (cl-mapcan (lambda (prop) (list prop nil))- (cons 'annotation-annotations props)))))+ (cons 'annotation-annotations props))+ object))) (setq pos (unless (or (not pos2) (>= pos2 end)) pos2)))))) -(defun annotation-load (goto-help remove &rest cmds)- "Apply highlighting annotations in CMDS in the current buffer.+(defun annotation-load (goto-help remove object &rest cmds)+ "Apply highlighting annotations in CMDS in OBJECT or the current buffer. The argument CMDS should be a list of lists (start end anns &optional info goto). Text between start and end will be@@ -280,8 +298,11 @@ buffer." (annotation-preserve-mod-p-and-undo (when (listp cmds)- (let ((pos (point-min)))+ ;; (message "cmds = %s" cmds)+ (let ((pos (if object 0 (point-min)))) (dolist (cmd cmds)+ ;; (message "cmd = %s" cmd)+ (when cmd (cl-destructuring-bind (start end anns &optional token-based info goto) cmd (let ((info (if (and (not info) (consp goto))@@ -289,13 +310,14 @@ info))) (when remove (annotation-remove-annotations- 'token-based pos end)+ 'token-based pos end object) (setq pos end)) (annotation-annotate- start end anns token-based info goto))))+ start end anns token-based info goto object)))))+ ;; Remove annotations from the last point to the end of the buffer. (when remove (annotation-remove-annotations- 'token-based pos (point-max)))))))+ 'token-based pos (if object (length object) (point-max)) object)))))) (provide 'annotation) ;;; annotation.el ends here
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.8.0.2 Formatting LaTeX generated by Agda]+ [2026/10/17 version 2.9.0 Formatting LaTeX generated by Agda] \RequirePackage{ifxetex, ifluatex, xifthen, xcolor, polytable, etoolbox, calc, environ, xparse, xkeyval}@@ -165,9 +165,12 @@ \definecolor{AgdaUnsolvedMeta} {HTML}{D3D3D3} \definecolor{AgdaUnsolvedConstraint}{HTML}{D3D3D3} \definecolor{AgdaTerminationProblem}{HTML}{BEBEBE}- \definecolor{AgdaIncompletePattern} {HTML}{D3D3D3}+ \definecolor{AgdaPositivityProblem} {HTML}{BEBEBE}+ \definecolor{AgdaInstanceProblem} {HTML}{BEBEBE} %% TODO pick color+ \definecolor{AgdaCoverageProblem} {HTML}{D3D3D3} \definecolor{AgdaErrorWarning} {HTML}{BEBEBE} \definecolor{AgdaError} {HTML}{696969}+ \definecolor{AgdaDeadcode} {HTML}{EDEDED} % Misc. \definecolor{AgdaHole} {HTML}{BEBEBE}@@ -205,9 +208,12 @@ \definecolor{AgdaUnsolvedMeta} {HTML}{FFD700} \definecolor{AgdaUnsolvedConstraint}{HTML}{FFD700} \definecolor{AgdaTerminationProblem}{HTML}{FF0000}- \definecolor{AgdaIncompletePattern} {HTML}{A020F0}+ \definecolor{AgdaPositivityProblem} {HTML}{FF0000}+ \definecolor{AgdaInstanceProblem} {HTML}{FF0000} %% TODO pick color+ \definecolor{AgdaCoverageProblem} {HTML}{A020F0} \definecolor{AgdaErrorWarning} {HTML}{FF0000} \definecolor{AgdaError} {HTML}{F4A460}+ \definecolor{AgdaDeadcode} {HTML}{EDEDED} % Misc. \definecolor{AgdaHole} {HTML}{9DFF9D}@@ -244,9 +250,12 @@ \definecolor{AgdaUnsolvedMeta} {HTML}{FFFF00} \definecolor{AgdaUnsolvedConstraint}{HTML}{FFFF00} \definecolor{AgdaTerminationProblem}{HTML}{FFA07A}- \definecolor{AgdaIncompletePattern} {HTML}{F5DEB3}+ \definecolor{AgdaPositivityProblem} {HTML}{FFA07A}+ \definecolor{AgdaInstanceProblem} {HTML}{FFA07A} %% TODO pick color+ \definecolor{AgdaCoverageProblem} {HTML}{F5DEB3} \definecolor{AgdaErrorWarning} {HTML}{FFA07A} \definecolor{AgdaError} {HTML}{FF0000}+ \definecolor{AgdaDeadcode} {HTML}{EDEDED} % Misc. \definecolor{AgdaHole} {HTML}{9DFF9D}@@ -334,17 +343,27 @@ % Other aspect commands. \newcommand{\AgdaFixityOp} [1]{\AgdaNoSpaceMath{$#1$}} \newcommand{\AgdaDottedPattern} [1]{\textcolor{AgdaDottedPattern}{#1}}-\newcommand{\AgdaUnsolvedMeta} [1]- {\AgdaFontStyle{\colorbox{AgdaUnsolvedMeta}{#1}}}-\newcommand{\AgdaUnsolvedConstraint}[1]- {\AgdaFontStyle{\colorbox{AgdaUnsolvedConstraint}{#1}}}-\newcommand{\AgdaTerminationProblem}[1]- {\AgdaFontStyle{\colorbox{AgdaTerminationProblem}{#1}}}-\newcommand{\AgdaIncompletePattern} [1]{\colorbox{AgdaIncompletePattern}{#1}}-\newcommand{\AgdaErrorWarning} [1]{\colorbox{AgdaErrorWarning}{#1}}-\newcommand{\AgdaError} [1]- {\textcolor{AgdaError}{\AgdaFontStyle{\underline{#1}}}}-\newcommand{\AgdaCatchallClause} [1]{#1} % feel free to change this+% Boxes (background color):+\newcommand{\AgdaDeadcode} [1]{\AgdaFontStyle{\colorbox{AgdaDeadcode}{#1}}}+\newcommand{\AgdaInstanceProblem} [1]{\AgdaFontStyle{\colorbox{AgdaInstanceProblem}{#1}}}+\newcommand{\AgdaUnsolvedConstraint}[1]{\AgdaFontStyle{\colorbox{AgdaUnsolvedConstraint}{#1}}}+\newcommand{\AgdaUnsolvedMeta} [1]{\AgdaFontStyle{\colorbox{AgdaUnsolvedMeta}{#1}}}+% TODO: add coloring+\newcommand{\AgdaCatchallClause }[1]{#1} % feel free to change this+\newcommand{\AgdaCosmeticProblem }[1]{#1} % feel free to change this+\newcommand{\AgdaShadowingInTelescope}[1]{#1} % feel free to change this++% The following aspect are currently unused because Agda does not texify+% documents with error warnings.+\newcommand{\AgdaError} [1]{\textcolor{AgdaError}{\AgdaFontStyle{\underline{#1}}}}+% Boxes (background color):+\newcommand{\AgdaConfluenceProblem }[1]{#1} % feel free to change this+\newcommand{\AgdaCoverageProblem }[1]{\colorbox{CoverageProblem}{#1}}+\newcommand{\AgdaErrorWarning }[1]{\colorbox{AgdaErrorWarning}{#1}}+\newcommand{\AgdaMissingDefinition }[1]{#1} % currently unused+\newcommand{\AgdaPositivityProblem }[1]{\AgdaFontStyle{\colorbox{AgdaPositivityProblem}{#1}}}+\newcommand{\AgdaTerminationProblem}[1]{\AgdaFontStyle{\colorbox{AgdaTerminationProblem}{#1}}}+\newcommand{\AgdaTypeChecks }[1]{#1} % currently unused % Used to hide code from LaTeX. %
src/data/lib/prim/Agda/Builtin/Bool.agda view
@@ -1,5 +1,5 @@ {-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism- --no-sized-types --no-guardedness --level-universe #-}+ --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.Bool where
src/data/lib/prim/Agda/Builtin/Char.agda view
@@ -1,5 +1,5 @@ {-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism- --no-sized-types --no-guardedness --level-universe #-}+ --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.Char where @@ -16,3 +16,20 @@ primCharToNat : Char → Nat primNatToChar : Nat → Char primCharEquality : Char → Char → Bool++{-# COMPILE JS primCharEquality = x => y => x === y #-}+{-# COMPILE JS primIsLower = x => /\p{Ll}/u.test(x) #-} -- Ll stands for Lowercase letters+{-# COMPILE JS primIsDigit = x => /\d/u.test(x) #-}+{-# COMPILE JS primIsAlpha = x => /\p{L}/u.test(x) #-} -- L stands for Letters+{-# COMPILE JS primIsSpace = x => /\p{space}/u.test(x) #-}+{-# COMPILE JS primIsAscii = x => x.codePointAt(0) < 128 #-}+{-# COMPILE JS primIsLatin1 = x => x.codePointAt(0) < 256 #-}+{-# COMPILE JS primIsPrint = x => !/[\p{Cc}\p{Cf}]/u.test(x) #-}+{-# COMPILE JS primIsHexDigit = x => /\p{AHex}/u.test(x) #-} -- AHex stands for ASCII Hexadecimal digits+{-# COMPILE JS primToUpper = x => x.toUpperCase() #-}+{-# COMPILE JS primToLower = x => x.toLowerCase() #-}+{-# COMPILE JS primCharToNat = x => BigInt(x.codePointAt(0)) #-}+{-# COMPILE JS primNatToChar = function(x) {+ const y = x % 0x110000n;+ return 0xD800n <= y && y <= 0xDFFFn ? '�' : String.fromCodePoint(Number(y));+} #-}
src/data/lib/prim/Agda/Builtin/Char/Properties.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.Char.Properties where
src/data/lib/prim/Agda/Builtin/Cubical/Equiv.agda view
@@ -1,12 +1,18 @@-{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness #-}+{-# OPTIONS --cubical=no-glue --safe --no-sized-types --no-guardedness --no-irrelevance #-} module Agda.Builtin.Cubical.Equiv where open import Agda.Primitive open import Agda.Builtin.Sigma-open import Agda.Primitive.Cubical renaming (primINeg to ~_; primIMax to _∨_; primIMin to _∧_;- primHComp to hcomp; primTransp to transp; primComp to comp;- itIsOne to 1=1)+open import Agda.Primitive.Cubical+ renaming ( primINeg to infix 30 ~_ -- I → I+ ; primIMin to infixr 20 _∧_ -- I → I → I+ ; primIMax to infixr 20 _∨_ -- I → I → I+ ; 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 _[_↦_]) import Agda.Builtin.Cubical.HCompU as HCompU
src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --cubical --safe --no-sized-types --no-guardedness #-}+{-# OPTIONS --cubical --safe --no-sized-types --no-guardedness --no-irrelevance #-} module Agda.Builtin.Cubical.Glue where
src/data/lib/prim/Agda/Builtin/Cubical/HCompU.agda view
@@ -1,12 +1,18 @@-{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness #-}+{-# OPTIONS --cubical=no-glue --safe --no-sized-types --no-guardedness --no-irrelevance #-} module Agda.Builtin.Cubical.HCompU where open import Agda.Primitive open import Agda.Builtin.Sigma-open import Agda.Primitive.Cubical renaming (primINeg to ~_; primIMax to _∨_; primIMin to _∧_;- primHComp to hcomp; primTransp to transp; primComp to comp;- itIsOne to 1=1)+open import Agda.Primitive.Cubical+ renaming ( primINeg to infix 30 ~_ -- I → I+ ; primIMin to infixr 20 _∧_ -- I → I → I+ ; primIMax to infixr 20 _∨_ -- I → I → I+ ; 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)
src/data/lib/prim/Agda/Builtin/Cubical/Path.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness #-}+{-# OPTIONS --cubical=no-glue --safe --no-sized-types --no-guardedness --no-irrelevance #-} module Agda.Builtin.Cubical.Path where
src/data/lib/prim/Agda/Builtin/Cubical/Sub.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness #-}+{-# OPTIONS --cubical=no-glue --safe --no-sized-types --no-guardedness --no-irrelevance #-} module Agda.Builtin.Cubical.Sub where
src/data/lib/prim/Agda/Builtin/Equality.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.Equality where
src/data/lib/prim/Agda/Builtin/Equality/Erase.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --with-K --safe --no-sized-types --no-guardedness --level-universe #-}+{-# OPTIONS --with-K --safe --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.Equality.Erase where
src/data/lib/prim/Agda/Builtin/Equality/Rewrite.agda view
@@ -1,7 +1,9 @@-{-# OPTIONS --cubical-compatible --rewriting --no-sized-types --no-guardedness --level-universe #-}+{-# OPTIONS --cubical-compatible --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.Equality.Rewrite where open import Agda.Builtin.Equality {-# BUILTIN REWRITE _≡_ #-}++primitive primRewriteNoMatch : ∀ {a} {A : Set a} → A → A
+ src/data/lib/prim/Agda/Builtin/Erased/Box-cong.agda view
@@ -0,0 +1,33 @@+------------------------------------------------------------------------+-- The function []-cong+------------------------------------------------------------------------++{-# OPTIONS --cubical-compatible --safe --no-sized-types+ --no-guardedness --level-universe+ --erased-matches=restricted #-}++-- The flag --erased-matches=restricted turns on all kinds of erased+-- matches for indexed data types, but only in certain builtin+-- modules. The code below must only give access to []-cong, no other+-- forms of erased matches.++module Agda.Builtin.Erased.Box-cong where++open import Agda.Builtin.Equality+open import Agda.Builtin.Erased.Erased+open import Agda.Primitive++private variable+ a : Level+ @0 A : Set a+ @0 x y : A++-- Given an erased proof of equality of x and y one can show that+-- [ x ] is equal to [ y ].+--+-- Note that this function cannot at the time of writing be+-- implemented in regular Agda code (unless+-- --erased-matches=unrestricted is turned on).++[]-cong : @0 x ≡ y → [ x ] ≡ [ y ]+[]-cong refl = refl
+ src/data/lib/prim/Agda/Builtin/Erased/Erased.agda view
@@ -0,0 +1,32 @@+------------------------------------------------------------------------+-- The type Erased+------------------------------------------------------------------------++{-# OPTIONS --cubical-compatible --safe --no-sized-types+ --no-guardedness --level-universe+ --erasure --erased-matches=none #-}++module Agda.Builtin.Erased.Erased where++open import Agda.Builtin.Equality+open import Agda.Primitive++private variable+ a : Level++-- The type Erased, which is a type-level variant of @0.+--+-- This type is defined as a record type *without* η-equality, in+-- anticipation of a possible future addition of linear types to Agda.+-- If η-equality is enabled, then the η-expansion of the linear+-- identity function λ x → x at type Erased A → Erased A is+-- λ x → [ erased x ], which is arguably not linear.++record Erased (@0 A : Set a) : Set a where+ no-eta-equality+ pattern+ constructor [_]+ field+ @0 erased : A++open Erased public
+ src/data/lib/prim/Agda/Builtin/Erased/Funext.agda view
@@ -0,0 +1,25 @@+------------------------------------------------------------------------+-- Postulated, erased function extensionality+------------------------------------------------------------------------++{-# OPTIONS --cubical-compatible --safe --no-sized-types+ --no-guardedness --level-universe --erased-funext+ --erased-matches=none #-}++module Agda.Builtin.Erased.Funext where++open import Agda.Builtin.Equality++private variable+ A : Set _+ P : A → Set _+ f g : (x : A) → P x++-- Function extensionality.+--+-- This statement is not of the form "certain functions are+-- equivalences", but it is logically equivalent to such a statement,+-- and it does not depend on a definition of equivalence.++postulate+ @0 funext : (∀ x → f x ≡ g x) → f ≡ g
+ src/data/lib/prim/Agda/Builtin/Erased/Propext.agda view
@@ -0,0 +1,28 @@+------------------------------------------------------------------------+-- Postulated, erased propositional extensionality+------------------------------------------------------------------------++{-# OPTIONS --cubical-compatible --safe --no-sized-types+ --no-guardedness --level-universe --erased-propext+ --erased-matches=none #-}++module Agda.Builtin.Erased.Propext where++open import Agda.Builtin.Equality+open import Agda.Primitive++private variable+ a : Level+ A B : Set _++-- The property of being a proposition.++Is-proposition : Set a → Set a+Is-proposition A = (x y : A) → x ≡ y++-- Propositional extensionality.++postulate+ @0 propext :+ Is-proposition A → Is-proposition B →+ (A → B) → (B → A) → A ≡ B
+ src/data/lib/prim/Agda/Builtin/Erased/Quotient.agda view
@@ -0,0 +1,78 @@+------------------------------------------------------------------------+-- Set quotients with erased higher constructors and an eliminator+-- that computes for the point constructor+------------------------------------------------------------------------++-- The interface is based on the presentations of quotients in Martin+-- Hofmann's PhD thesis and the HoTT book, as well as the set quotient+-- HIT in the cubical library, due to Zesen Qian and Anders Mörtberg.++{-# OPTIONS --cubical-compatible --safe --no-sized-types+ --no-guardedness --level-universe --erased-quotients+ --erased-matches=none #-}++module Agda.Builtin.Erased.Quotient where++open import Agda.Builtin.Equality+open import Agda.Primitive++private variable+ a p r : Level+ A : Set _+ @0 R : A → A → Set _+ x y : A++-- The property of being a set.++Is-set : Set a → Set a+Is-set A = {x y : A} (p q : x ≡ y) → p ≡ q++-- The subst function.++subst : (P : A → Set p) → x ≡ y → P x → P y+subst _ refl p = p++infix 4 _/_++postulate++ -- Set quotients.++ _/_ : (A : Set a) (@0 R : A → A → Set r) → Set (a ⊔ r)++ -- The point constructor.+ --+ -- If the type of [_] is changed, then+ -- Agda.TypeChecking.Primitive.primQrec might need to be modified.++ [_] : {a r : Level} {A : Set a} {@0 R : A → A → Set r} → A → A / R++ -- [_] respects the quotient relation.++ @0 resp : R x y → _≡_ {A = A / R} [ x ] [ y ]++ -- The quotients are set-truncated.++ @0 set : Is-set (A / R)++{-# BUILTIN QUOTIENTCONSTRUCTOR [_] #-}+{-# FOREIGN GHC type Quotient a r a' r' = a' #-}+{-# COMPILE GHC _/_ = type Quotient #-}+{-# COMPILE GHC [_] = \_ _ _ _ x -> x #-}+{-# COMPILE JS [_] = _ => _ => _ => _ => x => x #-}++primitive++ -- An eliminator for _/_.+ --+ -- If the type of qrec is changed, then+ -- Agda.TypeChecking.Primitive.primQrec and compiler backend code+ -- might need to be modified.++ qrec :+ {a r p : Level} {A : Set a} {@0 R : A → A → Set r}+ (P : A / R → Set p)+ (f : ∀ x → P [ x ]) →+ @0 (∀ {x y} (r : R x y) → subst P (resp r) (f x) ≡ f y) →+ @0 (∀ x → Is-set (P x)) →+ (x : A / R) → P x
src/data/lib/prim/Agda/Builtin/Float.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.Float where
src/data/lib/prim/Agda/Builtin/Float/Properties.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.Float.Properties where
src/data/lib/prim/Agda/Builtin/FromNat.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.FromNat where
src/data/lib/prim/Agda/Builtin/FromNeg.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.FromNeg where
src/data/lib/prim/Agda/Builtin/FromString.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.FromString where
src/data/lib/prim/Agda/Builtin/IO.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.IO where
src/data/lib/prim/Agda/Builtin/Int.agda view
@@ -1,11 +1,9 @@-{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.Int where open import Agda.Builtin.Nat open import Agda.Builtin.String--infix 8 pos -- Standard library uses this as +_ data Int : Set where pos : (n : Nat) → Int
src/data/lib/prim/Agda/Builtin/List.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.List where @@ -13,4 +13,4 @@ if (x.length < 1) { return v["[]"](); } else { return v["_∷_"](x[0], x.slice(1)); } } #-} {-# COMPILE JS [] = Array() #-}-{-# COMPILE JS _∷_ = function (x) { return function(y) { return Array(x).concat(y); }; } #-}+{-# COMPILE JS _∷_ = function (x) { return function(y) { return [x].concat(y); }; } #-}
src/data/lib/prim/Agda/Builtin/Maybe.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.Maybe where
src/data/lib/prim/Agda/Builtin/Nat.agda view
@@ -1,5 +1,5 @@ {-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism- --no-sized-types --no-guardedness --level-universe #-}+ --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.Nat where @@ -94,6 +94,18 @@ -- -- Q.e.d. +-- If we don't give a definition for div-helper in JS, the JS backend will+-- generate a recursive function, which can exhaust the heap memory.+-- So we provide a direct definition for the JS backend.+--+-- If the precondition j ≤ m is not met, the formula above is still valid,+-- as m - j < 1 + m and other steps do not depend on the precondition.+-- And the only point to notice is that n + m may be greater than j,+-- in which case n + m - j is 0 in Agda's Nat, but can be negative in JS's BigInt.+-- Thus n + m - j should be changed to something like max (n + m - j) 0,+-- so that the JS backend produces equivalent codes.+{-# COMPILE JS div-helper = k => m => n => j => k + (n + m - j >= 0n ? n + m - j : 0n) / (1n + m) #-}+ -- Helper function mod-helper for the remainder computation. --------------------------------------------------------------------------- --@@ -124,7 +136,7 @@ -- = mod-helper 0 m n m by definition -- = (n + 0) mod (1 + m) by induction hypothesis -- = (n + (1 + m)) mod (1 + m) by expansion--- = (1 + n) + k) mod (1 + m) since k = m (as l = 0)+-- = ((1 + n) + k) mod (1 + m) since k = m (as l = 0) -- -- clause 3: mod-helper k m (1 + n) (1 + j) -- = mod-helper (1 + k) m n j by definition@@ -132,3 +144,30 @@ -- = ((1 + n) + k) mod (1 + m) by commutativity -- -- Q.e.d.++-- Unfortunately, when the invariant m = k + j is not met, the formula above+-- is not valid, and we need a different formula for the JS backend,+-- so that the JS backend produces fully equivalent codes.+--+-- If j ≥ n, then the recursion will eventually run into clause 1, and we have+--+-- mod-helper k m n j+-- = mod-helper (k + n) m 0 (j - n) by applying definition (case 1) n times+-- = k + n by definition (case 3)+--+-- otherwise, the recursion will eventually run into clause 2, which will+-- make the invariant valid again, and we have+--+-- mod-helper k m n j+-- = mod-helper (k + j) m (n - j) 0 by applying definition (case 3) j times+-- = mod-helper 0 m (n - j - 1) m by definition (case 2)+-- = (n - j - 1 + 0) mod (1 + m) by previous proof+-- = (n - j - 1) mod (1 + m) by simplification+--+{-# COMPILE JS mod-helper = k => m => n => j => m ==+ k + j ?+ (n + k) % (1n + m) :+ (j >= n) ?+ k + n :+ (n - j - 1n) % (1n + m)+#-}
src/data/lib/prim/Agda/Builtin/Reflection.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.Reflection where
src/data/lib/prim/Agda/Builtin/Reflection/External.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.Reflection.External where
src/data/lib/prim/Agda/Builtin/Reflection/Properties.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.Reflection.Properties where
src/data/lib/prim/Agda/Builtin/Sigma.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.Sigma where
src/data/lib/prim/Agda/Builtin/Size.agda view
@@ -1,5 +1,5 @@ {-# OPTIONS --cubical-compatible --no-universe-polymorphism --sized-types- --no-guardedness --level-universe #-}+ --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.Size where
src/data/lib/prim/Agda/Builtin/Strict.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.Strict where
src/data/lib/prim/Agda/Builtin/String.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.String where
src/data/lib/prim/Agda/Builtin/String/Properties.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} 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 --level-universe #-}+{-# OPTIONS --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.TrustMe where
src/data/lib/prim/Agda/Builtin/Unit.agda view
@@ -1,5 +1,5 @@ {-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism- --no-sized-types --no-guardedness --level-universe #-}+ --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.Unit where
src/data/lib/prim/Agda/Builtin/Word.agda view
@@ -1,5 +1,5 @@ {-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism- --no-sized-types --no-guardedness --level-universe #-}+ --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.Word where
src/data/lib/prim/Agda/Builtin/Word/Properties.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Builtin.Word.Properties where
src/data/lib/prim/Agda/Primitive.agda view
@@ -1,6 +1,6 @@ -- The Agda primitives (preloaded). -{-# OPTIONS --cubical-compatible --no-import-sorts --level-universe #-}+{-# OPTIONS --cubical-compatible --safe --no-import-sorts --no-sized-types --no-guardedness --no-irrelevance --level-universe #-} module Agda.Primitive where
src/data/lib/prim/Agda/Primitive/Cubical.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --erased-cubical #-}+{-# OPTIONS --cubical=no-glue --safe --no-sized-types --no-guardedness --no-irrelevance #-} module Agda.Primitive.Cubical where @@ -11,9 +11,6 @@ -- I is treated as the type of booleans. {-# COMPILE JS i0 = false #-} {-# COMPILE JS i1 = true #-}--infix 30 primINeg-infixr 20 primIMin primIMax primitive primIMin : I → I → I
src/full/Agda/Benchmarking.hs view
@@ -9,16 +9,16 @@ import Control.DeepSeq import qualified Control.Exception as E -import Data.IORef- import GHC.Generics (Generic) import System.IO.Unsafe import Agda.Syntax.Abstract.Name import Agda.Syntax.TopLevelModuleName (TopLevelModuleName)+ import Agda.Utils.Benchmark (MonadBench(..)) import qualified Agda.Utils.Benchmark as B+import qualified Agda.Utils.IORef.Strict as Strict import Agda.Utils.Null import Agda.Syntax.Common.Pretty @@ -36,8 +36,10 @@ -- ^ Type checking and translation to internal syntax. | Termination -- ^ Termination checking.+ | Polarity+ -- ^ Polarity computation. | Positivity- -- ^ Positivity checking and polarity computation.+ -- ^ Positivity checking. | Injectivity -- ^ Injectivity checking. | ProjectionLikeness@@ -98,6 +100,8 @@ -- ^ Subphase for 'Typing': solving instance goals | Reflection -- ^ Subphase for 'Typing': evaluating elaborator reflection+ | ApplySection+ -- ^ Subphase for 'Typing': copying definitions for a module macro | InitialCandidates -- ^ Subphase for 'InstanceSearch': collecting initial candidates | FilterCandidates@@ -108,9 +112,14 @@ -- ^ Subphase for 'InstanceSearch': reducing overlapping instances | UnifyIndices -- ^ Subphase for 'CheckLHS': unification of the indices- | InverseScopeLookup- -- ^ Pretty printing names.+ | InverseNameLookup+ | InverseModuleLookup+ | InverseInScope+ | InverseNameModuleRecompute+ | InverseInScopeRecompute | TopModule TopLevelModuleName+ | CubicalLeftInversion+ -- ^ Generating left inverses in LHS unification in cubical or cubical-compatible mode. | Typeclass QName | Definition QName deriving (Eq, Ord, Show, Generic)@@ -144,13 +153,13 @@ -- | Global variable to store benchmark statistics. {-# NOINLINE benchmarks #-}-benchmarks :: IORef Benchmark-benchmarks = unsafePerformIO $ newIORef empty+benchmarks :: Strict.IORef Benchmark+benchmarks = unsafePerformIO $ Strict.newIORef empty instance MonadBench IO where type BenchPhase IO = Phase- getBenchmark = readIORef benchmarks- putBenchmark = writeIORef benchmarks+ getBenchmark = Strict.readIORef benchmarks+ putBenchmark = Strict.writeIORef benchmarks finally = E.finally -- | Benchmark an IO computation and bill it to the given account.
src/full/Agda/Compiler/Backend.hs view
@@ -46,9 +46,8 @@ import Agda.Utils.CallStack (HasCallStack) import Agda.Utils.FileName-import Agda.Utils.Functor import Agda.Utils.IndexedList-import Agda.Utils.Lens+import Agda.Utils.List import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Maybe@@ -83,10 +82,10 @@ -- | Run a monadic action given an existing backend. -- Throws an error if the user requested an unknown backend. withKnownBackend ::- (MonadTCError m, ReadTCState m) => BackendName -> (Backend -> m ()) -> m ()+ (MonadTCError m) => BackendName -> (Backend -> m ()) -> m () withKnownBackend name k = ifJustM (lookupBackend name) k $ do- backends <- useTC stBackends- let backendSet = otherBackends ++ [ backendName b | Backend b <- backends ]+ backends <- useSession lensBackends+ let backendSet = otherBackends ++! [ backendName b | Backend b <- backends ] typeError $ UnknownBackend name (Set.fromList backendSet) -- | Backends that are not included in the state, but still available@@ -121,14 +120,14 @@ parseBackendOptions backends argv opts0 = case makeAll backendWithOpts backends of Some bs -> do- let agdaFlags = map (embedOpt lSnd) (deadStandardOptions ++ standardOptions)+ let agdaFlags = map' (embedOpt _2) (deadStandardOptions ++! standardOptions) backendFlags = do Some i <- forgetAll Some $ allIndices bs BackendWithOpts b <- [lookupIndex bs i] opt <- commandLineFlags b- return $ embedOpt (lFst . lIndex i . bOptions) opt+ return $ embedOpt (_1 . lIndex i . bOptions) opt (backends, opts) <- getOptSimple (stripRTS argv)- (agdaFlags ++ backendFlags) (embedFlag lSnd . inputFlag)+ (agdaFlags ++! backendFlags) (embedFlag _2 . inputFlag) (bs, opts0) opts <- checkOpts opts return (forgetAll forgetOpts backends, opts)@@ -198,7 +197,7 @@ case r of Skip m -> return m Recompile menv -> do- defs <- map snd . sortDefs <$> curDefs+ defs <- map' snd . sortDefs <$> curDefs res <- mapM (compileDef' backend env menv isMain) defs postModule backend env menv isMain (iTopLevelModuleName i) res
src/full/Agda/Compiler/Backend/Base.hs view
@@ -13,7 +13,7 @@ import Agda.Syntax.Position (Range) import Agda.Interaction.Base (CommandM')-import Agda.Interaction.Options (ArgDescr(..), OptDescr(..), Flag)+import Agda.Interaction.Options (OptDescr, Flag) type BackendVersion = Text @@ -88,15 +88,21 @@ rnf (Backend b) = rnf b instance NFData opts => NFData (Backend'_boot definition tcm opts env menv mod def) where- rnf (Backend' a b c d e f g h i j k l m n) =- rnf a `seq` rnf b `seq` rnf c `seq` rnf' d `seq` rnf e `seq`- rnf f `seq` rnf g `seq` rnf h `seq` rnf i `seq` rnf j `seq`- rnf k `seq` rnf l `seq` rnf m `seq` rnf n- where- rnf' [] = ()- rnf' (Option a b c d : e) =- rnf a `seq` rnf b `seq` rnf'' c `seq` rnf d `seq` rnf' e-- rnf'' (NoArg a) = rnf a- rnf'' (ReqArg a b) = rnf a `seq` rnf b- rnf'' (OptArg a b) = rnf a `seq` rnf b+ rnf (Backend' a b c d e f g h i j k l !m !n) =+ rnf a `seq`+ rnf b `seq`+ rnf c `seq`+ -- Andreas, 2025-07-31, cannot normalize functions with deepseq-1.5.2.0 (GHC 9.10.3).+ -- see https://github.com/haskell/deepseq/issues/111.+ -- rnf d `seq`+ -- rnf e `seq`+ -- rnf f `seq`+ -- rnf g `seq`+ -- rnf h `seq`+ -- rnf i `seq`+ -- rnf j `seq`+ rnf k `seq`+ -- rnf l `seq`+ -- rnf m `seq`+ -- rnf n `seq`+ ()
src/full/Agda/Compiler/Common.hs view
@@ -30,11 +30,13 @@ 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.WithDefault ( lensCollapseDefault )+import Agda.Utils.Tuple.Strict (Pair(..))+import Agda.Utils.Tuple.Strict qualified as Strict+import Agda.Utils.Maybe.Strict qualified as Strict import Agda.Utils.Impossible @@ -69,7 +71,7 @@ alreadyDone <- gets (Set.member (iModuleName i)) if alreadyDone then return mempty else do imps <- lift $- map miInterface . catMaybes <$>+ map' miInterface . catMaybes <$> mapM (getVisitedModule . fst) (iImportedModules i) ri <- mconcat <$> mapM (doCompile' f NotMain) imps lift $ setInterface i@@ -81,14 +83,14 @@ setInterface i = do opts <- getsTC (stPersistentOptions . stPersistentState) setCommandLineOptions opts- mapM_ setOptionsFromPragma (iDefaultPragmaOptions i ++ iFilePragmaOptions i)+ mapM_ setOptionsFromPragma (iDefaultPragmaOptions i ++! iFilePragmaOptions 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'`- Set.fromList (map fst (iImportedModules i))+ Set.fromList (map' fst (iImportedModules i)) stCurrentModule `setTCLens'`- Just (iModuleName i, iTopLevelModuleName i)+ Strict.Just (iModuleName i :!: iTopLevelModuleName i) curIF :: ReadTCState m => m Interface curIF = do@@ -96,7 +98,7 @@ maybe __IMPOSSIBLE__ miInterface <$> getVisitedModule name curMName :: ReadTCState m => m TopLevelModuleName-curMName = maybe __IMPOSSIBLE__ snd <$> useTC stCurrentModule+curMName = Strict.maybe __IMPOSSIBLE__ Strict.snd <$> useTC stCurrentModule curDefs :: ReadTCState m => m Definitions curDefs = HMap.filter (not . defNoCompilation) . (^. sigDefinitions) . iSignature <$> curIF@@ -117,7 +119,7 @@ repl :: [String] -> String -> String repl subs = go where- go ('<':'<':c:'>':'>':s) | 0 <= i && i < length subs = subs !! i ++ go s+ go ('<':'<':c:'>':'>':s) | 0 <= i && i < length subs = subs !! i ++! go s where i = ord c - ord '0' go (c:s) = c : go s go [] = []@@ -154,22 +156,27 @@ -- Unfortunately, a pragma option is stored in the interface file as -- just a list of strings, thus, the solution is a bit of hack: -- We match on whether @["--no-main"]@ is one of the stored options.- let iFilePragmaStrings = map pragmaStrings . iFilePragmaOptions+ let iFilePragmaStrings = map' pragmaStrings . iFilePragmaOptions when (["--no-main"] `elem` iFilePragmaStrings mainI) $ setTCLens (stPragmaOptions . lensOptCompileMain . lensCollapseDefault) False -- Perhaps all pragma options from the top-level module should be -- made available to the compiler in a suitable way. Here are more -- hacks:- when (any ("--cubical" `elem`) $ iFilePragmaStrings mainI) $+ when (any (any (flip elem ["--cubical", "--cubical=full"])) $ iFilePragmaStrings mainI) $ setTCLens (stPragmaOptions . lensOptCubical) $ Just CFull- when (any ("--erased-cubical" `elem`) $ iFilePragmaStrings mainI) $+ when (any (any (flip elem ["--erased-cubical", "--cubical=erased"])) $ iFilePragmaStrings mainI) $ setTCLens (stPragmaOptions . lensOptCubical) $ Just CErased+ when (any ("--cubical=no-glue" `elem`) $ iFilePragmaStrings mainI) $+ setTCLens (stPragmaOptions . lensOptCubical) $ Just CWithoutGlue - setScope (iInsideScope mainI) -- so that compiler errors don't use overly qualified names+ setScope $ iInsideScope mainI -- so that compiler errors don't use overly qualified names+ -- András, 2025-08-30: this is a fresh creation of a scope from an interface+ -- so inverse scopes don't yet exist.+ recomputeInverseScope ignoreAbstractMode cont -- keep generated warnings- let newWarnings = stPostTCWarnings $ stPostScopeState $ s+ let newWarnings = s ^. stTCWarnings stTCWarnings `setTCLens` newWarnings return a @@ -177,11 +184,11 @@ ReadTCState m => ModuleName -> m TopLevelModuleName topLevelModuleName m = do -- Interfaces of visited modules.- visited <- map miInterface . Map.elems <$> getVisitedModules+ visited <- map' miInterface . Map.elems <$> getVisitedModules -- find the module with the longest matching prefix to m let is = sortBy (compare `on` (length . mnameToList . iModuleName)) $- filter (\i -> mnameToList (iModuleName i) `isPrefixOf`- mnameToList m)+ filter' (\i -> mnameToList (iModuleName i) `isPrefixOf`+ mnameToList m) visited case is of (i : _) -> return (iTopLevelModuleName i)
src/full/Agda/Compiler/JS/Compiler.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-binds #-}+ -- | Main module for JS backend. module Agda.Compiler.JS.Compiler where@@ -8,7 +10,7 @@ import Control.Monad.Trans import Data.Char ( isSpace )-import Data.Foldable ( forM_ )+import Data.Foldable ( forM_, foldrM ) import Data.Functor ( (<&>) ) import Data.List ( dropWhileEnd, elemIndex, intercalate, partition ) import Data.Maybe ( listToMaybe )@@ -44,9 +46,7 @@ import Agda.TypeChecking.Monad import Agda.TypeChecking.Reduce ( instantiateFull )-import Agda.TypeChecking.Substitute as TC ( TelV(..), raise, subst ) import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Telescope ( telViewPath ) import Agda.TypeChecking.Warnings ( warning ) import Agda.Utils.FileName ( isNewerThan )@@ -65,22 +65,22 @@ import Agda.Utils.Size (size) import Agda.Compiler.Common as CC-import Agda.Compiler.ToTreeless-import Agda.Compiler.Treeless.EliminateDefaults-import Agda.Compiler.Treeless.EliminateLiteralPatterns-import Agda.Compiler.Treeless.GuardsToPrims-import Agda.Compiler.Treeless.Erase ( computeErasedConstructorArgs, isErasable )-import Agda.Compiler.Treeless.Subst () import Agda.Compiler.Backend (Backend,Backend_boot(..), Backend',Backend'_boot(..), Recompile(..)) +import qualified Agda.Compiler.ToTreeless as T+import qualified Agda.Compiler.Treeless.EliminateDefaults as T+import qualified Agda.Compiler.Treeless.EliminateLiteralPatterns as T+import qualified Agda.Compiler.Treeless.GuardsToPrims as T+import qualified Agda.Compiler.Treeless.Erase as T+import qualified Agda.Compiler.Treeless.Subst as T+ import Agda.Compiler.JS.Syntax- ( Exp(Self,Local,Global,Undefined,Null,String,Char,Integer,Double,Lambda,Object,Array,Apply,Lookup,If,BinOp,PlainJS),- LocalId(LocalId), GlobalId(GlobalId), MemberId(MemberId,MemberIndex), Export(Export), Module(Module, modName, callMain), Comment(Comment),- modName, expName, uses- , JSQName+ ( Exp(Self,Local,Global,Undefined,Null,String,Char,Integer,Double,Lambda,Object,Array,Apply,Lookup,If,BinOp,PlainJS, MemberIdInString, Ternary),+ LocalId(LocalId), GlobalId(GlobalId), MemberId(MemberId, MemberIndex), Export(Export), Module(Module, modName, callMain),+ modName, expName, uses, JSQName ) import Agda.Compiler.JS.Substitution- ( curriedLambda, curriedApply, emp, apply, substShift )+ ( curriedLambda, curriedApply, emp, apply, substShift, subst', subst, shiftFrom) import qualified Agda.Compiler.JS.Pretty as JSPretty import Agda.Compiler.JS.Pretty (JSModuleStyle(..)) @@ -149,9 +149,9 @@ -- Minification is described at https://en.wikipedia.org/wiki/Minification_(programming) , Option [] ["js-minify"] (NoArg enableMin) "minify generated JS code" , Option [] ["js-verify"] (NoArg enableVerify) "except for main module, run generated JS modules through `node` (needs to be in PATH)"- , Option [] ["js-es6"] (NoArg setES6) "use ES6 module style for JS"- , Option [] ["js-cjs"] (NoArg setCJS) "use CommonJS module style (default)"- , Option [] ["js-amd"] (NoArg setAMD) "use AMD module style for JS"+ , Option [] ["js-es6"] (NoArg setES6) "use ES6 module style for JS (recommended)"+ , Option [] ["js-cjs"] (NoArg setCJS) "use CommonJS module style (default) (deprecated)"+ , Option [] ["js-amd"] (NoArg setAMD) "use AMD module style for JS (deprecated)" ] where enable o = pure o{ optJSCompile = True }@@ -167,6 +167,10 @@ jsPreCompile :: JSOptions -> TCM JSOptions jsPreCompile opts = opts <$ do mapM_ (typeError . CubicalCompilationNotSupported) =<< cubicalOption+ case optJSModuleStyle opts of+ JSCJS -> warning $ DeprecationWarning "JavaScript CommonJS module style" (Just "ES6 module style (via --js-es6)") "Agda version 2.10.0"+ JSAMD -> warning $ DeprecationWarning "JavaScript AMD module style" (Just "ES6 module style (via --js-es6)") "Agda version 2.10.0"+ JSES6 -> return () -- | After all modules have been compiled, copy RTE modules and verify compiled modules. @@ -225,9 +229,10 @@ cubical <- cubicalOption let compile = case cubical of -- Code that uses --cubical is not compiled.- Just CFull -> False- Just CErased -> True- Nothing -> True+ Just CFull -> False+ Just CErased -> True+ Just CWithoutGlue -> True+ Nothing -> True ifM uptodate noComp (yesComp compile) where outFile_ = do@@ -277,7 +282,8 @@ jsCompileDef :: JSOptions -> JSModuleEnv -> IsMain -> Definition -> TCM (Maybe Export)-jsCompileDef opts kit _isMain def = definition (opts, kit) (defName def, def)+jsCompileDef opts kit _isMain def = do+ definition (opts, kit) (defName def, def) -------------------------------------------------- -- Naming@@ -322,6 +328,7 @@ case d of Defn { theDef = Constructor { conData = p } } -> do getConstInfo p >>= \case+ -- Lawrence 2026-08-14: TODO: switch to "constructor" now the encoding is changing anyway? -- Andreas, 2020-10-27, comment quotes outdated fact. -- anon. constructors are now M.R.constructor. -- We could simplify/remove the workaround by switching "record"@@ -401,7 +408,7 @@ setCurrentRange r do -- Issue #3545: Warn user about ignored COMPILE pragma for defined functions. getConstInfo q <&> theDef >>= \case- FunctionDefn{} -> whenM (isErasable q) $ warning $ PragmaCompileErased jsBackendName q+ FunctionDefn{} -> whenM (T.isErasable q) $ warning $ PragmaCompileErased jsBackendName q _ -> return() -- If the pragma is not of the form "q = bla", complain. when (listToMaybe (words s) /= Just "=") do@@ -442,12 +449,9 @@ Function{} | otherwise -> do reportSDoc "compile.js" 5 $ "compiling fun:" <+> prettyTCM q- let mTreeless = toTreeless T.EagerEvaluation q- caseMaybeM mTreeless (pure Nothing) $ \ treeless -> do+ let mTreeless = T.toTreeless T.EagerEvaluation q+ caseMaybeM mTreeless (pure Nothing) $ \ funBody -> do used <- fromMaybe [] <$> getCompiledArgUse q- funBody <- eliminateCaseDefaults =<<- eliminateLiteralPatterns- (convertGuards treeless) reportSDoc "compile.js" 30 $ " compiled treeless fun:" <+> pretty funBody reportSDoc "compile.js" 40 $ " argument usage:" <+> (text . show) used @@ -469,32 +473,30 @@ plainJS $ "agdaRTS." ++ getBuiltinId p | Just e <- defJSDef d -> plainJS e- | otherwise ->+ | p `Set.member` undefinedPrimitives -> ret Undefined+ | otherwise -> do+ warning $ UnknownJSPrimitive $ getBuiltinId p+ ret Undefined PrimitiveSort{} -> return Nothing Datatype{} -> do- computeErasedConstructorArgs q+ T.computeErasedConstructorArgs q ret emp Record{} -> do- computeErasedConstructorArgs q+ T.computeErasedConstructorArgs q return Nothing Constructor{} | Just e <- defJSDef d -> plainJS e- -- Implements Scott-Encoding of constructor definitions+ -- Encode constructor definitions to JS functions that construct Tagged Arrays -- (see the note "Implementing data types")- Constructor{conData = p, conPars = nc} -> do- TelV tel _ <- telViewPath t- let nargs = length (telToList tel) - nc- args = [ Local $ LocalId $ nargs - i | i <- [0 .. nargs-1] ]- d <- getConstInfo p+ Constructor+ { conArity = conArity -- Number of fields stored in the constructor+ } -> do let l = List1.last ls ret- $ curriedLambda nargs- $ (case theDef d of- Record {} -> Object . Map.singleton l- dt -> id)- $ Lambda 1 $ Apply (Lookup (Local (LocalId 0)) l) args+ $ curriedLambda conArity+ $ Array $ MemberIdInString l : [Local (LocalId i) | i <- reverse [0..conArity-1]] AbstractDefn{} -> __IMPOSSIBLE__ where@@ -504,52 +506,64 @@ -- Implementing data types -------------------------- --- Data types are implemented using a variant of Scott Encoding,--- which uses JavaScript dicts instead of some lambda-expressions-+-- Data constructors are compiled to arrays where the 0th element is a string tag.+-- Such arrays are called 'Tagged Arrays'+-- -- For example, given the data type ----- data Foo : Set where--- c1 : Foo--- c2 : X -> Y -> Foo--- c3 : Foo -> Foo+-- data Foo (A : Set) : Set where+-- c1 : Foo A+-- c2 : X -> Y -> Foo A+-- c3 : Foo A -> Foo A -- -- here is how "Foo" is compiled: -- -- * A constructor definition, e.g. ----- c2 : X -> Y -> Foo+-- c2 : X -> Y -> Foo A -- -- compiles to ----- exports["Foo"]["c2"] = x => y => k => k["c2"](x,y)+-- exports["Foo"]["c2"] = x => y => ["c2", x, y] --+-- notice how the data-type parameter A does not become a parameter of the constructor c2.+-- Nor do any module parameters.+-- -- * A constructor application, e.g. ----- c2 x y+-- c2 E1 E2 -- -- compiles to ----- exports["Foo"]["c2"](x)(y)+-- exports["Foo"]["c2"](E1)(E2) -- -- * A case split, e.g. -- -- case p of -- (c1 ) -> E1--- (c2 x y) -> E2--- (c3 f ) -> E3+-- (c2 x y) -> E2 (where E2 = ...x ... y ...)+-- (c3 f ) -> E3 (where E3 = ... f ... ) -- -- compiles to ----- p(--- { "c1": () => E1--- , "c2": (x,y) => E2--- , "c3": f => E3--- })-+-- (p[0] == "c1") ? E1+-- : (p[0] == "c2") ? E2 (where E2 = ... p[1] ... p[2] ...)+-- : (p[0] == "c3") ? E3 (where E3 = ... p[1] ... )+-- : undefined+--+-- unless a there is a {-# COMPILE JS Foo = <split> #-} pragma,+-- in which case this case split compiles to+--+-- <split>+-- { "c1": () => E1+-- , "c2": (x,y) => E2 (where E2 = ... x ... y ... )+-- , "c3": (f) => E3 (where E3 = ... f ...)+-- }+--+-- Record types are compiled like single-argument data types compileTerm :: EnvWithOpts -> T.TTerm -> TCM Exp-compileTerm kit t = go t+compileTerm kit = go where go :: T.TTerm -> TCM Exp go = \case@@ -577,36 +591,35 @@ [(flatName, PlainJS evalThunk) ,(MemberId "__flat_helper", Lambda 0 x)] T.TApp t xs -> do+ -- Lawrence 2026-08: evaluating version hangs on Issue7595:+ -- curriedApply' <$> go t <*> mapM go xs curriedApply <$> go t <*> mapM go xs T.TLam t -> Lambda 1 <$> go t+ T.TLet T.Strict t e -> do+ t' <- go t+ e' <- go e+ return $ Apply (Lambda 1 e') [t'] -- `let x = t in e` is compiled to `(x => e[x()/x])(() => t)` so that `t` -- is only evaluated inside the body- T.TLet t e -> do+ T.TLet T.NonStrict t e -> do t' <- Lambda 0 <$> go t e' <- substShift 1 1 [Apply (Local (LocalId 0)) []] <$> go e return $ Apply (Lambda 1 e') [t'] T.TLit l -> return $ literal l- -- Implements Scott-Encoding of constructor applications+ -- Encode constructor applications to Tagged Arrays -- (see the note "Implementing data types") T.TCon q -> qname q- -- Implements Scott-Encoding of case splits- -- (see the note "Implementing data types")- T.TCase sc ct def alts | T.CTData dt <- T.caseType ct -> do- dt <- getConstInfo dt- alts' <- traverse (compileAlt kit) alts- let cs = defConstructors $ theDef dt- obj = Object $ Map.fromListWith __IMPOSSIBLE__ alts'- case (theDef dt, defJSDef dt) of- (_, Just e) -> do- return $ apply (PlainJS e) [Local (LocalId sc), obj]- (Record{}, _) -> do- memId <- visitorName $ recCon $ theDef dt- return $ apply (Lookup (Local $ LocalId sc) memId) [obj]- (Datatype{}, _) -> do- return $ curriedApply (Local (LocalId sc)) [obj]- _ -> __IMPOSSIBLE__- T.TCase _ _ _ _ -> __IMPOSSIBLE__-+ t@(T.TCase sc ci@(T.CaseInfo{caseType = T.CTData dt}) def alts) -> do+ pragma <- defJSDef <$> getConstInfo dt+ let isReachable = not (T.isUnreachable def)+ case (pragma, isReachable) of+ -- Recursive case (COMPILE JS pragma present, inexhaustive match): make exhautive & try again+ (Just _, True) -> go =<< T.eliminateCaseDefaultAtTopLevelIfPresent t+ -- Base case (COMPILE JS pragma present, all cases handled): emit call to pragma+ (Just e, False) -> compileCaseWithPragma e kit sc alts+ -- Base case (no COMPILE JS pragma): compile as usual+ (Nothing, _) -> compileCaseNoPragma kit sc def alts+ T.TCase sc ci def alts -> compileCaseNoPragma kit sc def alts T.TPrim p -> return $ compilePrim p T.TUnit -> unit T.TSort -> unit@@ -615,18 +628,60 @@ T.TError T.TMeta{} -> return Undefined T.TCoerce t -> go t - getDef (T.TDef f) = Just (Left f)- getDef (T.TCon c) = Just (Right c)- getDef (T.TCoerce x) = getDef x- getDef _ = Nothing- unit = return Null - mkArray xs- | 2 * length (filter ((== Null) . snd) xs) <= length xs = Array xs- | otherwise = Object $ Map.fromListWith __IMPOSSIBLE__- [ (MemberIndex i c, x) | (i, (c, x)) <- zip [0..] xs, x /= Null ]+-- Compiles a case split, without consulting any COMPILE JS pragmas+-- Returns a chain of ternary expressions+-- (see the note "Implementing data types")+compileCaseNoPragma :: EnvWithOpts -> Int -> T.TTerm -> [T.TAlt] -> TCM Exp+compileCaseNoPragma kit sc def alts = do+ def' <- compileTerm kit def+ foldrM (compileAlt kit sc) def' alts +-- Compile a case split, using a COMPILE JS pragma on the data type.+-- Precondition: cases present for all constructors of data type+-- Returns a call to the pragma+-- (see the note "Implementing data types")+compileCaseWithPragma :: String -> EnvWithOpts -> Int -> [T.TAlt] -> TCM Exp+compileCaseWithPragma pragmaContents kit sc alts = do+ let scrutinee = Local (LocalId sc)+ alts' <- alts & traverse \case+ T.TACon con nargs body -> do+ mid <- visitorName con+ body <- Lambda nargs <$> compileTerm kit body+ return (mid, body)+ _ -> __IMPOSSIBLE__+ return $ apply (PlainJS pragmaContents) [scrutinee, Object $ Map.fromListWith __IMPOSSIBLE__ alts']++-- Compiles a single treeless alternative (+ default case),+-- to a Ternary expression (see the note "Implementing data types")+compileAlt :: EnvWithOpts -> Int -> T.TAlt -> Exp -> TCM Exp+compileAlt kit sc (T.TACon {aCon = aCon, aArity = aArity, aBody = aBody}) def = do+ let scrutinee = Local (LocalId sc)+ body <- compileTerm kit aBody+ -- Lawrence 2026-08: evaluating versions hang on Issue7595:+ -- let body' = shiftFrom aArity 0 $ subst' aArity [Lookup scrutinee (MemberIndex i) | i <- [1 .. aArity]] body+ -- let body' = curriedApply' (curriedLambda aArity body) [Lookup scrutinee (MemberIndex i) | i <- [1 .. aArity]]+ -- but non-evalauting versions OK:+ -- let body' = curriedApply (curriedLambda aArity body) [Lookup scrutinee (MemberIndex i) | i <- [1 .. aArity]]+ let body' = shiftFrom aArity 0 $ subst aArity [Lookup scrutinee (MemberIndex i) | i <- [1 .. aArity]] body+ mid <- visitorName aCon+ pure $ Ternary (BinOp (Lookup scrutinee (MemberIndex 0)) "==" (MemberIdInString mid)) body' def+compileAlt kit _ (T.TAGuard {aGuard = aGuard, aBody = aBody}) def = do+ guard <- compileTerm kit aGuard+ body <- compileTerm kit aBody+ pure $ Ternary guard body def+compileAlt kit sc (T.TALit {aLit = LitQName q, aBody = aBody}) def = do+ let scrutinee = Local (LocalId sc)+ body <- compileTerm kit aBody+ pure $ Ternary (BinOp (Lookup scrutinee (MemberId "name")) "==" (String $ T.pack $ prettyShow q)) body def+-- Lawrence 2026-08: I suspect the lack of special case for LitMeta is buggy,+-- but it does not break the existing tests+compileAlt kit sc (T.TALit {aLit = aLit, aBody = aBody}) def = do+ let scrutinee = Local (LocalId sc)+ body <- compileTerm kit aBody+ pure $ Ternary (BinOp scrutinee "==" (literal aLit)) body def+ compilePrim :: T.TPrim -> Exp compilePrim p = case p of@@ -657,16 +712,6 @@ unOp js = curriedLambda 1 $ apply (PlainJS js) [local 0] primEq = curriedLambda 2 $ BinOp (local 1) "===" (local 0) --- Implements Scott-Encoding of case split cases--- (see the note "Implementing data types")-compileAlt :: EnvWithOpts -> T.TAlt -> TCM (MemberId, Exp)-compileAlt kit = \case- T.TACon con nargs body -> do- memId <- visitorName con- body <- Lambda nargs <$> compileTerm kit body- return (memId, body)- _ -> __IMPOSSIBLE__- visitorName :: QName -> TCM MemberId visitorName q = List1.last . snd <$> global q @@ -700,7 +745,7 @@ , (mem "fixity", litfixity fx)] where mem = MemberId- NameId n (ModuleNameHash m) = nameId $ qnameName q+ NameId n (ModuleNameHash m) = nameId q fx = theFixity $ nameFixity $ qnameName q litfixity :: Fixity -> Exp@@ -742,11 +787,6 @@ return fp -- | Primitives implemented in the JS Agda RTS.------ TODO: Primitives that are not part of this set, and for which--- 'defJSDef' does not return anything, are silently compiled to--- 'Undefined'. A better approach might be to list exactly those--- primitives which should be compiled to 'Undefined'. primitives :: Set PrimitiveId primitives = Set.fromList [ PrimShowInteger@@ -815,20 +855,20 @@ , PrimFloatPow -- Character functions- -- , PrimCharEquality -- missing- -- , PrimIsLower -- missing- -- , PrimIsDigit -- missing- -- , PrimIsAlpha -- missing- -- , PrimIsSpace -- missing- -- , PrimIsAscii -- missing- -- , PrimIsLatin1 -- missing- -- , PrimIsPrint -- missing- -- , PrimIsHexDigit -- missing- -- , PrimToUpper -- missing- -- , PrimToLower -- missing- -- , PrimCharToNat -- missing+ -- , PrimCharEquality -- in Agda.Builtin.Char+ -- , PrimIsLower -- in Agda.Builtin.Char+ -- , PrimIsDigit -- in Agda.Builtin.Char+ -- , PrimIsAlpha -- in Agda.Builtin.Char+ -- , PrimIsSpace -- in Agda.Builtin.Char+ -- , PrimIsAscii -- in Agda.Builtin.Char+ -- , PrimIsLatin1 -- in Agda.Builtin.Char+ -- , PrimIsPrint -- in Agda.Builtin.Char+ -- , PrimIsHexDigit -- in Agda.Builtin.Char+ -- , PrimToUpper -- in Agda.Builtin.Char+ -- , PrimToLower -- in Agda.Builtin.Char+ -- , PrimCharToNat -- in Agda.Builtin.Char -- , PrimCharToNatInjective -- missing- -- , PrimNatToChar -- missing+ -- , PrimNatToChar -- in Agda.Builtin.Char -- , PrimShowChar -- in Agda.Builtin.String -- String functions@@ -856,6 +896,7 @@ , PrimShowMeta , PrimMetaToNat -- , PrimMetaToNatInjective -- missing+ , PrimQrec , builtinIMin , builtinIMax , builtinINeg@@ -872,4 +913,78 @@ -- , builtinGlue -- missing -- , builtin_glue -- missing -- , builtin_unglue -- missing+ ]++-- | Primitives that are intentionally compiled to @Undefined@ by the+-- JS backend (e.g. because they are erased, they are type-level only,+-- or they are implemented in Agda). Any primitive not in 'primitives',+-- 'undefinedPrimitives', or handled via 'defJSDef' will trigger an+-- 'UnknownJSPrimitive' warning.+undefinedPrimitives :: Set PrimitiveId+undefinedPrimitives = Set.fromList+ [ -- Natural number functions+ PrimNatPlus+ , PrimNatTimes+ , PrimNatDivSucAux+ , PrimNatModSucAux+ , PrimNatEquality+ , PrimNatLess+ , PrimShowNat++ -- Machine words+ , PrimWord64ToNatInjective++ -- Level functions+ , PrimLevelZero+ , PrimLevelSuc+ , PrimLevelMax++ -- Floating point functions (implemented in Agda.Builtin.Float)+ , PrimFloatRound+ , PrimFloatFloor+ , PrimFloatCeiling+ , PrimFloatToRatio+ , PrimFloatDecode+ , PrimFloatEncode+ , PrimFloatToWord64Injective++ -- Character functions (implemented in Agda.Builtin.Char)+ , PrimCharEquality+ , PrimIsLower+ , PrimIsDigit+ , PrimIsAlpha+ , PrimIsSpace+ , PrimIsAscii+ , PrimIsLatin1+ , PrimIsPrint+ , PrimIsHexDigit+ , PrimToUpper+ , PrimToLower+ , PrimCharToNat+ , PrimCharToNatInjective+ , PrimNatToChar+ , PrimShowChar++ -- String functions (implemented in Agda.Builtin.String)+ , PrimStringToList+ , PrimStringToListInjective+ , PrimStringFromList+ , PrimStringFromListInjective+ , PrimStringAppend+ , PrimStringEquality+ , PrimShowString+ , PrimStringUncons++ -- Other+ , PrimEraseEquality+ , PrimForce+ , PrimForceLemma+ , PrimQNameToWord64s+ , PrimQNameToWord64sInjective+ , PrimMetaToNatInjective++ -- Cubical (missing)+ , builtinGlue+ , builtin_glue+ , builtin_unglue ]
src/full/Agda/Compiler/JS/Pretty.hs view
@@ -5,7 +5,6 @@ import Data.Char ( isAsciiLower, isAsciiUpper, isDigit ) import Data.List ( intercalate ) import Data.String ( IsString (fromString) )-import Data.Semigroup ( Semigroup, (<>) ) import Data.Set ( Set, toList, insert, member ) import qualified Data.Set as Set import Data.Map ( Map, toAscList )@@ -247,12 +246,7 @@ instance Pretty MemberId where pretty _ (MemberId s) = "\"" <> unescapes s <> "\""- pretty n (MemberIndex i comment) = text (show i) <> pretty n comment--instance Pretty Comment where- pretty _ (Comment "") = mempty- pretty (_, True, _) _ = mempty- pretty _ (Comment s) = text $ "/* " ++ s ++ " */"+ pretty n (MemberIndex i) = text (show i) -- Pretty print expressions @@ -264,20 +258,22 @@ prettyPrec p n (Null) = "null" prettyPrec p n (String s) = "\"" <> unescapes (T.unpack s) <> "\"" prettyPrec p n (Char c) = "\"" <> unescapes [c] <> "\""- prettyPrec p n (Integer x) = "agdaRTS.primIntegerFromString(\"" <> text (show x) <> "\")"+ prettyPrec p n (Integer x) = text (show x) <> "n" prettyPrec p n (Double x) = text $ show x prettyPrec p (n, min, ms) (Lambda x e) = mparens (p > 2) $ mparens (x /= 1) (punctuate "," (pretties (n + x, min, ms) (map LocalId [x-1, x-2 .. 0]))) <+> "=>" <+> block (n + x, min, ms) e prettyPrec p n (Object o) = braces $ punctuate "," $ pretties n o- prettyPrec p n (Array es) = brackets $ punctuate "," [pretty n c <> pretty n e | (c, e) <- es]+ prettyPrec p n (Array es) = brackets $ punctuate "," [pretty n e | e <- es]+ prettyPrec p n (MemberIdInString mid) = pretty n mid+ prettyPrec p n (Ternary eCond eThen eElse) = (prettyPrec 17 n eCond <+> text "?" <+> prettyPrec 17 n eThen)+ $+$ text ":" <+> prettyPrec 17 n eElse prettyPrec p n (Apply f es) = prettyPrec 17 n f <> parens (punctuate "," $ pretties n es) prettyPrec p n (Lookup e l) = prettyPrec 17 n e <> brackets (pretty n l) prettyPrec p n (If e f g) = mparens (p > 2) $ prettyPrec 3 n e <> "?" <+> prettyPrec 3 n f <> ":" <+> prettyPrec 2 n g prettyPrec p n (PreOp op e) = parens $ text op <> " " <> prettyPrec 17 n e prettyPrec p n (BinOp e op f) = parens $ prettyPrec 17 n e <> " " <> text op <> " " <> prettyPrec 17 n f- prettyPrec p n (Const c) = text c prettyPrec p n (PlainJS js) = text js block :: (Nat, Bool, JSModuleStyle) -> Exp -> Doc
src/full/Agda/Compiler/JS/Substitution.hs view
@@ -3,28 +3,39 @@ import Prelude hiding ( map, lookup ) import Data.Map ( empty, unionWith, singleton, findWithDefault ) import qualified Data.Map as Map-import Data.List ( genericIndex )+import Data.Maybe ( fromMaybe ) import qualified Data.List as List import Agda.Syntax.Common ( Nat ) import Agda.Compiler.JS.Syntax- ( Exp(Self,Undefined,Local,Lambda,Object,Array,Apply,Lookup,If,BinOp,PreOp),+ ( Exp(..), MemberId, LocalId(LocalId) ) import Agda.Utils.Function ( iterate' )+import Agda.Utils.List ( (!!!) ) -- Map for expressions map :: Nat -> (Nat -> LocalId -> Exp) -> Exp -> Exp+map m f (Self) = Self map m f (Local i) = f m i+map m f (Global g) = Global g+map m f (Undefined) = Undefined+map m f (Null) = Null+map m f (String s) = String s+map m f (Char c) = Char c+map m f (Integer i) = Integer i+map m f (Double d) = Double d map m f (Lambda i e) = Lambda i (map (m + i) f e) map m f (Object o) = Object (Map.map (map m f) o)-map m f (Array es) = Array (List.map (\(c, e) -> (c, map m f e)) es)+map m f (Array es) = Array (List.map (map m f) es)+map m f (MemberIdInString mid) = MemberIdInString mid+map m f (Ternary e1 e2 e3) = Ternary (map m f e1) (map m f e2) (map m f e3) map m f (Apply e es) = Apply (map m f e) (List.map (map m f) es) map m f (Lookup e l) = Lookup (map m f e) l map m f (If e e' e'') = If (map m f e) (map m f e') (map m f e'') map m f (PreOp op e) = PreOp op (map m f e) map m f (BinOp e op e') = BinOp (map m f e) op (map m f e')-map m f e = e+map m f (PlainJS str) = PlainJS str -- Shifting @@ -47,7 +58,7 @@ substituter :: Nat -> [Exp] -> Nat -> LocalId -> Exp substituter n es m (LocalId i) | i < m = Local (LocalId i)-substituter n es m (LocalId i) | (i - m) < n = shift m (genericIndex (es ++ repeat Undefined) (n - (i + 1 - m)))+substituter n es m (LocalId i) | (i - m) < n = shift m $ fromMaybe Undefined $ es !!! (n - (i + 1 - m)) substituter n es m (LocalId i) | otherwise = Local (LocalId (i - n)) substShift :: Nat -> Nat -> [Exp] -> Exp -> Exp@@ -56,17 +67,28 @@ -- A variant on substitution which performs beta-reduction map' :: Nat -> (Nat -> LocalId -> Exp) -> Exp -> Exp+map' m f (Self) = Self map' m f (Local i) = f m i+map' m f (Global g) = Global g+map' m f (Undefined) = Undefined+map' m f (Null) = Null+map' m f (String s) = String s+map' m f (Char c) = Char c+map' m f (Integer i) = Integer i+map' m f (Double d) = Double d map' m f (Lambda i e) = Lambda i (map' (m + i) f e) map' m f (Object o) = Object (Map.map (map' m f) o)-map' m f (Array es) = Array (List.map (\(c, e) -> (c, map' m f e)) es)+map' m f (Array es) = Array (List.map (map' m f) es)+map' m f (MemberIdInString mid) = MemberIdInString mid+map' m f (Ternary e1 e2 e3) = Ternary (map' m f e1) (map' m f e2) (map' m f e3) map' m f (Apply e es) = apply (map' m f e) (List.map (map' m f) es) map' m f (Lookup e l) = lookup (map' m f e) l map' m f (If e e' e'') = If (map' m f e) (map' m f e') (map' m f e'') map' m f (PreOp op e) = PreOp op (map' m f e) map' m f (BinOp e op e') = BinOp (map' m f e) op (map' m f e')-map' m f e = e+map' m f (PlainJS str) = PlainJS str + subst' :: Nat -> [Exp] -> Exp -> Exp subst' 0 es e = e subst' n es e = map' 0 (substituter n es) e@@ -90,7 +112,7 @@ self :: Exp -> Exp -> Exp self e (Self) = e self e (Object o) = Object (Map.map (self e) o)-self e (Array es) = Array (List.map (\(c, x) -> (c, self e x)) es)+self e (Array es) = Array (List.map (self e) es) self e (Apply f es) = case (self e f) of (Lambda n g) -> self e (subst' n es g) g -> Apply g (List.map (self e) es)@@ -109,20 +131,13 @@ -- Some helper functions curriedApply :: Exp -> [Exp] -> Exp-curriedApply = foldl (\ f e -> apply f [e])+curriedApply = foldl (\ f e -> Apply f [e]) +curriedApply' :: Exp -> [Exp] -> Exp+curriedApply' = foldl (\ f e -> apply f [e])+ curriedLambda :: Nat -> Exp -> Exp curriedLambda n = iterate' n (Lambda 1) emp :: Exp emp = Object (empty)--union :: Exp -> Exp -> Exp-union (Object o) (Object p) = Object (unionWith union o p)-union e f = e--vine :: [MemberId] -> Exp -> Exp-vine ls e = foldr (\ l e -> Object (singleton l e)) e ls--object :: [([MemberId],Exp)] -> Exp-object = foldr (\ (ls,e) -> (union (vine ls e))) emp
src/full/Agda/Compiler/JS/Syntax.hs view
@@ -4,7 +4,6 @@ import Data.Map (Map) import Data.Set (Set) import qualified Data.Set as Set-import Data.Semigroup ( Semigroup ) import Data.Text (Text) @@ -28,15 +27,21 @@ Double Double | Lambda Nat Exp | Object (Map MemberId Exp) |- Array [(Comment, Exp)] |+ Array [Exp] |+ MemberIdInString MemberId |+ Ternary Exp Exp Exp | Apply Exp [Exp] | Lookup Exp MemberId | If Exp Exp Exp | BinOp Exp String Exp | PreOp String Exp |- Const String | PlainJS String -- ^ Arbitrary JS code. deriving (Show, Eq)+-- Code style:+-- All recursive Exp-traversing functions should list every constructor explicitly.+-- Do not write a catch-all case to cover all the trivial constructors.+-- This policy helps catch subtle bugs (randomly failing substitution, missing imports etc.)+-- due to newly-added constructors silently hitting the catch-all case. -- Local identifiers are named by De Bruijn indices. -- Global identifiers are named by string lists.@@ -50,15 +55,9 @@ data MemberId = MemberId String- | MemberIndex Int Comment+ | MemberIndex Int deriving (Eq, Ord, Show) -newtype Comment = Comment String- deriving (Show, Semigroup, Monoid)--instance Eq Comment where _ == _ = True-instance Ord Comment where compare _ _ = EQ- -- The top-level compilation unit is a module, which names -- the GId of its exports, and a list of definitions @@ -95,12 +94,23 @@ instance (Uses a, Uses b, Uses c) => Uses (a, b, c) where uses (a, b, c) = uses a `Set.union` uses b `Set.union` uses c -instance Uses Comment where- uses _ = Set.empty- instance Uses Exp where+ uses (Self) = Set.empty+ uses (Local _) = Set.empty+ uses (Global _) = Set.empty+ uses (Undefined) = Set.empty+ uses (Null) = Set.empty+ uses (String _) = Set.empty+ uses (Integer _) = Set.empty+ uses (Char _) = Set.empty+ uses (Double _) = Set.empty+ uses (Lambda n _) = Set.empty+ -- Lawrence 2026-08: I suspect returning Set.empty for lambdas is a bug,+ -- but it does not break existing tests uses (Object o) = uses o uses (Array es) = uses es+ uses (MemberIdInString mid) = Set.empty -- special case of string literals+ uses (Ternary e1 e2 e3) = Set.unions [uses e1, uses e2, uses e3] uses (Apply e es) = uses (e, es) uses (Lookup e l) = uses' e (List1.singleton l) where@@ -111,7 +121,7 @@ uses (If e f g) = uses (e, f, g) uses (BinOp e op f) = uses (e, f) uses (PreOp op e) = uses e- uses e = Set.empty+ uses (PlainJS _) = Set.empty instance Uses Export where uses (Export _ e) = uses e@@ -134,20 +144,27 @@ instance (Globals a, Globals b, Globals c) => Globals (a, b, c) where globals (a, b, c) = globals a `Set.union` globals b `Set.union` globals c -instance Globals Comment where- globals _ = Set.empty- instance Globals Exp where+ globals (Self) = Set.empty+ globals (Local _) = Set.empty globals (Global i) = Set.singleton i+ globals (Undefined) = Set.empty+ globals (Null) = Set.empty+ globals (String _) = Set.empty+ globals (Integer _) = Set.empty+ globals (Char _) = Set.empty+ globals (Double _) = Set.empty globals (Lambda n e) = globals e globals (Object o) = globals o globals (Array es) = globals es+ globals (MemberIdInString _) = Set.empty --special case of string literals+ globals (Ternary e1 e2 e3) = Set.unions [globals e1, globals e2, globals e3] globals (Apply e es) = globals (e, es) globals (Lookup e l) = globals e globals (If e f g) = globals (e, f, g) globals (BinOp e op f) = globals (e, f) globals (PreOp op e) = globals e- globals _ = Set.empty+ globals (PlainJS _) = Set.empty instance Globals Export where globals (Export _ e) = globals e
src/full/Agda/Compiler/MAlonzo/Coerce.hs view
@@ -40,7 +40,7 @@ then TApp (TCoerce f) <$> mapM softCoerce vs else TCoerce . TApp f <$> mapM coerce vs TLam b -> TCoerce . TLam <$> softCoerce b- TLet e b -> TLet <$> softCoerce e <*> coerce b+ TLet s e b -> TLet s <$> softCoerce e <*> coerce b TCase x t d bs -> TCase x t <$> coerce d <*> mapM coerceAlt bs coerceAlt (TACon c a b) = TACon c a <$> coerce b@@ -67,7 +67,7 @@ then TApp (TCoerce f) <$> mapM softCoerce vs else TApp f <$> mapM coerce vs TLam b -> TLam <$> softCoerce b- TLet e b -> TLet <$> softCoerce e <*> softCoerce b+ TLet s e b -> TLet s <$> softCoerce e <*> softCoerce b TCase x t d bs -> TCase x t <$> coerce d <*> mapM coerceAlt bs funArity :: HasConstInfo m => TTerm -> m Nat
src/full/Agda/Compiler/MAlonzo/Compiler.hs view
@@ -5,11 +5,12 @@ ) where -import Control.Arrow (second)+import Prelude hiding ( zip, zipWith )+ import Control.DeepSeq import Control.Monad.Except ( throwError ) import Control.Monad.IO.Class ( MonadIO(..) )-import Control.Monad.Reader ( MonadReader(..), asks, ReaderT, runReaderT, withReaderT)+import Control.Monad.Reader ( MonadReader(..), asks, ReaderT, runReaderT, withReaderT ) import Control.Monad.Trans ( lift ) import Control.Monad.Writer ( MonadWriter(..), WriterT, runWriterT ) @@ -23,12 +24,9 @@ import Data.Text (Text) import qualified Data.Text as Text import Data.Monoid (Monoid, mempty, mappend)-import Data.Semigroup ((<>)) import GHC.Generics (Generic) -import qualified Agda.Utils.Haskell.Syntax as HS- import System.Directory (createDirectoryIfMissing) import System.Environment (setEnv) import System.FilePath hiding (normalise)@@ -69,14 +67,18 @@ import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.Float+import qualified Agda.Utils.Haskell.Syntax as HS import Agda.Utils.IO.Directory import Agda.Utils.Lens import Agda.Utils.List import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.ListInf as ListInf import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Singleton+import Agda.Utils.Tuple (second) import qualified Agda.Utils.IO.UTF8 as UTF8+import Agda.Utils.Zip import Agda.Setup ( getDataDir ) @@ -117,6 +119,8 @@ -- ^ Make inductive constructors strict? , flagGhcStrict :: Bool -- ^ Make functions strict?+ , flagGhcTrace :: Bool+ -- ^ Print function name upon entry using 'Debug.Trace.trace'? } deriving Generic @@ -130,6 +134,7 @@ , flagGhcFlags = [] , flagGhcStrictData = False , flagGhcStrict = False+ , flagGhcTrace = False } -- | The option to activate the GHC backend.@@ -154,6 +159,8 @@ "make inductive constructors strict" , Option [] ["ghc-strict"] (NoArg strict) "make functions strict"+ , Option [] ["ghc-trace"] (NoArg trace)+ "instrument code to debug print trace of function calls" ] where dontCallGHC o = pure o{ flagGhcCallGhc = False }@@ -162,6 +169,7 @@ strict o = pure o{ flagGhcStrictData = True , flagGhcStrict = True }+ trace o = pure o{ flagGhcTrace = True } withCompilerFlag :: FilePath -> Flag GHCFlags withCompilerFlag fp o = case flagGhcBin o of@@ -220,8 +228,9 @@ ghcPreCompile :: GHCFlags -> TCM GHCEnv ghcPreCompile flags = do whenJustM cubicalOption \case- CErased -> pure ()- CFull -> typeError $ CubicalCompilationNotSupported CFull+ CWithoutGlue -> pure ()+ CErased -> pure ()+ CFull -> typeError $ CubicalCompilationNotSupported CFull outDir <- compileDir let ghcOpts = GHCOptions@@ -231,6 +240,7 @@ , optGhcCompileDir = outDir , optGhcStrictData = flagGhcStrictData flags , optGhcStrict = flagGhcStrict flags+ , optGhcTrace = flagGhcTrace flags } mbool <- getBuiltinName builtinBool@@ -381,9 +391,10 @@ cubical <- cubicalOption case cubical of -- Code that uses --cubical is not compiled.- Just CFull -> noComp- Just CErased -> check- Nothing -> check)+ Just CFull -> noComp+ Just CErased -> check+ Just CWithoutGlue -> check+ Nothing -> check) `runReaderT` GHCModuleEnv cenv (HsModuleEnv m (isMain == IsMain)) where uptodate = case mifile of@@ -413,81 +424,76 @@ -> TopLevelModuleName -> [GHCDefinition] -- ^ Compiled module content. -> TCM GHCModule-ghcPostModule _cenv menv _isMain _moduleName ghcDefs = do+ghcPostModule cenv menv _isMain _moduleName ghcDefs = do builtinThings <- getsTC stBuiltinThings+ i <- curIF - -- Accumulate all of the modules, definitions, declarations, etc.- let (usedFloat, decls, defs, mainDefs, usedModules) = mconcat $- (\(GHCDefinition useFloat' decls' def' md' imps')- -> (useFloat', decls', [def'], maybeToList md', imps'))- <$> ghcDefs+ let+ -- Accumulate all of the modules, definitions, declarations, etc.+ (usedFloat, decls, defs, mainDefs, usedModules) = mconcat $ ghcDefs <&>+ \ (GHCDefinition useFloat' decls' def' md' imps') ->+ (useFloat', decls', [def'], maybeToList md', imps') - let imps = mazRTEFloatImport usedFloat ++ imports builtinThings usedModules defs+ -- Builtins used in the definitions.+ actuallyUsedBuiltins = usedBuiltins builtinThings defs+ useBuiltinFloat = any (`Set.member` actuallyUsedBuiltins) floatBuiltins+ useBuiltinChar = any (`Set.member` actuallyUsedBuiltins) charBuiltins - i <- curIF+ -- Get content of FOREIGN pragmas.+ (headerPragmas, hsImps, code) = foreignHaskell i - -- Get content of FOREIGN pragmas.- let (headerPragmas, hsImps, code) = foreignHaskell i+ -- MAlonzo.* imports+ mazImports :: [HS.ImportDecl]+ mazImports = concat+ [ rteImports+ , mazRTEFloatImport (usedFloat <> UsesFloat useBuiltinFloat)+ , moduleImports usedModules+ ] + -- Other imports, from FOREIGN pragmas and builtins.+ -- The needed Haskell modules might be duplicated by FOREIGN imports+ -- so we render them as strings and merge them with the latter,+ -- to remove duplicates.+ haskellImports :: [GHCImport]+ haskellImports = Set.toAscList $ Set.union hsImps $ Set.fromList $ map prettyPrint $ concat+ [ [ hsImportDebugTrace | optGhcTrace (ghcEnvOpts cenv) ]+ , [ HS.qualifiedImport $ HS.ModuleName "Data.Char" | useBuiltinChar ]+ , [ HS.qualifiedImport $ HS.ModuleName "Data.Text" ]+ ]+ flip runReaderT menv $ do hsModuleName <- curHsMod writeModule $ HS.Module hsModuleName- (map HS.OtherPragma $ List.nub headerPragmas)- imps- (map fakeDecl (List.nub hsImps ++ code) ++ decls)+ (map HS.OtherPragma $ Set.toAscList headerPragmas)+ -- The MAlonzo.Code modules make proper import declarations in the AST.+ mazImports+ -- The other imports are already rendered to strings.+ (map fakeDecl (haskellImports ++ code) ++ decls) return $ GHCModule menv mainDefs -ghcCompileDef :: GHCEnv -> GHCModuleEnv -> IsMain -> Definition -> TCM GHCDefinition-ghcCompileDef _cenv menv _isMain def = do- ((usesFloat, decls, mainFuncDef), (HsCompileState imps)) <-- definition def `runHsCompileT` menv- return $ GHCDefinition usesFloat decls def (checkedMainDef <$> mainFuncDef) imps---- | We do not erase types that have a 'HsData' pragma.--- This is to ensure a stable interface to third-party code.-ghcMayEraseType :: QName -> TCM Bool-ghcMayEraseType q = getHaskellPragma q <&> \case- -- Andreas, 2019-05-09, issue #3732.- -- We restrict this to 'HsData' since types like @Size@, @Level@- -- should be erased although they have a 'HsType' binding to the- -- Haskell unit type.- Just HsData{} -> False- _ -> True---- Compilation ------------------------------------------------------------+-- Imports --------------------------------------------------------------- -imports ::- BuiltinThings -> Set TopLevelModuleName -> [Definition] ->- [HS.ImportDecl]-imports builtinThings usedModules defs = hsImps ++ imps where- hsImps :: [HS.ImportDecl]- hsImps = [unqualRTE, decl mazRTE]+-- | Imports for the runtime environment (RTE). +rteImports :: [HS.ImportDecl]+rteImports = [unqualRTE, HS.qualifiedImport mazRTE]+ where unqualRTE :: HS.ImportDecl- unqualRTE = HS.ImportDecl mazRTE False $ Just $- (False, [ HS.IVar $ HS.Ident x- | x <- [mazCoerceName, mazErasedName, mazAnyTypeName] ++- map treelessPrimName rtePrims ])-- rtePrims = [T.PAdd, T.PSub, T.PMul, T.PQuot, T.PRem, T.PGeq, T.PLt, T.PEqI,- T.PAdd64, T.PSub64, T.PMul64, T.PQuot64, T.PRem64, T.PLt64, T.PEq64,- T.PITo64, T.P64ToI] -- Excludes T.PEqF, which is defined in MAlonzo.RTE.Float-- imps :: [HS.ImportDecl]- imps = map decl $ uniq $ importsForPrim builtinThings defs ++ map mazMod mnames-- decl :: HS.ModuleName -> HS.ImportDecl- decl m = HS.ImportDecl m True Nothing+ unqualRTE = HS.ImportDecl mazRTE False $ Just $ (False,) $ map (HS.IVar . HS.Ident) $+ [mazCoerceName, mazErasedName, mazAnyTypeName] +++ map treelessPrimName+ [T.PAdd, T.PSub, T.PMul, T.PQuot, T.PRem, T.PGeq, T.PLt, T.PEqI,+ T.PAdd64, T.PSub64, T.PMul64, T.PQuot64, T.PRem64, T.PLt64, T.PEq64,+ T.PITo64, T.P64ToI] -- Excludes T.PEqF, which is defined in MAlonzo.RTE.Float - mnames :: [TopLevelModuleName]- mnames = Set.elems usedModules+-- | Imports of the compiled Agda modules, ordered alphabetically. - uniq :: [HS.ModuleName] -> [HS.ModuleName]- uniq = List.map List1.head . List1.group . List.sort+moduleImports :: Set TopLevelModuleName -> [HS.ImportDecl]+moduleImports = map (HS.qualifiedImport . mazMod') . List.sort . map prettyShow . Set.elems --- Should we import MAlonzo.RTE.Float+-- | Should we import @MAlonzo.RTE.Float@? newtype UsesFloat = UsesFloat Bool deriving (Eq, Show) pattern YesFloat :: UsesFloat@@ -504,8 +510,34 @@ mappend = (<>) mazRTEFloatImport :: UsesFloat -> [HS.ImportDecl]-mazRTEFloatImport (UsesFloat b) = [ HS.ImportDecl mazRTEFloat True Nothing | b ]+mazRTEFloatImport (UsesFloat b) = [ HS.qualifiedImport mazRTEFloat | b ] +hsImportDebugTrace :: HS.ImportDecl+hsImportDebugTrace = HS.ImportDecl+ { importModule = HS.ModuleName "Debug.Trace"+ , importQualified = True+ , importSpecs = Just (False, [ HS.IVar $ HS.Ident "trace" ])+ }++-- Compilation ------------------------------------------------------------++ghcCompileDef :: GHCEnv -> GHCModuleEnv -> IsMain -> Definition -> TCM GHCDefinition+ghcCompileDef _cenv menv _isMain def = do+ ((usesFloat, decls, mainFuncDef), (HsCompileState imps)) <-+ definition def `runHsCompileT` menv+ return $ GHCDefinition usesFloat decls def (checkedMainDef <$> mainFuncDef) imps++-- | We do not erase types that have a 'HsData' pragma.+-- This is to ensure a stable interface to third-party code.+ghcMayEraseType :: QName -> TCM Bool+ghcMayEraseType q = getHaskellPragma q <&> \case+ -- Andreas, 2019-05-09, issue #3732.+ -- We restrict this to 'HsData' since types like @Size@, @Level@+ -- should be erased although they have a 'HsType' binding to the+ -- Haskell unit type.+ Just HsData{} -> False+ _ -> True+ -------------------------------------------------- -- Main compiling clauses --------------------------------------------------@@ -685,8 +717,8 @@ emptyBinds] ] - -- TC builtins are compiled to erased, which is an ∞-ary- -- function.+ -- TC builtins are compiled to erased, which is a non-strict+ -- ∞-ary function. Axiom{} | ghcEnvIsTCBuiltin env q -> do retDecls $ [ HS.FunBind@@ -705,10 +737,9 @@ PrimitiveSort{} -> retDecls [] - Function{} -> function pragma $ functionViaTreeless q+ Function{} -> function pragma $ functionViaTreeless def q Datatype{ dataPars = np, dataIxs = ni, dataClause = cl- , dataPathCons = pcs } | Just hsdata@(HsData r ty hsCons) <- pragma -> setCurrentRange r $ do reportSDoc "compile.ghc.definition" 40 $ hsep $@@ -725,7 +756,6 @@ ] retDecls result Datatype{ dataPars = np, dataIxs = ni, dataClause = cl- , dataPathCons = pcs } -> do liftTCM $ computeErasedConstructorArgs q cs <- liftTCM $ getNotErasedConstructors q@@ -767,17 +797,19 @@ return (imp, [tsig,def] ++ ccls) _ -> return (imp, ccls) - functionViaTreeless :: QName -> HsCompileM (UsesFloat, [HS.Decl])- functionViaTreeless q = do- strict <- optGhcStrict <$> askGhcOpts- let eval = if strict then EagerEvaluation else LazyEvaluation+ functionViaTreeless :: Definition -> QName -> HsCompileM (UsesFloat, [HS.Decl])+ functionViaTreeless def q = do+ strict <- optGhcStrict <$> askGhcOpts+ strictData <- optGhcStrictData <$> askGhcOpts+ let eval =+ if strict then EagerEvaluation+ else LazyEvaluation (if strictData then Strict else NonStrict) caseMaybeM (liftTCM $ toTreeless eval q) (pure mempty) $ \ treeless -> do used <- fromMaybe [] <$> getCompiledArgUse q let dostrip = ArgUnused `elem` used -- Compute the type approximation- def <- getConstInfo q (argTypes0, resType) <- hsTelApproximation $ defType def let pars = case theDef def of Function{ funProjection = Right Projection{ projIndex = i } } | i > 0 -> i - 1@@ -807,6 +839,13 @@ ArgUnused -> HS.PIrrPat p) ps0 used + -- Trace entering functions when --ghc-trace is on.+ b <- ifM (pure (isProperProjection $ theDef def) `or2M` (not . optGhcTrace <$> askGhcOpts))+ {-then-} (pure b)+ {-else-} do+ x <- render <$> prettyTCM q+ pure $ HS.App (HS.App hsDebugTrace $ HS.Lit $ HS.String $ Text.pack x) b+ return (useFloat, if dostrip then tyfunbind (dname q) argTypes resType ps0' b0 ++@@ -824,6 +863,10 @@ axiomErr :: HS.Exp axiomErr = rtmError $ Text.pack $ "postulate evaluated: " ++ prettyShow q +-- | The Haskell function 'Debug.Trace.trace'.+hsDebugTrace :: HS.Exp+hsDebugTrace = HS.Var $ HS.Qual (HS.ModuleName "Debug.Trace") $ HS.Ident "trace"+ constructorCoverageCode :: QName -> Int -> [QName] -> HaskellType -> [HaskellCode] -> HsCompileM [HS.Decl] constructorCoverageCode q np cs hsTy hsCons = do -- Check that number of constructors matches up.@@ -987,10 +1030,13 @@ T.TVar i -> hsVarUQ . lookupIndex i <$> view ccContext T.TLam t -> intros 1 $ \ [x] -> hsLambda [HS.PVar x] <$> term t - T.TLet t1 t2 -> do+ T.TLet s t1 t2 -> do t1' <- term t1+ s' <- case s of+ T.Strict -> return HS.Strict+ T.NonStrict -> return HS.Lazy intros 1 $ \[x] -> do- hsLet x t1' . hsCoerce <$> term t2+ hsLet s' x t1' . hsCoerce <$> term t2 T.TCase sc ct def alts -> do sc' <- term $ T.TVar sc@@ -1119,7 +1165,7 @@ where apps = foldl HS.App rteCon name = HS.Con $ HS.Qual mazRTE $ HS.Ident name- NameId n (ModuleNameHash m) = nameId $ qnameName x+ NameId n (ModuleNameHash m) = nameId x fx = theFixity $ nameFixity $ qnameName x litAssoc NonAssoc = rteCon "NonAssoc"@@ -1136,7 +1182,7 @@ , HS.PLit (HS.Int $ fromIntegral m) , HS.PWildCard, HS.PWildCard ] where- NameId n (ModuleNameHash m) = nameId $ qnameName x+ NameId n (ModuleNameHash m) = nameId x litmetapat :: MetaId -> HS.Pat litmetapat (MetaId m h) =@@ -1156,7 +1202,7 @@ else HS.Lazy argTypes = [ (Just strict, t) | (t, False) <- zip (drop np argTypes0)- (fromMaybe [] erased ++ repeat False)+ (ListInf.pad (fromMaybe [] erased) False) ] return $ HS.ConDecl (unqhname ConK q) argTypes @@ -1179,14 +1225,25 @@ where vs = [ ihname A i | i <- [0 .. arity - 1]] -tvaldecl :: QName- -> Induction- -- ^ Is the type inductive or coinductive?- -> Nat -> [HS.ConDecl] -> Maybe Clause -> [HS.Decl]-tvaldecl q ind npar cds cl =+-- | Produce Haskell code for a data type declaration.+tvaldecl ::+ QName+ -- ^ Name of the data/record type.+ -> Induction+ -- ^ Is the type inductive or coinductive?+ -> Nat+ -- ^ Number of parameters.+ -> [HS.ConDecl]+ -- ^ Constructors.+ -> Maybe a+ -- ^ The definition of this type if it is a copy created by a+ -- module application (see 'defCopyClause'); such a type is a mere+ -- alias, so no data declaration is emitted for it.+ -> [HS.Decl]+tvaldecl q ind npar cds body = HS.FunBind [HS.Match vn pvs (HS.UnGuardedRhs HS.unit_con) emptyBinds] : maybe [HS.DataDecl kind tn [] cds' []]- (const []) cl+ (const []) body where (tn, vn) = (unqhname TypeK q, dname q) pvs = [ HS.PVar $ ihname A i | i <- [0 .. npar - 1]]
src/full/Agda/Compiler/MAlonzo/HaskellTypes.hs view
@@ -30,6 +30,8 @@ import qualified Agda.Utils.Haskell.Syntax as HS import Agda.Utils.List+import Agda.Utils.ListInf ( pattern (:<) )+import Agda.Utils.ListInf qualified as ListInf import Agda.Utils.Monad import Agda.Utils.Null import Agda.Syntax.Common.Pretty (prettyShow)@@ -123,7 +125,13 @@ haskellType' :: Type -> HsCompileM HS.Type haskellType' t = runToHs (unEl t) (fromType t) where- fromArgs = mapM (fromTerm . unArg)+ fromArgs = mapM fromArg+ fromArg v+ | usableModality v = fromTerm (unArg v)+ | otherwise = pure hsUnit+ fromDom dom+ | usableModality dom = fromType (unDom dom)+ | otherwise = pure hsUnit fromType = fromTerm . unEl fromTerm v = do v <- liftTCM $ unSpine <$> reduce v@@ -132,20 +140,20 @@ kit <- liftTCM coinductionKit case v of Var x es -> do- let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ let args = mustAllApplyElims es hsApp . hsVar <$> getHsVar x <*> fromArgs args Def d es -> do- let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ let args = mustAllApplyElims es hsApp <$> getHsType d <*> fromArgs args Pi a b -> if isBinderUsed b -- Andreas, 2012-04-03. Q: could we rely on Abs/NoAbs instead of again checking freeness of variable? then do- hsA <- fromType (unDom a)+ hsA <- fromDom a liftE1' (underAbstraction a b) $ \ b -> hsForall <$> getHsVar 0 <*> (hsFun hsA <$> fromType b)- else hsFun <$> fromType (unDom a) <*> fromType (noabsApp __IMPOSSIBLE__ b)+ else hsFun <$> fromDom a <*> fromType (noabsApp __IMPOSSIBLE__ b) Con c ci es -> do- let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ let args = mustAllApplyElims es hsApp <$> getHsType (conName c) <*> fromArgs args Lam{} -> throwError (BadLambda v) Level{} -> return hsUnit@@ -153,7 +161,7 @@ Sort{} -> return hsUnit MetaV{} -> throwError (BadMeta v) DontCare{} -> throwError (BadDontCare v)- Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s+ Dummy s _ -> __IMPOSSIBLE_VERBOSE__ (show s) haskellType :: QName -> HsCompileM HS.Type haskellType q = do@@ -161,12 +169,12 @@ let (np, erased) = case theDef def of Constructor{ conPars, conErased }- -> (conPars, fromMaybe [] conErased ++ repeat False)- _ -> (0, repeat False)- stripErased (True : es) (HS.TyFun _ t) = stripErased es t- stripErased (False : es) (HS.TyFun s t) = HS.TyFun s $ stripErased es t- stripErased es (HS.TyForall xs t) = HS.TyForall xs $ stripErased es t- stripErased _ t = t+ -> (conPars, ListInf.pad (fromMaybe [] conErased) False)+ _ -> (0, ListInf.repeat False)+ stripErased (True :< es) (HS.TyFun _ t) = stripErased es t+ stripErased (False :< es) (HS.TyFun s t) = HS.TyFun s $ stripErased es t+ stripErased es (HS.TyForall xs t) = HS.TyForall xs $ stripErased es t+ stripErased _ t = t underPars 0 a = stripErased erased <$> haskellType' a underPars n a = do a <- reduce a@@ -183,8 +191,10 @@ data PolyApprox = PolyApprox | NoPolyApprox deriving (Eq) -hsTypeApproximation :: PolyApprox -> Int -> Type -> HsCompileM HS.Type-hsTypeApproximation poly fv t = do+hsTypeApproximation :: PolyApprox -> Int -> Dom Type -> HsCompileM HS.Type+hsTypeApproximation poly fv dom+ | not (usableModality dom) = pure hsUnit+ | otherwise = do env <- askGHCEnv let is q b = Just q == b env tyCon = HS.TyCon . HS.UnQual . HS.Ident@@ -196,31 +206,37 @@ t <- unSpine <$> reduce t case t of Var i _ | poly == PolyApprox -> return $ tyVar n i- Pi a b -> hsFun <$> go n (unEl $ unDom a) <*> go (n + k) (unEl $ unAbs b)+ Pi a b -> hsFun <$> goDom n a <*> go (n + k) (unEl $ unAbs b) where k = case b of Abs{} -> 1; NoAbs{} -> 0 Def q els | q `is` ghcEnvList , Just k <- ghcEnvListArity env , [Apply t] <- drop (k-1) els ->- HS.TyApp (tyCon "[]") <$> go n (unArg t)+ HS.TyApp (tyCon "[]") <$> goArg n t | q `is` ghcEnvMaybe , Just k <- ghcEnvMaybeArity env , [Apply t] <- drop (k-1) els ->- HS.TyApp (tyCon "Maybe") <$> go n (unArg t)+ HS.TyApp (tyCon "Maybe") <$> goArg n t | q `is` ghcEnvBool -> return $ tyCon "Bool" | q `is` ghcEnvInteger -> return $ tyCon "Integer" | q `is` ghcEnvNat -> return $ tyCon "Integer" | q `is` ghcEnvWord64 -> return $ rteCon "Word64" | otherwise -> do- let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims els- foldl HS.TyApp <$> getHsType' q <*> mapM (go n . unArg) args+ let args = mustAllApplyElims els+ foldl HS.TyApp <$> getHsType' q <*> mapM (goArg n) args `catchError` \ _ -> -- Not a Haskell type ifM (and2M (isCompiled q) (isData q)) (HS.TyCon <$> xhqn TypeK q) (return mazAnyType) Sort{} -> return $ HS.FakeType "()" _ -> return mazAnyType- go fv (unEl t)+ goArg n v+ | usableModality v = go n (unArg v)+ | otherwise = pure hsUnit+ goDom n dom+ | usableModality dom = go n (unEl $ unDom dom)+ | otherwise = pure hsUnit+ goDom fv dom -- Approximating polymorphic types is not actually a good idea unless we -- actually keep track of type applications in recursive functions, and@@ -232,5 +248,5 @@ hsTelApproximation' :: PolyApprox -> Type -> HsCompileM ([HS.Type], HS.Type) hsTelApproximation' poly t = do TelV tel res <- telViewPath t- let args = map (snd . unDom) (telToList tel)- (,) <$> zipWithM (hsTypeApproximation poly) [0..] args <*> hsTypeApproximation poly (length args) res+ let doms = map (fmap snd) (telToList tel)+ (,) <$> zipWithM (hsTypeApproximation poly) [0..] doms <*> hsTypeApproximation poly (length doms) (defaultDom res)
src/full/Agda/Compiler/MAlonzo/Misc.hs view
@@ -58,6 +58,8 @@ -- ^ Make inductive constructors strict? , optGhcStrict :: Bool -- ^ Make functions strict?+ , optGhcTrace :: Bool+ -- ^ Print function name upon entry using 'Debug.Trace.trace'? } -- | A static part of the GHC backend's environment that does not@@ -111,7 +113,7 @@ askGHCModuleEnv :: m GHCModuleEnv default askGHCModuleEnv- :: (MonadTrans t, Monad n, m ~ (t n), ReadGHCModuleEnv n)+ :: (MonadTrans t, m ~ (t n), ReadGHCModuleEnv n) => m GHCModuleEnv askGHCModuleEnv = lift askGHCModuleEnv @@ -290,9 +292,9 @@ hsTypedDouble :: Real a => a -> HS.Exp hsTypedDouble n = HS.ExpTypeSig (HS.Lit (HS.Frac $ toRational n)) (HS.TyCon (hsName "Double")) -hsLet :: HS.Name -> HS.Exp -> HS.Exp -> HS.Exp-hsLet x e b =- HS.Let (HS.BDecls [HS.LocalBind HS.Lazy x (HS.UnGuardedRhs e)]) b+hsLet :: HS.Strictness -> HS.Name -> HS.Exp -> HS.Exp -> HS.Exp+hsLet s x e b =+ HS.Let (HS.BDecls [HS.LocalBind s x (HS.UnGuardedRhs e)]) b hsVarUQ :: HS.Name -> HS.Exp hsVarUQ = HS.Var . HS.UnQual
src/full/Agda/Compiler/MAlonzo/Pragmas.hs view
@@ -8,6 +8,9 @@ import Data.Char import qualified Data.List as List import qualified Data.Map as Map+import Data.Set (Set)+import Data.Set qualified as Set+ import Text.ParserCombinators.ReadP import Agda.Syntax.Position@@ -28,6 +31,12 @@ import Agda.Utils.Impossible +-- | Raw Haskell pragma (something enclosed in @{-# ... #-}@).+type GHCPragma = String++-- | Raw Haskell import (something starting with @import @).+type GHCImport = String+ type HaskellCode = String type HaskellType = String @@ -212,10 +221,12 @@ -- | Get content of @FOREIGN GHC@ pragmas, sorted by 'KindOfForeignCode': -- file header pragmas, import statements, rest.-foreignHaskell :: Interface -> ([String], [String], [String])-foreignHaskell = partitionByKindOfForeignCode classifyForeign- . map getCode . maybe [] (reverse . getForeignCodeStack) . Map.lookup ghcBackendName . iForeignCode- where getCode (ForeignCode _ code) = code+foreignHaskell :: Interface -> (Set GHCPragma, Set GHCImport, [HaskellCode])+foreignHaskell i = (Set.fromList pragmas, Set.fromList imports, reverse revCode)+ where+ getCode (ForeignCode _ code) = code+ (pragmas, imports, revCode) = partitionByKindOfForeignCode classifyForeign+ . map getCode . maybe [] getForeignCodeStack . Map.lookup ghcBackendName . iForeignCode $ i -- | Classify @FOREIGN@ Haskell code. data KindOfForeignCode
src/full/Agda/Compiler/MAlonzo/Primitives.hs view
@@ -2,19 +2,19 @@ module Agda.Compiler.MAlonzo.Primitives where -import Control.Arrow ( second ) import Control.Monad.Trans.Maybe ( MaybeT(MaybeT, runMaybeT) ) -import qualified Data.List as List-import Data.Map (Map)-import qualified Data.Map as Map-import qualified Data.HashMap.Strict as HMap+import Data.HashMap.Strict qualified as HMap+import Data.List qualified as List+import Data.Map qualified as Map import Data.Maybe+import Data.Set (Set)+import Data.Set qualified as Set import Agda.Compiler.Common import Agda.Compiler.MAlonzo.Misc import Agda.Syntax.Common-import Agda.Syntax.Common.Pretty (prettyShow)+import Agda.Syntax.Common.Pretty ( prettyShow ) import Agda.Syntax.Internal import Agda.Syntax.Treeless import Agda.TypeChecking.Monad@@ -22,12 +22,14 @@ import Agda.TypeChecking.Reduce import Agda.Utils.Either-import Agda.Utils.Lens-import Agda.Utils.List (hasElem)-import qualified Agda.Utils.Haskell.Syntax as HS+import Agda.Utils.List ( hasElem )+import Agda.Utils.Haskell.Syntax qualified as HS import Agda.Utils.Impossible +---------------------------------------------------------------------------+-- * Entrypoint (@main@)+ newtype MainFunctionDef = MainFunctionDef Definition data CheckedMainFunctionDef = CheckedMainFunctionDef@@ -81,6 +83,58 @@ mainLHS = HS.Ident "main" mainRHS = HS.UnGuardedRhs $ HS.App mazCoerce (HS.Var $ HS.UnQual $ dname $ defName def) +---------------------------------------------------------------------------+-- * Primitives and builtins++-- | These builtins need a qualified import of "Data.Char".+charBuiltins :: [SomeBuiltin]+charBuiltins =+ [ someBuiltin BuiltinChar+ , someBuiltin PrimIsAlpha+ , someBuiltin PrimIsAscii+ , someBuiltin PrimIsDigit+ , someBuiltin PrimIsHexDigit+ , someBuiltin PrimIsLatin1+ , someBuiltin PrimIsLower+ , someBuiltin PrimIsPrint+ , someBuiltin PrimIsSpace+ , someBuiltin PrimToLower+ , someBuiltin PrimToUpper+ ]++-- | These builtins need a qualified import of "MAlonzo.RTE.Float".+floatBuiltins :: [SomeBuiltin]+floatBuiltins =+ [ someBuiltin PrimFloatCeiling+ , someBuiltin PrimFloatDecode+ , someBuiltin PrimFloatEncode+ , someBuiltin PrimFloatEquality+ , someBuiltin PrimFloatFloor+ , someBuiltin PrimFloatInequality+ , someBuiltin PrimFloatIsSafeInteger+ , someBuiltin PrimFloatLess+ , someBuiltin PrimFloatRound+ , someBuiltin PrimFloatToRatio+ , someBuiltin PrimFloatToWord64+ , someBuiltin PrimRatioToFloat+ ]++-- | Which builtins are actually used in the definitions?+usedBuiltins :: BuiltinThings -> [Definition] -> Set SomeBuiltin+usedBuiltins builtinThings defs = Set.fromList+ [ s+ | (s, def) <- Map.toList builtinThings+ , maybe False elemDefs $ getName def+ ]+ where+ elemDefs = hasElem $ map defName defs+ getName = \case+ Builtin t -> Just $ getPrimName t+ Prim (PrimFun q _ _ _) -> Just q+ BuiltinRewriteRelations _ -> Nothing++-- ** Translating primitives+ treelessPrimName :: TPrim -> String treelessPrimName p = case p of@@ -110,53 +164,7 @@ -- primitives only used by GuardsToPrims transformation, which MAlonzo doesn't use PIf -> __IMPOSSIBLE__ --- | Haskell modules to be imported for BUILT-INs-importsForPrim :: BuiltinThings -> [Definition] -> [HS.ModuleName]-importsForPrim builtinThings defs = xForPrim table builtinThings defs ++ [HS.ModuleName "Data.Text"]- where- table = Map.fromList $ map (second HS.ModuleName)- [ someBuiltin BuiltinChar |-> "Data.Char"- , someBuiltin PrimFloatCeiling |-> "MAlonzo.RTE.Float"- , someBuiltin PrimFloatDecode |-> "MAlonzo.RTE.Float"- , someBuiltin PrimFloatEncode |-> "MAlonzo.RTE.Float"- , someBuiltin PrimFloatEquality |-> "MAlonzo.RTE.Float"- , someBuiltin PrimFloatFloor |-> "MAlonzo.RTE.Float"- , someBuiltin PrimFloatInequality |-> "MAlonzo.RTE.Float"- , someBuiltin PrimFloatIsSafeInteger |-> "MAlonzo.RTE.Float"- , someBuiltin PrimFloatLess |-> "MAlonzo.RTE.Float"- , someBuiltin PrimFloatRound |-> "MAlonzo.RTE.Float"- , someBuiltin PrimFloatToRatio |-> "MAlonzo.RTE.Float"- , someBuiltin PrimFloatToWord64 |-> "MAlonzo.RTE.Float"- , someBuiltin PrimIsAlpha |-> "Data.Char"- , someBuiltin PrimIsAscii |-> "Data.Char"- , someBuiltin PrimIsDigit |-> "Data.Char"- , someBuiltin PrimIsHexDigit |-> "Data.Char"- , someBuiltin PrimIsLatin1 |-> "Data.Char"- , someBuiltin PrimIsLower |-> "Data.Char"- , someBuiltin PrimIsPrint |-> "Data.Char"- , someBuiltin PrimIsSpace |-> "Data.Char"- , someBuiltin PrimRatioToFloat |-> "MAlonzo.RTE.Float"- , someBuiltin PrimToLower |-> "Data.Char"- , someBuiltin PrimToUpper |-> "Data.Char"- ]- (|->) = (,) -----------------xForPrim :: Map SomeBuiltin a -> BuiltinThings -> [Definition] -> [a]-xForPrim table builtinThings defs = catMaybes- [ Map.lookup s table- | (s, def) <- Map.toList builtinThings- , maybe False elemDefs $ getName def- ]- where- elemDefs = hasElem $ map defName defs- getName = \case- Builtin t -> Just $ getPrimName t- Prim (PrimFun q _ _ _) -> Just q- BuiltinRewriteRelations _ -> Nothing-- -- | Definition bodies for primitive functions primBody :: MonadTCError m => PrimitiveId -> m HS.Exp primBody s = maybe unimplemented (fromRight (hsVarUQ . HS.Ident) <$>) $ List.lookup s $@@ -279,6 +287,12 @@ -- Erase , PrimEraseEquality |-> return mazErasedName++ -- Rewriting+ , PrimRewriteNoMatch |-> return "\\ _ _ x -> x"++ -- Quotients+ , PrimQrec |-> return "\\_ _ _ _ _ _ f _ _ x -> f x" -- Cubical , PrimIMin |-> return "(&&)"
src/full/Agda/Compiler/MAlonzo/Strict.hs view
@@ -8,11 +8,11 @@ import Agda.Utils.Haskell.Syntax --- | The function 'makeStrict' makes every function argument, case and--- generator pattern, and 'LocalBind' binding strict (except for those--- patterns that are marked as irrefutable, and anything in a--- 'FakeDecl' or 'FakeExp'). Note that only the outermost patterns are--- made strict.+-- | The function 'makeStrict' makes every function argument and case+-- and generator pattern strict (except for those patterns that are+-- marked as irrefutable, and anything in a 'FakeDecl' or 'FakeExp').+-- Note that only the outermost patterns are made strict, and that+-- 'LocalBind' bindings are not made strict. class MakeStrict a where makeStrict :: a -> a@@ -33,7 +33,7 @@ d@DataDecl{} -> d d@TypeSig{} -> d FunBind ms -> FunBind (makeStrict ms)- LocalBind s f rhs -> LocalBind Strict f (makeStrict rhs)+ LocalBind s f rhs -> LocalBind s f (makeStrict rhs) d@PatSyn{} -> d d@FakeDecl{} -> d d@Comment{} -> d
src/full/Agda/Compiler/ToTreeless.hs view
@@ -1,15 +1,17 @@ {-# OPTIONS_GHC -Wunused-imports #-} module Agda.Compiler.ToTreeless- ( toTreeless- , toTreelessWith+ ( toTreelessWith , closedTermToTreeless , Pipeline(..) , CompilerPass(..) , compilerPass- , compilerPipeline , CCConfig , CCSubst(..)+ -- * Default pipeline+ , compilerPipeline+ , mkDefaultCCConfig+ , toTreeless ) where import Prelude hiding ((!!))@@ -19,7 +21,6 @@ import Data.Maybe import Data.Map (Map) import qualified Data.Map as Map-import qualified Data.List as List import Agda.Syntax.Common import Agda.Syntax.Internal as I@@ -47,7 +48,6 @@ import Agda.Utils.Function import Agda.Utils.Functor-import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Monad@@ -102,50 +102,50 @@ -- ^ TTerm de-bruijn index of the current catch all. -- If an inner case has no catch-all clause, we use the one from its parent. , ccEvaluation :: EvaluationStrategy- -- ^ Which evaluation strategy does the backend assumes.+ -- ^ Which evaluation strategy does the backend assume.+ , ccPipeline :: BuildPipeline+ -- ^ Which pipeline does the backend use. , ccSubstUnused :: CCSubst -- ^ Whether to erase unused arguments. } -type CCConfig = (EvaluationStrategy, CCSubst)+type CCConfig = (EvaluationStrategy, CCSubst, BuildPipeline) -- | Initial environment for expression generation. initCCEnv :: CCConfig -> CCEnv-initCCEnv (eval, su) = CCEnv+initCCEnv (eval, su, pl) = CCEnv { ccCxt = [] , ccCatchall = Nothing , ccEvaluation = eval , ccSubstUnused = su+ , ccPipeline = pl } +ccCCConfig :: CCEnv -> CCConfig+ccCCConfig e = (ccEvaluation e, ccSubstUnused e, ccPipeline e)+ -- | Converts compiled clauses to treeless syntax. -- -- Note: Do not use any of the concrete names in the returned -- term for identification purposes! If you wish to do so, -- first apply the Agda.Compiler.Treeless.NormalizeNames -- transformation.-toTreelessWith :: BuildPipeline -> CCConfig -> QName -> TCM (Maybe C.TTerm)-toTreelessWith pl cfg q+toTreelessWith :: CCConfig -> QName -> TCM (Maybe C.TTerm)+toTreelessWith cfg q = ifM (alwaysInline q) (pure Nothing)- $ Just <$> toTreelessWith' pl cfg q--toTreeless :: EvaluationStrategy -> QName -> TCM (Maybe C.TTerm)-toTreeless eval = toTreelessWith compilerPipeline (eval, EraseUnused)+ $ Just <$> toTreelessWith' cfg q -toTreelessWith' :: BuildPipeline -> CCConfig -> QName -> TCM C.TTerm-toTreelessWith' pl cfg q =+toTreelessWith' :: CCConfig -> QName -> TCM C.TTerm+toTreelessWith' cfg q = flip fromMaybeM (getTreeless q) $ verboseBracket "treeless.convert" 20 ("compiling " ++ prettyShow q) $ do cc <- getCompiledClauses q unlessM (alwaysInline q) $ setTreeless q (C.TDef q) -- so recursive inlining doesn't loop, but not for always inlined -- functions, since that would risk inlining to fail.- ccToTreelessWith pl cfg q cc--toTreeless' :: EvaluationStrategy -> QName -> TCM C.TTerm-toTreeless' eval = toTreelessWith' compilerPipeline (eval, EraseUnused)+ ccToTreelessWith cfg q cc -ccToTreelessWith :: BuildPipeline -> CCConfig -> QName -> CC.CompiledClauses -> TCM C.TTerm-ccToTreelessWith pl cfg@(eval, su) q cc = do+ccToTreelessWith :: CCConfig -> QName -> CC.CompiledClauses -> TCM C.TTerm+ccToTreelessWith cfg@(eval, su, pl) q cc = do let pbody b = pbody' "" b pbody' suf b = sep [ text (prettyShow q ++ suf) <+> "=", nest 2 $ prettyPure b ] v <- ifM (alwaysInline q) (return 20) (return 0)@@ -163,30 +163,9 @@ setCompiledArgUse q used return body -ccToTreeless :: EvaluationStrategy -> QName -> CC.CompiledClauses -> TCM C.TTerm-ccToTreeless eval = ccToTreelessWith compilerPipeline (eval, EraseUnused)- compilerPass :: String -> Int -> String -> (EvaluationStrategy -> TTerm -> TCM TTerm) -> Pipeline compilerPass tag v name code = SinglePass (CompilerPass tag v name code) -compilerPipeline :: BuildPipeline-compilerPipeline v q =- Sequential- -- Issue #4967: No simplification step before builtin translation! Simplification relies- -- on either all or no builtins being translated. Since we might have inlined- -- functions that have had the builtin translation applied, we need to apply it- -- first.- -- [ compilerPass "simpl" (35 + v) "simplification" $ const simplifyTTerm- [ compilerPass "builtin" (30 + v) "builtin translation" $ const translateBuiltins- , FixedPoint 5 $ Sequential- [ compilerPass "simpl" (30 + v) "simplification" $ const simplifyTTerm- , compilerPass "erase" (30 + v) "erasure" $ eraseTerms q- , compilerPass "uncase" (30 + v) "uncase" $ const caseToSeq- , compilerPass "aspat" (30 + v) "@-pattern recovery" $ const recoverAsPatterns- ]- , compilerPass "id" (30 + v) "identity function detection" $ const (detectIdentityFunctions q)- ]- runPipeline :: EvaluationStrategy -> QName -> Pipeline -> TTerm -> TCM TTerm runPipeline eval q pipeline t = case pipeline of SinglePass p -> runCompilerPass eval q p t@@ -224,9 +203,9 @@ alwaysInline q = do def <- theDef <$> getConstInfo q pure $ case def of -- always inline with functions and pattern lambdas- Function{funClauses = cs} -> (isJust (funExtLam def) && not recursive) || isJust (funWith def)+ Function{funClauses = cs} -> (isJust (funExtLam def) && not recursive) || isWithFunction def where- recursive = any (fromMaybe True . clauseRecursive) cs+ recursive = any (couldBeRecursive . clauseRecursive) cs _ -> False shift :: Int -> CCContext -> CCContext@@ -255,7 +234,7 @@ casetree cc = do case cc of CC.Fail xs -> withContextSize (length xs) $ return C.tUnreachable- CC.Done xs v -> withContextSize (length xs) $ do+ CC.Done _ _ xs v -> withContextSize (length xs) $ do -- Issue 2469: Body context size (`length xs`) may be smaller than current context size -- if some arguments are not used in the body. v <- lift (putAllowedReductions (SmallSet.fromList [ProjectionReductions, CopatternReductions]) $ normalise v)@@ -281,29 +260,44 @@ updateCatchall catchall fromCatchall else do -- Get the type of the scrutinee.- caseTy <-+ (caseTy, ind) <- case (Map.keys conBrs', Map.keys litBrs) of (cs, []) -> lift $ go cs where go (c:cs) = canonicalName c >>= getConstInfo <&> theDef >>= \case- Constructor{conData} ->- return $ C.CTData conData+ Constructor{conData} -> do+ def <- theDef <$> getConstInfo conData+ return+ ( C.CTData conData+ , case def of+ Datatype{} -> Inductive+ Record{ recInduction } -> case recInduction of+ Just i -> i+ Nothing -> Inductive+ _ -> __IMPOSSIBLE__+ ) _ -> go cs go [] = __IMPOSSIBLE__- ([], LitChar _ : _) -> return C.CTChar- ([], LitString _ : _) -> return C.CTString- ([], LitFloat _ : _) -> return C.CTFloat- ([], LitQName _ : _) -> return C.CTQName+ ([], LitChar _ : _) -> return (C.CTChar, Inductive)+ ([], LitString _ : _) -> return (C.CTString, Inductive)+ ([], LitFloat _ : _) -> return (C.CTFloat, Inductive)+ ([], LitQName _ : _) -> return (C.CTQName, Inductive) _ -> __IMPOSSIBLE__ updateCatchall catchall $ do- x <- asks (lookupLevel n . ccCxt)- def <- fromCatchall- let caseInfo = C.CaseInfo- { caseType = caseTy- , caseLazy = lazy- , caseErased = fromMaybe __IMPOSSIBLE__ $- erasedFromQuantity (getQuantity i)+ x <- asks (lookupLevel n . ccCxt)+ eval <- asks ccEvaluation+ def <- fromCatchall+ let -- Lazy matches are made strict in strict backends.+ lazy' = lazy && case eval of+ C.LazyEvaluation _ -> True+ C.EagerEvaluation -> False+ caseInfo = C.CaseInfo+ { caseType = caseTy+ , caseLazy = lazy'+ , caseInduction = ind+ , caseErased = fromMaybe __IMPOSSIBLE__ $+ erasedFromQuantity (getQuantity i) } C.TCase x caseInfo def <$> do br1 <- conAlts n conBrs'@@ -328,8 +322,8 @@ concat [ arities cxt' c | Just c <- [def] ] -- ?? where cxt' = max (x + 1) cxt arities cxt (Case _ Branches{projPatterns = True}) = [cxt]- arities cxt (Done xs _) = [max cxt (length xs)]- arities cxt (Fail xs) = [max cxt (length xs)]+ arities cxt (Done _ _ xs _) = [max cxt (length xs)]+ arities cxt (Fail xs) = [max cxt (length xs)] wArities cxt (WithArity k c) = map (\ x -> x - k + 1) $ arities (cxt - 1 + k) c@@ -345,7 +339,8 @@ , "-- def =" <+> prettyPure def ] local (\ e -> e { ccCatchall = Just 0, ccCxt = shift 1 cxt }) $ do- C.mkLet def <$> cont+ -- This binding is non-strict, see issue #8759.+ C.mkLet C.NonStrict def <$> cont -- | Shrinks or grows the context to the given size. -- Does not update the catchall expression, the catchall expression@@ -428,7 +423,7 @@ , "-- cxt =" <+> prettyPure cxt ] -- Prepend diff lambdas- cont <&> \ t -> List.iterate C.TLam t !! diff+ iterate' diff C.TLam <$> cont -- | Adds lambdas until the context has at least the given size. -- Updates the catchall expression to take the additional lambdas into account.@@ -454,7 +449,9 @@ local (\e -> e { ccCatchall = Just 0 , ccCxt = shift 1 cxt }) $ do let catchallArgs = map C.TVar $ downFrom diff- C.mkLet (C.mkTApp (C.TVar $ catchall + diff) catchallArgs)+ -- This binding is non-strict, see issue #8759.+ C.mkLet C.NonStrict+ (C.mkTApp (C.TVar $ catchall + diff) catchallArgs) <$> cont Nothing -> cont @@ -494,7 +491,7 @@ -- Get the name of the first field let p1 = fst $ headWithDefault __IMPOSSIBLE__ $ Map.toList fs -- Use the field name to get the record constructor and the field names.- I.ConHead c IsRecord{} _ind xs <- conSrcCon . theDef <$> (getConstInfo =<< canonicalName . I.conName =<< recConFromProj p1)+ I.ConHead c IsRecord{} _ind _hit xs <- conSrcCon . theDef <$> (getConstInfo =<< canonicalName . I.conName =<< recConFromProj p1) reportSDoc "treeless.convert.mkRecord" 60 $ vcat [ text "record constructor fields: xs = " <+> (text . show) xs , text "to be filled with content: keys fs = " <+> (text . show) (Map.keys fs)@@ -522,7 +519,7 @@ case I.unSpine $ etaContractErased term of I.Var ind es -> do ind' <- asks (lookupIndex ind . ccCxt)- let args = fromMaybe __IMPOSSIBLE__ $ I.allApplyElims es+ let args = I.mustAllApplyElims es C.mkTApp (C.TVar ind') <$> substArgs args I.Lam _ ab -> C.TLam <$>@@ -531,10 +528,10 @@ I.Lit l -> return $ C.TLit l I.Level _ -> return C.TUnit I.Def q es -> do- let args = fromMaybe __IMPOSSIBLE__ $ I.allApplyElims es+ let args = I.mustAllApplyElims es maybeInlineDef q args I.Con c ci es -> do- let args = fromMaybe __IMPOSSIBLE__ $ I.allApplyElims es+ let args = I.mustAllApplyElims es c' <- lift $ canonicalName $ I.conName c C.mkTApp (C.TCon c') <$> substArgs args I.Pi _ _ -> return C.TUnit@@ -599,22 +596,22 @@ normaliseStatic v = pure v -- | Does not require the name to refer to a function.-cacheTreeless :: EvaluationStrategy -> QName -> TCM ()-cacheTreeless eval q = do+cacheTreeless :: CCConfig -> QName -> TCM ()+cacheTreeless cfg q = do def <- theDef <$> getConstInfo q case def of- Function{} -> () <$ toTreeless' eval q+ Function{} -> () <$ toTreelessWith' cfg q _ -> return () maybeInlineDef :: I.QName -> I.Args -> CC C.TTerm maybeInlineDef q vs = do- eval <- asks ccEvaluation- ifM (lift $ alwaysInline q) (doinline eval) $ do- lift $ cacheTreeless eval q+ cfg <- asks ccCCConfig+ ifM (lift $ alwaysInline q) (doinline cfg) $ do+ lift $ cacheTreeless cfg q def <- lift $ getConstInfo q case theDef def of fun@Function{}- | fun ^. funInline -> doinline eval+ | fun ^. funInline -> doinline cfg | otherwise -> do -- If ArgUsage hasn't been computed yet, we assume all arguments are used. used <- lift $ fromMaybe [] <$> getCompiledArgUse q@@ -627,8 +624,8 @@ C.mkTApp (C.TDef q) <$> zipWithM substUsed vs (used ++ repeat ArgUsed) _ -> C.mkTApp (C.TDef q) <$> substArgs vs where- doinline eval = C.mkTApp <$> inline eval q <*> substArgs vs- inline eval q = lift $ toTreeless' eval q+ doinline cfg = C.mkTApp <$> inline cfg q <*> substArgs vs+ inline cfg q = lift $ toTreelessWith' cfg q substArgs :: [Arg I.Term] -> CC [C.TTerm] substArgs = traverse substArg@@ -636,3 +633,45 @@ substArg :: Arg I.Term -> CC C.TTerm substArg x | usableModality x = substTerm (unArg x) | otherwise = return C.TErased+++-------------------------------------+-- Default pipeline+-------------------------------------++-- | Default compiler pipeline+--+-- Backends may use different pipelines+compilerPipeline :: BuildPipeline+compilerPipeline v q =+ Sequential+ -- Issue #4967: No simplification step before builtin translation! Simplification relies+ -- on either all or no builtins being translated. Since we might have inlined+ -- functions that have had the builtin translation applied, we need to apply it+ -- first.+ -- [ compilerPass "simpl" (35 + v) "simplification" $ const simplifyTTerm+ [ compilerPass "builtin" (30 + v) "builtin translation" $ const translateBuiltins+ , FixedPoint 5 $ Sequential+ [ compilerPass "simpl" (30 + v) "simplification" $ simplifyTTerm+ , compilerPass "erase" (30 + v) "erasure" $ eraseTerms q+ , compilerPass "uncase" (30 + v) "uncase" $ const caseToSeq+ , compilerPass "aspat" (30 + v) "@-pattern recovery" $ const recoverAsPatterns+ ]+ , compilerPass "id" (30 + v) "identity function detection" $ const (detectIdentityFunctions q)+ ]++-- | Create default CCConfig using default pipeline+mkDefaultCCConfig :: EvaluationStrategy -> CCConfig+mkDefaultCCConfig eval = (eval, EraseUnused, compilerPipeline)++-- | Convert to treeless using default pipeline+toTreeless :: EvaluationStrategy -> QName -> TCM (Maybe C.TTerm)+toTreeless = toTreelessWith . mkDefaultCCConfig++-- | Convert to treeless using default pipeline+toTreeless' :: EvaluationStrategy -> QName -> TCM C.TTerm+toTreeless' = toTreelessWith' . mkDefaultCCConfig++-- | Convert clauses to treeless using default pipeline+ccToTreeless :: EvaluationStrategy -> QName -> CC.CompiledClauses -> TCM C.TTerm+ccToTreeless = ccToTreelessWith . mkDefaultCCConfig
src/full/Agda/Compiler/Treeless/AsPatterns.hs view
@@ -51,7 +51,7 @@ tApp f vs TLam b -> TLam <$> underBinds 1 (recover b) TCon{} -> tApp t [] -- need to recover nullary constructors as well (to make deep @-patterns work)- TLet v b -> TLet <$> recover v <*> underBinds 1 (recover b)+ TLet s v b -> TLet s <$> recover v <*> underBinds 1 (recover b) TCase x ct d bs -> TCase x ct <$> recover d <*> mapM (recoverAlt x) bs TCoerce t -> TCoerce <$> recover t TLit{} -> pure t
src/full/Agda/Compiler/Treeless/Builtin.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE RecordWildCards #-}+ {-# OPTIONS_GHC -Wunused-imports #-} -- | Translates the Agda builtin nat datatype to arbitrary-precision integers.@@ -99,8 +101,18 @@ -- primForce e f es -- >>> -- let e (seq x⁰ ((raise 1 f) x⁰) (raise 1 es))+ --+ -- Now that there are strict let bindings one might think that+ -- PSeq could be removed, but the "unchainCase" transformation+ -- implemented by Agda.Compiler.Treeless.Simplify.simplify can+ -- make strict bindings non-strict. If PSeq is removed, then it+ -- might make sense to have strict bindings that cannot be made+ -- non-strict. TApp (TDef q) (_ : _ : _ : _ : e : f : es)- | isForce q -> tr $ TLet e $ mkTApp (tOp PSeq (TVar 0) $ mkTApp (raise 1 f) [TVar 0]) $ raise 1 es+ | isForce q ->+ tr $ TLet Strict e $+ mkTApp (tOp PSeq (TVar 0) $ mkTApp (raise 1 f) [TVar 0]) $+ raise 1 es TApp (TCon s) [e] | isSuc s -> case tr e of@@ -126,14 +138,17 @@ TCase 0 _ d bs' -> map sucBranch bs' ++ [nPlusKAlt 1 d] b -> [nPlusKAlt 1 b] where- sucBranch (TALit (LitNat i) b) = TALit (LitNat (i + 1)) $ TLet (tInt i) b+ sucBranch (TALit (LitNat i) b) =+ TALit (LitNat (i + 1)) $ TLet Strict (tInt i) b sucBranch alt | Just (k, b) <- nPlusKView alt =- nPlusKAlt (k + 1) $ TLet (tOp PAdd (TVar 0) (tInt 1)) $+ nPlusKAlt (k + 1) $+ TLet Strict (tOp PAdd (TVar 0) (tInt 1)) $ applySubst ([TVar 1, TVar 0] ++# wkS 2 idS) b sucBranch _ = __IMPOSSIBLE__ - nPlusKAlt k b = TAGuard (tOp PGeq (TVar e) (tInt k)) $- TLet (tOp PSub (TVar e) (tInt k)) b+ nPlusKAlt k b =+ TAGuard (tOp PGeq (TVar e) (tInt k)) $+ TLet Strict (tOp PSub (TVar e) (tInt k)) b TACon c 1 b | isPos c -> case tr b of -- collapse nested nat patterns@@ -152,13 +167,14 @@ TCase 0 _ d bs -> map negsucBranch bs ++ [negAlt d] b -> [negAlt b] where- body b = TLet (tNegPlusK 1 (TVar e)) b+ body b = TLet Strict (tNegPlusK 1 (TVar e)) b negAlt b = TAGuard (tOp PLt (TVar e) (tInt 0)) $ body b negsucBranch (TALit (LitNat i) b) = TALit (LitNat (-i - 1)) $ body b negsucBranch alt | Just (k, b) <- nPlusKView alt = TAGuard (tOp PLt (TVar e) (tInt (-k))) $- body $ TLet (tNegPlusK (k + 1) (TVar $ e + 1)) b+ body $+ TLet Strict (tNegPlusK (k + 1) (TVar $ e + 1)) b negsucBranch _ = __IMPOSSIBLE__ TACon c a b -> [TACon c a (tr b)]@@ -179,7 +195,7 @@ TLam b -> TLam (tr b) TApp a bs -> TApp (tr a) (map tr bs)- TLet e b -> TLet (tr e) (tr b)+ TLet s e b -> TLet s (tr e) (tr b) inferCaseType t (TACon c _ _ : _) | isZero c = t { caseType = CTNat }@@ -188,7 +204,8 @@ | isNegSuc c = t { caseType = CTInt } inferCaseType t _ = t - nPlusKView (TAGuard (TApp (TPrim PGeq) [TVar 0, (TLit (LitNat k))])- (TLet (TApp (TPrim PSub) [TVar 0, (TLit (LitNat j))]) b))+ nPlusKView+ (TAGuard (TApp (TPrim PGeq) [TVar 0, (TLit (LitNat k))])+ (TLet _ (TApp (TPrim PSub) [TVar 0, (TLit (LitNat j))]) b)) | k == j = Just (k, b) nPlusKView _ = Nothing
src/full/Agda/Compiler/Treeless/Compare.hs view
@@ -9,12 +9,12 @@ equalTerms :: TTerm -> TTerm -> Bool equalTerms u v = case (evalPrims u, evalPrims v) of- (TLet s u@(TCase 0 _ _ _), TLet t v@(TCase 0 _ _ _)) ->+ (TLet _ s u@(TCase 0 _ _ _), TLet _ t v@(TCase 0 _ _ _)) -> equalTerms s t && equalTerms u v- (TLet _ (TCase 0 _ _ _), _) -> False- (_, TLet _ (TCase 0 _ _ _)) -> False- (TLet t u, v) -> equalTerms (subst 0 t u) v- (u, TLet t v) -> equalTerms u (subst 0 t v)+ (TLet _ _ (TCase 0 _ _ _), _) -> False+ (_, TLet _ _ (TCase 0 _ _ _)) -> False+ (TLet _ t u, v) -> equalTerms (subst 0 t u) v+ (u, TLet _ t v) -> equalTerms u (subst 0 t v) (u, v) | u == v -> True (TApp f us, TApp g vs) -> eqList equalTerms (f : us) (g : vs) (TCase x _ d as, TCase y _ e bs) -> x == y && equalTerms d e && eqList equalAlts as bs
src/full/Agda/Compiler/Treeless/EliminateDefaults.hs view
@@ -14,23 +14,36 @@ import Agda.Compiler.Treeless.Subst () --instance only +-- Eliminate a case default.+-- Leaves its argument unchanged if:+-- * it not a data-type case split.+-- * the default case is unreachable (this makes the function idempotent)+eliminateCaseDefaultAtTopLevelIfPresent :: TTerm -> TCM TTerm+eliminateCaseDefaultAtTopLevelIfPresent (TCase sc ci@CaseInfo{caseType = CTData qn} def alts)+ | not (isUnreachable def) = do+ dtCons <- defConstructors . theDef <$> getConstInfo qn+ let missingCons = dtCons List.\\ map aCon alts+ newAlts <- forM missingCons $ \con -> do+ Constructor {conArity = ar} <- theDef <$> getConstInfo con+ return $ TACon con ar (TVar ar)++ alts' <- (++ newAlts) <$> mapM (trAlt . raise 1) alts++ -- This binding is non-strict, see issue #8759.+ return $ TLet NonStrict def $ TCase (sc + 1) ci tUnreachable alts'+eliminateCaseDefaultAtTopLevelIfPresent t = pure t++trAlt :: TAlt -> TCM TAlt+trAlt = \case+ TAGuard g b -> TAGuard <$> eliminateCaseDefaults g <*> eliminateCaseDefaults b+ TACon q a b -> TACon q a <$> eliminateCaseDefaults b+ TALit l b -> TALit l <$> eliminateCaseDefaults b+ eliminateCaseDefaults :: TTerm -> TCM TTerm eliminateCaseDefaults = tr where tr :: TTerm -> TCM TTerm- tr = \case- TCase sc ct@CaseInfo{caseType = CTData qn} def alts- | not (isUnreachable def) -> do- dtCons <- defConstructors . theDef <$> getConstInfo qn- let missingCons = dtCons List.\\ map aCon alts- def <- tr def- newAlts <- forM missingCons $ \con -> do- Constructor {conArity = ar} <- theDef <$> getConstInfo con- return $ TACon con ar (TVar ar)-- alts' <- (++ newAlts) <$> mapM (trAlt . raise 1) alts-- return $ TLet def $ TCase (sc + 1) ct tUnreachable alts'+ tr = eliminateCaseDefaultAtTopLevelIfPresent >=> \case TCase sc ct def alts -> TCase sc ct <$> tr def <*> mapM trAlt alts t@TVar{} -> return t@@ -46,10 +59,4 @@ TCoerce a -> TCoerce <$> tr a TLam b -> TLam <$> tr b TApp a bs -> TApp <$> tr a <*> mapM tr bs- TLet e b -> TLet <$> tr e <*> tr b-- trAlt :: TAlt -> TCM TAlt- trAlt = \case- TAGuard g b -> TAGuard <$> tr g <*> tr b- TACon q a b -> TACon q a <$> tr b- TALit l b -> TALit l <$> tr b+ TLet s e b -> TLet s <$> tr e <*> tr b
src/full/Agda/Compiler/Treeless/EliminateLiteralPatterns.hs view
@@ -61,7 +61,7 @@ TCoerce a -> TCoerce (tr a) TLam b -> TLam (tr b) TApp a bs -> TApp (tr a) (map tr bs)- TLet e b -> TLet (tr e) (tr b)+ TLet s e b -> TLet s (tr e) (tr b) -- TODO:: Defined but not used isCaseOn (CTData dt) xs = dt `elem` mapMaybe ($ kit) xs
src/full/Agda/Compiler/Treeless/Erase.hs view
@@ -8,13 +8,14 @@ , isErasable ) where -import Control.Arrow ( first, second ) import Control.Monad.State ( StateT, evalStateT ) +import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Syntax.Internal as I import Agda.Syntax.Treeless import Agda.Syntax.Literal@@ -26,17 +27,17 @@ import Agda.TypeChecking.Pretty import Agda.TypeChecking.Primitive +import Agda.Compiler.Treeless.Pretty () import Agda.Compiler.Treeless.Subst import Agda.Compiler.Treeless.Unused import Agda.Utils.Functor-import Agda.Utils.Lens+import Agda.Utils.IntSet.Infinite ( IntSet )+import Agda.Utils.IntSet.Infinite qualified as IntSet import Agda.Utils.Maybe import Agda.Utils.Memo import Agda.Utils.Monad-import Agda.Syntax.Common.Pretty (prettyShow)-import Agda.Utils.IntSet.Infinite (IntSet)-import qualified Agda.Utils.IntSet.Infinite as IntSet+import Agda.Utils.Tuple ( first, second ) import Agda.Utils.Impossible @@ -67,7 +68,12 @@ runE $ mapM_ getFunInfo cs eraseTerms :: QName -> EvaluationStrategy -> TTerm -> TCM TTerm-eraseTerms q eval t = usedArguments q t *> runE (eraseTop q t)+eraseTerms q eval t = do+ t' <- usedArguments q t *> runE (eraseTop q t)+ reportSDoc "treeless.opt.erase" 40 $+ "Term before erasure:" $$ nest 2 (pretty t) $$+ "Term after erasure:" $$ nest 2 (pretty t')+ return t' where eraseTop q t = do (_, h) <- getFunInfo q@@ -101,13 +107,13 @@ TCon{} -> pure t TApp f es -> tApp <$> erase f <*> mapM erase es TLam b -> tLam <$> erase b- TLet e b -> do+ TLet s e b -> do e <- erase e if isErased e then case b of- TCase 0 _ _ _ -> tLet TErased <$> erase b+ TCase 0 _ _ _ -> tLet s TErased <$> erase b _ -> erase $ subst 0 TErased b- else tLet e <$> erase b+ else tLet s e <$> erase b TCase x t d bs -> do (d, bs) <- pruneUnreachable x (caseErased t) (caseType t) d bs d <- erase d@@ -121,11 +127,13 @@ TCoerce e -> TCoerce <$> erase e -- #3380: this is not safe for strict backends- tLam TErased | eval == LazyEvaluation = TErased- tLam t = TLam t+ tLam TErased = case eval of+ LazyEvaluation _ -> TErased+ EagerEvaluation -> TLam TErased+ tLam t = TLam t - tLet e b- | freeIn 0 b = TLet e b+ tLet s e b+ | freeIn 0 b = TLet s e b | otherwise = strengthen impossible b tApp f [] = f@@ -206,12 +214,18 @@ if isErased erased then getConstructors q else getNotErasedConstructors q- let bs | isErased erased = bs'- | otherwise =- flip filter bs' $ \case- a@TACon{} -> (aCon a) `elem` cs- TAGuard{} -> True- TALit{} -> True+ let (bs, pruned)+ | isErased erased = (bs', [])+ | otherwise =+ flip List.partition bs' $ \case+ a@TACon{} -> (aCon a) `elem` cs+ TAGuard{} -> True+ TALit{} -> True+ lift $ reportSDoc "treeless.opt.erase.prune" 50 $+ ("The match is" <+>+ (if isErased erased then id else ("not" <+>)) "erased.") $$+ "Kept branches:" $$ nest 2 (vcat (map pretty bs)) $$+ "Pruned branches:" $$ nest 2 (vcat (map pretty pruned)) let -- In the case of a match on an erased argument the value d is -- equal to tUnreachable, except perhaps if bs is empty. In the -- latter case complete is True exactly when the type has zero
src/full/Agda/Compiler/Treeless/GuardsToPrims.hs view
@@ -47,7 +47,7 @@ TCoerce a -> TCoerce (tr a) TLam b -> TLam (tr b) TApp a bs -> TApp (tr a) (map tr bs)- TLet e b -> TLet (tr e) (tr b)+ TLet s e b -> TLet s (tr e) (tr b) -- | Split alts into TAGuard alts and other alts. splitAlts :: [TAlt] -> ([TAlt], [TAlt])
src/full/Agda/Compiler/Treeless/Identity.hs view
@@ -6,7 +6,7 @@ import Prelude hiding ((!!)) -- don't use partial functions import Control.Applicative ( Alternative((<|>), empty) )-import Data.Semigroup+import Data.Semigroup ( sconcat ) import qualified Data.List as List import Agda.Syntax.Treeless@@ -84,7 +84,7 @@ case t of TVar x | x >= k -> IdIn [x - k] | otherwise -> notId- TLet _ b -> go (k + 1) b+ TLet _ _ b -> go (k + 1) b TCase _ _ d bs -> sconcat (go k d :| map (goAlt k) bs) TApp (TDef f) args | f == q -> IdIn [ y | (TVar x, y) <- zip (reverse args) [0..], y + k == x ]
src/full/Agda/Compiler/Treeless/NormalizeNames.hs view
@@ -33,7 +33,7 @@ t@TError{} -> return t TLam b -> TLam <$> tr b TApp a bs -> TApp <$> tr a <*> mapM tr bs- TLet e b -> TLet <$> tr e <*> tr b+ TLet s e b -> TLet s <$> tr e <*> tr b TCase sc t def alts -> TCase sc t <$> tr def <*> mapM trAlt alts TCoerce a -> TCoerce <$> tr a
src/full/Agda/Compiler/Treeless/Pretty.hs view
@@ -6,20 +6,23 @@ import Prelude hiding ((!!)) -- don't use partial functions! -import Control.Arrow (first) import Control.Monad.Reader import Data.Maybe import qualified Data.IntMap as IntMap -import Agda.Syntax.Treeless+import Agda.Syntax.Common import Agda.Syntax.Common.Pretty+import Agda.Syntax.Treeless import Agda.Compiler.Treeless.Subst -import Agda.Utils.Impossible import Agda.Utils.Function import Agda.Utils.List+import Agda.Utils.Null (empty)+import Agda.Utils.Tuple (first) +import Agda.Utils.Impossible+ instance Pretty Compiled where pretty Compiled {cTreeless, cArgUsage} = "Compiled {" <?> vcat@@ -83,6 +86,9 @@ instance Pretty TTerm where prettyPrec p t = runP $ prec p (pTerm t) +instance Pretty TAlt where+ prettyPrec p b = runP $ prec p (pAlt b)+ opName :: TPrim -> String opName PAdd = "+" opName PSub = "-"@@ -160,38 +166,51 @@ where (n, b) = tLamView t t@TLet{} -> paren 0 $ withNames (length es) $ \ xs ->- (\ (binds, b) -> sep [ "let" <+> vcat [ sep [ text x <+> "="- , nest 2 e ] | (x, e) <- binds ]- <+> "in", b ])+ (\(binds, b) ->+ sep [ "let" <+>+ vcat [ sep [(strictness s <> text x) <+> "=", nest 2 e]+ | (s, x, e) <- binds+ ] <+>+ "in"+ , b+ ]) <$> pLets (zip xs es) b where (es, b) = tLetView t pLets [] b = ([],) <$> pTerm' 0 b- pLets ((x, e) : bs) b = do+ pLets ((x, (s, e)) : bs) b = do e <- pTerm' 0 e- first ((x, e) :) <$> bindName x (pLets bs b)+ first ((s, x, e) :) <$> bindName x (pLets bs b) - TCase x _ def alts -> paren 0 $+ strictness Strict = "!"+ strictness NonStrict = "~"++ TCase x i def alts -> paren 0 $ (\ sc alts defd ->- sep [ "case" <+> sc <+> "of"+ sep [ "case" <+>+ (if isErased (caseErased i) then "(erased)" else empty) <+>+ sc <+> "of" , nest 2 $ vcat (alts ++ [ "_ →" <+> defd | null alts || def /= TError TUnreachable ]) ] ) <$> pTerm' 0 (TVar x) <*> mapM pAlt alts <*> pTerm' 0 def- where- pAlt (TALit l b) = pAlt' <$> pTerm' 0 (TLit l) <*> pTerm' 0 b- pAlt (TAGuard g b) =- pAlt' <$> (("_" <+> "|" <+>) <$> pTerm' 0 g)- <*> (pTerm' 0 b)- pAlt (TACon c a b) =- withNames' a b $ \ xs -> bindNames xs $- pAlt' <$> pTerm' 0 (TApp (TCon c) [TVar i | i <- reverse [0..a - 1]])- <*> pTerm' 0 b- pAlt' p b = sep [p <+> "→", nest 2 b] TUnit -> pure "()" TSort -> pure "Set" TErased -> pure "_" TError err -> paren 9 $ pure $ "error" <+> text (show (show err)) TCoerce t -> paren 9 $ ("coe" <+>) <$> pTerm' 10 t++pAlt' :: Doc -> Doc -> Doc+pAlt' p b = sep [p <+> "→", nest 2 b]++pAlt :: TAlt -> P Doc+pAlt (TALit l b) = pAlt' <$> pTerm' 0 (TLit l) <*> pTerm' 0 b+pAlt (TAGuard g b) =+ pAlt' <$> (("_" <+> "|" <+>) <$> pTerm' 0 g)+ <*> (pTerm' 0 b)+pAlt (TACon c a b) =+ withNames' a b $ \ xs -> bindNames xs $+ pAlt' <$> pTerm' 0 (TApp (TCon c) [TVar i | i <- reverse [0..a - 1]])+ <*> pTerm' 0 b
src/full/Agda/Compiler/Treeless/Simplify.hs view
@@ -2,11 +2,14 @@ module Agda.Compiler.Treeless.Simplify (simplifyTTerm) where -import Control.Arrow ( (***), second )+import Control.Applicative import Control.Monad ( (>=>), guard ) import Control.Monad.Reader ( MonadReader(..), asks, Reader, runReader )+import Control.Monad.Trans+import Control.Monad.Trans.Maybe import qualified Data.List as List +import Agda.Syntax.Internal (termSize) import Agda.Syntax.Treeless import Agda.Syntax.Literal @@ -16,44 +19,66 @@ import Agda.Compiler.Treeless.Compare +import Agda.Utils.IndexMap (IndexMap)+import qualified Agda.Utils.IndexMap as IndexMap import Agda.Utils.List import Agda.Utils.Maybe+import Agda.Utils.Tuple ( (***), second ) import Agda.Utils.Impossible data SEnv = SEnv- { envSubst :: Substitution' TTerm+ { envSubst :: Substitution' TTerm+ , envStrictness :: IndexMap Strictness+ -- ^ What strictness was the given variable bound with? , envRewrite :: [(TTerm, TTerm)] } type S = Reader SEnv runS :: S a -> a-runS m = runReader m $ SEnv IdS []+runS m = runReader m $ SEnv IdS IndexMap.nil [] -lookupVar :: Int -> S TTerm-lookupVar i = asks $ (`lookupS` i) . envSubst+lookupVar :: Int -> S (Strictness, TTerm)+lookupVar i = do+ env <- ask+ return (IndexMap.index i (envStrictness env), lookupS (envSubst env) i) onSubst :: (Substitution' TTerm -> Substitution' TTerm) -> S a -> S a onSubst f = local $ \ env -> env { envSubst = f (envSubst env) } +onStrictness :: (IndexMap Strictness -> IndexMap Strictness) -> S a -> S a+onStrictness f =+ local (\env -> env { envStrictness = f (envStrictness env) })+ onRewrite :: Substitution' TTerm -> S a -> S a onRewrite rho = local $ \ env -> env { envRewrite = map (applySubst rho *** applySubst rho) (envRewrite env) } addRewrite :: TTerm -> TTerm -> S a -> S a addRewrite lhs rhs = local $ \ env -> env { envRewrite = (lhs, rhs) : envRewrite env } -underLams :: Int -> S a -> S a-underLams i = onRewrite (raiseS i) . onSubst (liftS i)+-- | There is one strictness per binding, and the first element in the+-- list corresponds to the first new binding. -underLam :: S a -> S a-underLam = underLams 1+underLams :: [Strictness] -> S a -> S a+underLams ss =+ onRewrite (raiseS i) . onSubst (liftS i) .+ onStrictness (flip IndexMap.append ss)+ where+ i = length ss -underLet :: TTerm -> S a -> S a-underLet u = onRewrite (raiseS 1) . onSubst (\rho -> wkS 1 $ u :# rho)+underLam :: Strictness -> S a -> S a+underLam s = underLams [s] -bindVar :: Int -> TTerm -> S a -> S a-bindVar x u = onSubst (inplaceS x u `composeS`)+underLet :: Strictness -> TTerm -> S a -> S a+underLet s u =+ onRewrite (raiseS 1) . onSubst (\rho -> wkS 1 $ u :# rho) .+ onStrictness (flip IndexMap.snoc s) +bindVar :: Int -> Strictness -> TTerm -> S a -> S a+bindVar x s u =+ onSubst (inplaceS x u `composeS`) .+ onStrictness (IndexMap.update x s)+ rewrite :: TTerm -> S TTerm rewrite t = do rules <- asks envRewrite@@ -64,17 +89,18 @@ data FunctionKit = FunctionKit { modAux, divAux, natMinus, true, false :: Maybe QName } -simplifyTTerm :: TTerm -> TCM TTerm-simplifyTTerm t = do+simplifyTTerm :: EvaluationStrategy -> TTerm -> TCM TTerm+simplifyTTerm eval t = do kit <- FunctionKit <$> getBuiltinName builtinNatModSucAux <*> getBuiltinName builtinNatDivSucAux <*> getBuiltinName builtinNatMinus <*> getBuiltinName builtinTrue <*> getBuiltinName builtinFalse- return $ runS $ simplify kit t+ return $ runS $ simplify eval kit t -simplify :: FunctionKit -> TTerm -> S TTerm-simplify FunctionKit{..} = simpl+simplify :: EvaluationStrategy -> FunctionKit -> TTerm -> S TTerm+simplify eval FunctionKit{ divAux, modAux, natMinus, true, false } =+ simpl where simpl = rewrite' >=> unchainCase >=> \case @@ -104,10 +130,10 @@ f <- simpl f es <- traverse simpl es maybeMinusToPrim f es- TLam b -> TLam <$> underLam (simpl b)- t@TLit{} -> pure t- t@TCon{} -> pure t- TLet e b -> do+ TLam b -> TLam <$> underLam (defaultStrictness eval) (simpl b)+ t@TLit{} -> pure t+ t@TCon{} -> pure t+ TLet s e b -> do simpl e >>= \case TPFn P64ToI a -> do -- Inline calls to P64ToI since these trigger optimisations.@@ -115,34 +141,23 @@ -- moment they only do if inlining the entire let looks like a -- good idea. let rho = inplaceS 0 (TPFn P64ToI (TVar 0))- tLet a <$> underLet a (simpl (applySubst rho b))- e -> tLet e <$> underLet e (simpl b)+ tLet s a <$> underLet s a (simpl (applySubst rho b))+ e -> tLet s e <$> underLet s e (simpl b) TCase x t d bs -> do- v <- lookupVar x+ (_, v) <- lookupVar x let (lets, u) = tLetView v- (d, bs) <- pruneBoolGuards d <$> traverse (simplAlt x) bs+ (d, bs) <-+ pruneBoolGuards d <$>+ traverse (simplAlt x (caseInduction t)) bs case u of -- TODO: also for literals- _ | Just (c, as) <- conView u -> simpl $ matchCon lets c as d bs+ _ | Just (c, as) <- conView u ->+ simpl $ matchCon lets c as (caseInduction t) d bs | Just (k, TVar y) <- plusKView u -> simpl . mkLets lets . TCase y t d =<< mapM (matchPlusK y x k) bs- TCase y t1 d1 bs1 -> simpl $ mkLets lets $ TCase y t1 (distrDef case1 d1) $- map (distrCase case1) bs1- where- -- Γ x Δ -> Γ _ Δ Θ y, where x maps to y and Θ are the lets- n = length lets- rho = liftS (x + n + 1) (raiseS 1) `composeS`- singletonS (x + n + 1) (TVar 0) `composeS`- raiseS (n + 1)- case1 = applySubst rho (TCase x t d bs)-- distrDef v d | isUnreachable d = tUnreachable- | otherwise = tLet d v-- distrCase v (TACon c a b) = TACon c a $ TLet b $ raiseFrom 1 a v- distrCase v (TALit l b) = TALit l $ TLet b v- distrCase v (TAGuard g b) = TAGuard g $ TLet b v-- _ -> do+ -- We are not normalizing the case-of-case commuting converison+ -- since it can lead to major code duplication without join points+ -- or continuations. See issue #7595.+ | otherwise -> do d <- simpl d tCase x t d bs @@ -161,25 +176,122 @@ unchainCase e@(TCase x t d bs) = do let (lets, u) = tLetView d k = length lets- return $ case u of- TCase y _ d' bs' | x + k == y ->- mkLets lets $ TCase y t d' $ raise k bs ++ filter (`noOverlap` bs) bs'- _ -> e+ case u of+ TCase y _ d' bs' | x + k == y -> do+ lets <- runMaybeT (mapM safeLet lets)+ return $ case lets of+ Just lets ->+ mkLets lets $ TCase y t d' $+ raise k bs ++ filter (`noOverlap` bs) bs'+ Nothing -> e+ _ -> return e unchainCase e = return e + -- If chained cases of the following form are collapsed, and the+ -- lets moved to the outside, then performance could take a hit+ -- (see issue #8767):+ --+ -- case x of+ -- ⋮+ -- _ -> let … in case y of …+ --+ -- If strict evaluation is used, then this transformation is only+ -- allowed if all let bindings are "safe", i.e. non-strict or+ -- (heuristically) cheap to compute. If non-strict evaluation is+ -- used, then "unsafe" bindings are made non-strict. - mkLets es b = foldr TLet b es+ safeLet :: (Strictness, TTerm) -> MaybeT S (Strictness, TTerm)+ safeLet l@(NonStrict, _) =+ return l+ safeLet l@(Strict, t) = MaybeT $ do+ t' <- runMaybeT (do+ -- The number 30 does not have any special significance other+ -- than being "not too small, but not very large".+ guard (termSize t < 30)+ cheap t)+ return $ case t' of+ Just t -> Just (Strict, t)+ Nothing -> case eval of+ LazyEvaluation _ -> Just (NonStrict, t)+ EagerEvaluation -> Nothing+ where+ cheap :: TTerm -> MaybeT S TTerm+ cheap t = case t of+ -- Error calls should definitely not be evaluated prematurely.+ TError{} -> empty+ -- Case expressions and top-level definitions are treated as+ -- expensive.+ TCase{} -> empty+ TDef{} -> empty+ -- Strictly bound variables are treated as cheap.+ TVar x -> do+ (s, _) <- lift (lookupVar x)+ case s of+ NonStrict -> empty+ Strict -> return t+ -- Lets, coercions and applications of primitives are handled+ -- recursively.+ TLet s t1 t2 -> uncurry TLet <$> safeLet (s, t1) <*> cheap t2+ TCoerce t -> TCoerce <$> cheap t+ TApp t args -> case t of+ TPrim p -> TApp <$> (if cheapPrim p then return (TPrim p)+ else empty)+ <*> mapM cheap args+ _ -> empty+ -- Things that are known to be (basically) values are treated+ -- as cheap.+ TPrim{} -> return t+ TLam{} -> return t+ TLit{} -> return t+ TCon{} -> return t+ TUnit{} -> return t+ TSort{} -> return t+ TErased{} -> return t - matchCon _ _ _ d [] = d- matchCon lets c as d (TALit{} : bs) = matchCon lets c as d bs- matchCon lets c as d (TAGuard{} : bs) = matchCon lets c as d bs- matchCon lets c as d (TACon c' a b : bs)- | c == c' = flip (foldr TLet) lets $ mkLet 0 as (raiseFrom a (length lets) b)- | otherwise = matchCon lets c as d bs+ cheapPrim = \case+ -- String comparison might be expensive.+ PEqS -> False+ -- If expressions are treated as expensive, just like case+ -- expressions.+ PIf -> False+ -- All other primitives are treated as cheap, including PSeq.+ PSeq -> True+ PAdd -> True+ PAdd64 -> True+ PSub -> True+ PSub64 -> True+ PMul -> True+ PMul64 -> True+ PQuot -> True+ PQuot64 -> True+ PRem -> True+ PRem64 -> True+ PGeq -> True+ PLt -> True+ PLt64 -> True+ PEqI -> True+ PEq64 -> True+ PEqF -> True+ PEqC -> True+ PEqQ -> True+ PITo64 -> True+ P64ToI -> True++ mkLets es b = foldr (uncurry TLet) b es++ matchCon _ _ _ _ d [] = d+ matchCon lets c as i d (TALit{} : bs) = matchCon lets c as i d bs+ matchCon lets c as i d (TAGuard{} : bs) = matchCon lets c as i d bs+ matchCon lets c as i d (TACon c' a b : bs)+ | c == c' = flip (foldr (uncurry TLet)) lets $+ mkLet 0 as (raiseFrom a (length lets) b)+ | otherwise = matchCon lets c as i d bs where- mkLet _ [] b = b- mkLet i (a : as) b = TLet (raise i a) $ mkLet (i + 1) as b+ s = defaultConstructorStrictness eval i + mkLet _ [] b = b+ mkLet i (a : as) b = TLet s (raise i a) $ mkLet (i + 1) as b+ -- Simplify let y = x + k in case y of j -> u; _ | g[y] -> v -- to let y = x + k in case x of j - k -> u; _ | g[x + k] -> v matchPlusK :: Int -> Int -> Integer -> TAlt -> S TAlt@@ -196,12 +308,12 @@ pure $ if v `betterThan` u then v else u where inline (TVar x) = do- v <- lookupVar x+ (_, v) <- lookupVar x if v == TVar x then pure v else inline v- inline (TApp f@TPrim{} args) = TApp f <$> mapM inline args- inline u@(TLet _ (TCase 0 _ _ _)) = pure u- inline (TLet e b) = inline (subst 0 e b)- inline u = pure u+ inline (TApp f@TPrim{} args) = TApp f <$> mapM inline args+ inline u@(TLet _ _ (TCase 0 _ _ _)) = pure u+ inline (TLet _ e b) = inline (subst 0 e b)+ inline u = pure u simplPrim t = pure t simplPrim' :: TTerm -> TTerm@@ -315,16 +427,22 @@ | op == PSub = Just (PAdd, -k, u) constArithView _ = Nothing - simplAlt x (TACon c a b) = TACon c a <$> underLams a (maybeAddRewrite (x + a) conTerm $ simpl b)- where conTerm = mkTApp (TCon c) $ map TVar $ downFrom a- simplAlt x (TALit l b) = TALit l <$> maybeAddRewrite x (TLit l) (simpl b)- simplAlt x (TAGuard g b) = TAGuard <$> simpl g <*> simpl b+ simplAlt x i (TACon c a b) =+ TACon c a <$>+ underLams (replicate a (defaultConstructorStrictness eval i))+ (maybeAddRewrite (x + a) conTerm $ simpl b)+ where+ conTerm = mkTApp (TCon c) $ map TVar $ downFrom a+ simplAlt x _ (TALit l b) =+ TALit l <$> maybeAddRewrite x (TLit l) (simpl b)+ simplAlt x _ (TAGuard g b) =+ TAGuard <$> simpl g <*> simpl b -- If x is already bound we add a rewrite, otherwise we bind x to rhs. maybeAddRewrite x rhs cont = do- v <- lookupVar x+ (s, v) <- lookupVar x case v of- TVar y | x == y -> bindVar x rhs $ cont+ TVar y | x == y -> bindVar x s rhs $ cont _ -> addRewrite v rhs cont isTrue (TCon c) = Just c == true@@ -341,9 +459,9 @@ maybeMinusToPrim f es = tApp f es - tLet (TVar x) b = subst 0 (TVar x) b- tLet e (TVar 0) = e- tLet e b = TLet e b+ tLet _ (TVar x) b = subst 0 (TVar x) b+ tLet _ e (TVar 0) = e+ tLet s e b = TLet s e b tCase :: Int -> CaseInfo -> TTerm -> [TAlt] -> S TTerm tCase x t d [] = pure d@@ -363,7 +481,7 @@ where bs' = filter (not . isUnreachable) bs - lookupIfVar (TVar i) = lookupVar i+ lookupIfVar (TVar i) = snd <$> lookupVar i lookupIfVar t = pure t noOverlap b bs = not $ any (overlapped b) bs@@ -404,25 +522,31 @@ tCase' x t d bs = pruneLitCases x t d bs tApp :: TTerm -> [TTerm] -> S TTerm- tApp (TLet e b) es = TLet e <$> underLet e (tApp b (raise 1 es))+ tApp (TLet s e b) es = TLet s e <$> underLet s e (tApp b (raise 1 es)) tApp (TCase x t d bs) es = do d <- tApp d es- bs <- mapM (`tAppAlt` es) bs+ bs <- mapM (flip (tAppAlt (caseInduction t)) es) bs simpl $ TCase x t d bs -- will resimplify branches tApp (TVar x) es = do- v <- lookupVar x+ (_, v) <- lookupVar x case v of _ | v /= TVar x && isAtomic v -> tApp v es TLam{} -> tApp v es -- could blow up the code _ -> pure $ mkTApp (TVar x) es tApp f [] = pure f tApp (TLam b) (TVar i : es) = tApp (subst 0 (TVar i) b) es- tApp (TLam b) (e : es) = tApp (TLet e b) es+ tApp (TLam b) (e : es) =+ tApp (TLet (defaultStrictness eval) e b) es+ -- Applications are strict in strict backends and non-strict in+ -- non-strict backends. tApp f es = pure $ TApp f es - tAppAlt (TACon c a b) es = TACon c a <$> underLams a (tApp b (raise a es))- tAppAlt (TALit l b) es = TALit l <$> tApp b es- tAppAlt (TAGuard g b) es = TAGuard g <$> tApp b es+ tAppAlt i (TACon c a b) es =+ TACon c a <$>+ underLams (replicate a (defaultConstructorStrictness eval i))+ (tApp b (raise a es))+ tAppAlt _ (TALit l b) es = TALit l <$> tApp b es+ tAppAlt _ (TAGuard g b) es = TAGuard g <$> tApp b es isAtomic = \case TVar{} -> True
src/full/Agda/Compiler/Treeless/Subst.hs view
@@ -5,7 +5,7 @@ import qualified Data.IntMap as IntMap import Data.IntMap (IntMap) import Data.Maybe-import Data.Semigroup ( Semigroup, (<>), All(..), Any(..) )+import Data.Semigroup ( All(..), Any(..) ) import Agda.Syntax.Treeless import Agda.TypeChecking.Substitute@@ -33,12 +33,20 @@ TVar i -> lookupS rho i TApp f ts -> tApp (applySubst rho f) (applySubst rho ts) TLam b -> TLam (applySubst (liftS 1 rho) b)- TLet e b -> TLet (applySubst rho e) (applySubst (liftS 1 rho) b)+ TLet s e b -> TLet s (applySubst rho e)+ (applySubst (liftS 1 rho) b) TCase i t d bs -> case applySubst rho (TVar i) of TVar j -> TCase j t (applySubst rho d) (applySubst rho bs)- e -> TLet e $ TCase 0 t (applySubst rho' d) (applySubst rho' bs)- where rho' = wkS 1 rho+ e -> TLet s e $+ TCase 0 t (applySubst rho' d) (applySubst rho' bs)+ where+ rho' = wkS 1 rho+ -- If the match is lazy, use a non-strict let, otherwise a+ -- strict let. Note that, if the backend is strict, then+ -- 'Agda.Compiler.ToTreeless.casetree' makes all matches+ -- strict.+ s = if caseLazy t then NonStrict else Strict TCoerce e -> TCoerce (applySubst rho e) where tApp (TPrim PSeq) [TErased, b] = b@@ -79,6 +87,7 @@ -- Andreas, 2019-07-10: this free variable computation should be rewritten -- in the style of TypeChecking.Free.Lazy. -- https://github.com/agda/agda/commit/03eb3945114a4ccdb449f22d69db8d6eaa4699b8#commitcomment-34249120+-- András, 2026-02-13: now called TypeChecking.Free.Generic class HasFree a where freeVars :: a -> IntMap Occurs@@ -126,7 +135,7 @@ TApp (TPrim PSeq) [TVar x, b] -> freeVars (InSeq x, b) TApp f ts -> freeVars (f, ts) TLam b -> underLambda <$> freeVars (Binder 1 b)- TLet e b -> freeVars (e, Binder 1 b)+ TLet _ e b -> freeVars (e, Binder 1 b) TCase i _ d bs -> freeVars (i, (d, bs)) TCoerce t -> freeVars t
src/full/Agda/Compiler/Treeless/Uncase.hs view
@@ -23,7 +23,7 @@ TLam b -> TLam $ uncase b TLit{} -> t TCon{} -> t- TLet e b -> tLet (uncase e) (uncase b)+ TLet s e b -> tLet s (uncase e) (uncase b) TCase x t d bs -> doCase x t (uncase d) (map uncaseAlt bs) TUnit{} -> t TSort{} -> t@@ -59,10 +59,10 @@ equalTo x t (TALit l b) = equalTerms (subst x (TLit l) t) (subst x (TLit l) b) equalTo x t (TAGuard _ b) = equalTerms t b - tLet e b =+ tLet s e b = case occursIn 0 b of Occurs 0 _ _ -> strengthen impossible b- _ -> TLet e b+ _ -> TLet s e b -- Primitive operations are already strict tApp (TPrim PSeq) [_, b@(TApp (TPrim op) _)]
src/full/Agda/Compiler/Treeless/Unused.hs view
@@ -5,6 +5,8 @@ , stripUnusedArguments ) where +import Prelude hiding (null, zip, zipWith)+ import Data.Maybe import Agda.Syntax.Common@@ -16,8 +18,12 @@ import Agda.Compiler.Treeless.Pretty () -- instance only import Agda.Utils.Function ( iterateUntilM )-import Agda.Utils.List ( downFrom )+import Agda.Utils.List ( downFrom, takeExactly )+import Agda.Utils.ListInf qualified as ListInf+import Agda.Utils.Null+import Agda.Utils.Singleton import qualified Agda.Utils.VarSet as VarSet+import Agda.Utils.Zip usedArguments :: QName -> TTerm -> TCM [ArgUsage] usedArguments q t = computeUnused q b (replicate n ArgUnused)@@ -31,7 +37,7 @@ reportSLn "treeless.opt.unused" 50 $ concat [ "Unused approximation for ", prettyShow q, ": "- , unwords [ if u == ArgUsed then [x] else "_" | (x, u) <- zip ['a'..] used ]+ , unwords [ if u == ArgUsed then [x] else "_" | (x, u) <- zip (ListInf.upFrom 'a') used ] ] -- Update usage information q to so far "best" value. setCompiledArgUse q used@@ -44,19 +50,19 @@ ] where go = \case- TVar x -> pure $ VarSet.singleton x- TPrim{} -> pure VarSet.empty- TDef{} -> pure VarSet.empty- TLit{} -> pure VarSet.empty- TCon{} -> pure VarSet.empty+ TVar x -> pure $ singleton x+ TPrim{} -> pure empty+ TDef{} -> pure empty+ TLit{} -> pure empty+ TCon{} -> pure empty TApp (TDef f) ts -> do used <- fromMaybe [] <$> getCompiledArgUse f- VarSet.unions <$> sequence [ go t | (t, ArgUsed) <- zip ts $ used ++ repeat ArgUsed ]+ VarSet.unions <$> sequence [ go t | (t, ArgUsed) <- zip ts $ ListInf.pad used ArgUsed ] - TApp f ts -> VarSet.unions <$> mapM go (f : ts)- TLam b -> underBinder <$> go b- TLet e b -> do+ TApp f ts -> VarSet.unions <$> mapM go (f : ts)+ TLam b -> underBinder <$> go b+ TLet _ e b -> do uses <- go b if | VarSet.member 0 uses -> VarSet.union (underBinder uses) <$> go e | otherwise -> pure (underBinder uses)@@ -66,10 +72,10 @@ case e of Erased{} -> cont NotErased{} -> VarSet.insert x <$> cont- TUnit{} -> pure VarSet.empty- TSort{} -> pure VarSet.empty- TErased{} -> pure VarSet.empty- TError{} -> pure VarSet.empty+ TUnit{} -> pure empty+ TSort{} -> pure empty+ TErased{} -> pure empty+ TError{} -> pure empty TCoerce t -> go t goAlt _ (TALit _ b) = go b@@ -81,15 +87,14 @@ goAlt _ (TACon _ a b) = underBinders a <$> go b underBinder = underBinders 1- underBinders 0 = id- underBinders n = VarSet.filterGE 0 . VarSet.subtract n+ underBinders n = VarSet.strengthen n stripUnusedArguments :: [ArgUsage] -> TTerm -> TTerm stripUnusedArguments used t = mkTLam m $ applySubst rho b where (n, b) = tLamView t m = length $ filter (== ArgUsed) used'- used' = reverse $ take n $ used ++ repeat ArgUsed+ used' = reverse $ takeExactly ArgUsed n used rho = computeSubst used' computeSubst (ArgUnused : bs) = TErased :# computeSubst bs computeSubst (ArgUsed : bs) = liftS 1 $ computeSubst bs
src/full/Agda/Interaction/Base.hs view
@@ -46,10 +46,34 @@ -- recorded in 'theTCState', but when new interaction points are -- added by give or refine Agda does not ensure that the ranges -- of later interaction points are updated.+ --+ -- For example, consider a term @cons ?0 ?1@ with some ranges @r0@ @r1@@+ -- for the two interaction points.+ -- We refine @?0 := cons ?2 ?3@.+ -- The new interaction points will get ranges @r2 = r3 = r0@.+ -- We cannot do much better than that, as they are constrained by+ -- @r0 ≤ r2 ≤ r3 < r1@.+ -- At this point @('Range','InteractionId')@ still orders the IPs correctly.+ -- Now we refine @?2 := cons ?4 ?5@ with @r4 = r5 = r2@;+ -- this breaks the order maintained by @('Range','InteractionId')@.+ --+ -- So we need some other structure to remember the correct order of IPs.+ -- The list 'theInteractionPoints' serves this purpose.+ --+ -- Alternatively, we could maintain for entries in 'InteractionPoints'+ -- a path @p : Genesis = [Int]@ into their genesis tree.+ -- E.g. for @?2@ we would have @p2 = [0]@ (the first child of @?0@)+ -- and @p3 = [1]@ (the second child of @?0@).+ -- Then @p4 = [0,0]@ and @p5 = [0,1]@.+ -- The order @('Range','Genesis')@ would be correct then. , theCurrentFile :: Maybe CurrentFile -- ^ The file which the state applies to. Only stored if the -- module was successfully type checked (potentially with -- warnings).+ , theCurrentFilePath :: Maybe AbsolutePath+ -- ^ The path supplied by the current interaction command. Unlike+ -- 'theCurrentFile', this is available while a file is being loaded,+ -- even if loading fails. , optionsOnReload :: CommandLineOptions -- ^ Reset the options on each reload to these. , oldInteractionScopes :: !OldInteractionScopes@@ -72,6 +96,7 @@ CommandState { theInteractionPoints = [] , theCurrentFile = Nothing+ , theCurrentFilePath = Nothing , optionsOnReload = defaultOptions , oldInteractionScopes = Map.empty , commandQueue = commandQueue@@ -142,7 +167,8 @@ -- @argv@ as the command-line options. = Cmd_load FilePath [String] - | Cmd_constraints+ -- | Show constraints on goals.+ | Cmd_constraints Rewrite -- | Show unsolved metas. If there are no unsolved metas but unsolved constraints -- show those instead.@@ -460,10 +486,21 @@ return (b, s) -- | Ordered ascendingly by degree of normalization.-data Rewrite = AsIs | Instantiated | HeadNormal | Simplified | Normalised+data Rewrite = AsIs | Instantiated | HeadNormal | Simplified | Normalised deriving (Show, Read, Eq, Ord) -data ComputeMode = DefaultCompute | HeadCompute | IgnoreAbstract | UseShowInstance+-- | Modifier for the interactive computation command,+-- specifying the mode of computation and result display.+--+data ComputeMode+ = DefaultCompute+ -- ^ Fully 'normalise'.+ | HeadCompute+ -- ^ 'reduce' to weak head normal form.+ | IgnoreAbstract+ -- ^ 'normalise', unfolding even @abstract@ and @NON_TERMINATING@ definitions.+ | UseShowInstance+ -- ^ 'normalise' to a string literal and wrap it in a @show@. deriving (Show, Read, Eq) data UseForce
src/full/Agda/Interaction/BasicOps.hs view
@@ -5,7 +5,6 @@ import Prelude hiding (null) -import Control.Arrow ( first ) import Control.Monad.Except ( MonadError(..) ) import Control.Monad.State ( MonadState(..), evalState ) import Control.Monad.Identity ( runIdentity )@@ -16,6 +15,7 @@ import qualified Data.Map.Strict as MapS import qualified Data.Set as Set import qualified Data.List as List+import Data.Bifunctor (first, second) import Data.Maybe import Data.Monoid import Data.Function (on)@@ -33,6 +33,7 @@ import Agda.Syntax.Abstract.Views as A import Agda.Syntax.Abstract.Pretty import Agda.Syntax.Common+import Agda.Syntax.Concrete.Operators (parseApplication) import Agda.Syntax.Info (MetaInfo(..),emptyMetaInfo,exprNoRange,defaultAppInfo_,defaultAppInfo) import qualified Agda.Syntax.Info as Info import Agda.Syntax.Internal as I@@ -46,6 +47,7 @@ import Agda.Syntax.Parser import Agda.TheTypeChecker+import Agda.TypeChecking.Conversion.Errors import Agda.TypeChecking.Constraints import Agda.TypeChecking.Conversion import Agda.TypeChecking.Errors ( getAllWarnings, Verbalize(..) )@@ -58,7 +60,7 @@ import Agda.TypeChecking.Telescope import Agda.TypeChecking.With import Agda.TypeChecking.Coverage-import Agda.TypeChecking.Coverage.Match ( SplitPattern )+import Agda.TypeChecking.Coverage.SplitPattern ( SplitPattern ) import Agda.TypeChecking.Records import Agda.TypeChecking.Pretty ( PrettyTCM, prettyTCM ) import Agda.TypeChecking.Pretty.Constraint (prettyRangeConstraint)@@ -90,6 +92,9 @@ import Agda.Utils.Size import Agda.Utils.String import Agda.Utils.WithDefault ( WithDefault'(Value) )+import Agda.Utils.Tuple.Strict (Pair(..))+import Agda.Utils.Tuple.Strict qualified as Strict+import Agda.Utils.Maybe.Strict qualified as Strict import Agda.Utils.Impossible @@ -98,25 +103,20 @@ parseExpr :: Range -> String -> TCM C.Expr parseExpr rng s = do (C.ExprWhere e wh, attrs) <-- runPM $ parsePosString exprWhereParser pos s+ runPM $ parseRangeString exprWhereParser rng s checkAttributes attrs unless (null wh) $ interactionError UnexpectedWhere return e- where pos = fromMaybe (startPos Nothing) $ rStart rng parseExprIn :: InteractionId -> Range -> String -> TCM Expr parseExprIn ii rng s = do- mId <- lookupInteractionId ii- updateMetaVarRange mId rng- mi <- getMetaInfo <$> lookupLocalMeta mId- e <- parseExpr rng s+ e <- parseExpr rng s -- Andreas, 2019-08-19, issue #4007 -- We need to be in the TCEnv of the meta variable -- such that the scope checker can label the clause -- of a parsed extended lambda as IsAbstract if the -- interaction point was created in AbstractMode.- withMetaInfo mi $- concreteToAbstract (clScope mi) e+ withInteractionId ii $ concreteToAbstract_ e -- Type check the given expression and assign its value to the meta -- Precondition: we are in the context where the given meta was created.@@ -134,7 +134,7 @@ t' <- t `piApplyM` permute (takeP (length ctx) $ mvPermutation mv) ctx traceCall (CheckExprCall CmpLeq e t') $ do reportSDoc "interaction.give" 20 $ do- a <- asksTC envAbstractMode+ a <- viewTC eAbstractMode TP.hsep [ TP.text ("give(" ++ show a ++ "): instantiated meta type =") , prettyTCM t'@@ -186,7 +186,7 @@ IPNoClause -> return () IPClause{ipcQName = f} -> do mb <- defMutual <$> getConstInfo f- terErrs <- localTC (\ e -> e { envMutualBlock = Just mb }) $ termMutual []+ terErrs <- localTC (set eMutualBlock (Just mb)) $ termMutual [] List1.unlessNull terErrs $ warning . TerminationIssue -- TODO redo positivity check! @@ -195,13 +195,10 @@ Bool -- ^ Elaborating? -> UseForce -- ^ Skip safety checks? -> InteractionId -- ^ Hole.- -> Maybe Range -> Expr -- ^ The expression to give. -> TCM Term -- ^ Value of the expression-give_ elaborating force ii mr e = do- -- if Range is given, update the range of the interaction meta+give_ elaborating force ii e = do mi <- lookupInteractionId ii- whenJust mr $ updateMetaVarRange mi reportSDoc "interaction.give" 10 $ "giving expression" TP.<+> prettyTCM e reportSDoc "interaction.give" 50 $ TP.text $ show $ deepUnscope e -- Try to give mi := e@@ -220,11 +217,10 @@ give :: UseForce -- ^ Skip safety checks? -> InteractionId -- ^ Hole.- -> Maybe Range -> Expr -- ^ The expression to give. -> TCM Expr -- ^ If successful, the very expression is returned unchanged.-give force ii mr e = do- _ <- give_ False force ii mr e+give force ii e = do+ _ <- give_ False force ii e removeInteractionPoint ii return e @@ -233,11 +229,10 @@ :: Rewrite -- ^ Normalise result? -> UseForce -- ^ Skip safety checks? -> InteractionId -- ^ Hole.- -> Maybe Range -> Expr -- ^ The expression to give. -> TCM Expr -- ^ If successful, return the elaborated expression.-elaborate_give norm force ii mr e = withInteractionId ii $ do- v <- give_ True force ii mr e+elaborate_give norm force ii e = withInteractionId ii $ do+ v <- give_ True force ii e reportSDoc "interaction.give" 40 $ "v = " TP.<+> pure (pretty v) -- Reduce projection-likes before quoting, otherwise instance -- selection may fail on reload (see #6203).@@ -251,35 +246,50 @@ refine :: UseForce -- ^ Skip safety checks when giving? -> InteractionId -- ^ Hole.- -> Maybe Range -> Expr -- ^ The expression to refine the hole with.+ -- Precondition: it was parsed in the context of the hole+ -- so its ranges are correct. -> TCM Expr -- ^ The successfully given expression.-refine force ii mr e = do- mi <- lookupInteractionId ii- mv <- lookupLocalMeta mi- let range = fromMaybe (getRange mv) mr- scope = M.getMetaScope mv+refine force ii e = do reportSDoc "interaction.refine" 10 $ "refining with expression" TP.<+> prettyTCM e reportSDoc "interaction.refine" 50 $ TP.text $ show $ deepUnscope e+ -- Andreas, 2025-11-12, issue #8197+ -- We use the range of @e@ which might contain questionmarks+ -- so that the new questionmarks appended to @e@+ -- can receive a 'Range' relatively correct to the ranges+ -- of the questionmarks withing @e@.+ -- If @e@ has no range information, fall back to the current interaction+ -- point range so appended metas still get a real file range.+ holeRange <- getInteractionRange ii+ let exprRange = getRange e+ range = if null exprRange then holeRange else exprRange+ scope <- getInteractionScope ii -- We try to append up to 10 meta variables tryRefine 10 range scope e where- tryRefine :: Int -> Range -> ScopeInfo -> Expr -> TCM Expr- tryRefine nrOfMetas r scope = try nrOfMetas Nothing+ -- This wrapper around 'try' makes 'range' and 'scope' available there.+ tryRefine :: Int -> Range -> ScopeInfo -> Expr -> TCM Expr+ tryRefine nrOfMetas range scope = try nrOfMetas Nothing where try :: Int -> Maybe TCErr -> Expr -> TCM Expr- try 0 err e = interactionError $ CannotRefine $ case err of- Just (TypeError _ _ cl) | UnequalTerms _ I.Pi{} _ _ <- clValue cl ->- "functions with 10 or more arguments"- _ -> ""- try n _ e = give force ii (Just r) e `catchError` \err -> try (n - 1) (Just err) =<< appMeta e+ try 0 err e = do+ reportSDoc "interaction.refine" 30 $ "final error:" TP.$$ prettyTCM err+ interactionError $ CannotRefine $ case err of+ Just (TypeError _ _ cl) | ConversionError_ (ConversionError _ _ I.Pi{} _ _) <- clValue cl ->+ "functions with 10 or more arguments"+ _ -> ""+ try n _ e = give force ii e `catchError` \err -> do+ reportSDoc "interaction.refine" 30 $ "retrying because of error:" TP.$$ prettyTCM err+ try (n - 1) (Just err) =<< appMeta e -- Apply A.Expr to a new meta appMeta :: Expr -> TCM Expr appMeta e = do- let rng = rightMargin r -- Andreas, 2013-05-01 conflate range to its right margin to ensure that appended metas are last in numbering. This fixes issue 841.+ -- Andreas, 2013-05-01 conflate range to its right margin to ensure that appended metas are last in numbering.+ -- This fixes issue 841.+ let rng = rightMargin range -- Make new interaction point ii <- registerInteractionPoint False rng Nothing let info = Info.MetaInfo@@ -311,7 +321,7 @@ where subX (A.Var y) | x == y = namedArg arg subX e = e _ -> App i e arg- return $ smartApp (defaultAppInfo r) e $ defaultNamedArg metaVar+ return $ smartApp (defaultAppInfo range) e $ defaultNamedArg metaVar {-| Evaluate the given expression in the current environment -} evalInCurrent :: ComputeMode -> Expr -> TCM Expr@@ -341,9 +351,19 @@ Simplified -> simplify Normalised -> normalise --- | Modifier for the interactive computation command,--- specifying the mode of computation and result display.---+-- | Evaluate the given expression in the current environment+-- with allowed reductions modified according to 'ComputeMode'.+computeInCurrent :: ComputeMode -> Expr -> TCM Expr+computeInCurrent cmode e =+ withComputeIgnoreAbstract cmode $ evalInCurrent cmode e++-- | Modify the allowed reductions according to 'ComputeMode'.+{-# SPECIALIZE withComputeIgnoreAbstract :: ComputeMode -> TCM a -> TCM a #-}+withComputeIgnoreAbstract :: MonadTCEnv m => ComputeMode -> m a -> m a+withComputeIgnoreAbstract cmode =+ applyWhen (computeIgnoreAbstract cmode) $+ allowNonTerminatingReductions . ignoreAbstractMode+ computeIgnoreAbstract :: ComputeMode -> Bool computeIgnoreAbstract DefaultCompute = False computeIgnoreAbstract HeadCompute = False@@ -465,8 +485,8 @@ <*> (reify =<< getMetaType m) <*> forM (fromMaybe [] mcands) (\ (Candidate q tm ty _) -> do (,,) <$> reify tm <*> reify tm <*> reify ty)- reify (ResolveInstanceHead q) = return $ ResolveInstanceOF q- reify (IsEmpty r a) = IsEmptyType <$> reify a+ reify (ResolveInstanceHead kwr q) = return $ ResolveInstanceOF q+ reify (IsEmpty r a) = IsEmptyType <$> reify (unDom a) reify (CheckSizeLtSat a) = SizeLtSat <$> reify a reify (CheckFunDef i q cs err) = do a <- reify =<< defType <$> getConstInfo q@@ -482,6 +502,14 @@ OfType <$> reify (MetaV m []) <*> reify t reify (CheckType t) = JustType <$> reify t reify (UsableAtModality _ _ mod t) = UsableAtMod mod <$> reify t+ reify (RewConstraint (LocalEquation g t u a)) = do+ -- I think reifying rewrite constraints to 'CmpInType' should be fine+ -- (ultimately 'RewConstraint' is basically just 'ValueCmp' with a nicer+ -- error message)+ t' <- addContext g $ reify t+ u' <- addContext g $ reify u+ a' <- addContext g $ reify a+ return $ CmpInType CmpEq t' u' a' {-# SPECIALIZE reify :: Constraint -> TCM (ReifiesTo Constraint) #-} instance (Pretty a, Pretty b) => PrettyTCM (OutputForm a b) where@@ -502,8 +530,8 @@ | otherwise = "," blockedOn (UnblockOnAll bs) | Set.null bs = empty- blockedOn (UnblockOnAny bs) | Set.null bs = "stuck" P.<> comma- blockedOn u = "blocked on" <+> (pretty u P.<> comma)+ blockedOn (UnblockOnAny bs) | Set.null bs = "stuck" <> comma+ blockedOn u = "blocked on" <+> (pretty u <> comma) prange r | null s = empty | otherwise = text $ " [ at " ++ s ++ " ]"@@ -617,9 +645,6 @@ cl <- reify (PConstr Set.empty alwaysUnblock c) enterClosure cl abstractToConcrete_ -getConstraints :: TCM [OutputForm C.Expr C.Expr]-getConstraints = getConstraints' return $ const True- namedMetaOf :: OutputConstraint A.Expr a -> a namedMetaOf (OfType i _) = i namedMetaOf (JustType i) = i@@ -653,7 +678,7 @@ UnBlock{} -> Nothing FindInstance{} -> Nothing ResolveInstanceHead{} -> Nothing- IsEmpty r t -> isMeta (unEl t)+ IsEmpty r t -> isMeta (unEl (unDom t)) CheckSizeLtSat t -> isMeta t CheckFunDef{} -> Nothing HasBiggerSort a -> Nothing@@ -664,6 +689,7 @@ CheckType t -> isMeta (unEl t) CheckLockedVars t _ _ _ -> isMeta t UsableAtModality _ ms _ t -> caseMaybe ms (isMeta t) $ \ s -> isMetaS s `mplus` isMeta t+ RewConstraint (LocalEquation g t u a) -> isMeta t `mplus` isMeta u isMeta :: Term -> Maybe Elims isMeta (MetaV m' es_m) | m == m' = pure es_m@@ -720,13 +746,14 @@ , 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)- cs <- forM cs $ \c -> do- cl <- reify c+-- | Get meta solutions and constraints.+getConstraints :: Rewrite -> TCM [OutputForm C.Expr C.Expr]+getConstraints norm = do+ cs <- stripConstraintPids <$> M.getAllConstraints+ cs <- forM cs \ (c :: ProblemConstraint) -> do+ cl <- reify =<< normalForm norm c enterClosure cl abstractToConcrete_- ss <- mapM toOutputForm =<< getSolvedInteractionPoints True AsIs -- get all+ ss <- mapM toOutputForm =<< getSolvedInteractionPoints True norm -- get all return $ ss ++ cs where toOutputForm (ii, mi, e) = do@@ -734,7 +761,8 @@ withMetaInfo mv $ do mi <- interactionIdToMetaId ii let m = QuestionMark emptyMetaInfo{ metaNumber = Just mi } ii- let oform = OutputForm noRange [] alwaysUnblock $ Assign m e :: OutputForm Expr Expr+ let oform :: OutputForm Expr Expr+ oform = OutputForm noRange [] alwaysUnblock $ Assign m e abstractToConcrete_ oform -- | Reify the boundary of an interaction point as something that can be@@ -827,20 +855,20 @@ return (visibleMetas, hiddenMetas) -- | Print open metas nicely.-showGoals :: Goals -> TCM String-showGoals (ims, hms) = do+prettyGoals :: Goals -> TCM Doc+prettyGoals (ims, hms) = do di <- forM ims $ \ i -> withInteractionId (outputFormId $ OutputForm noRange [] alwaysUnblock i) $ prettyATop i- dh <- mapM showA' hms- return $ unlines $ map show di ++ dh+ dh <- mapM pr hms+ return $ vcat $ di ++ dh where- showA' :: OutputConstraint A.Expr NamedMeta -> TCM String- showA' m = do+ pr :: OutputConstraint A.Expr NamedMeta -> TCM Doc+ pr m = do let i = nmid $ namedMetaOf m r <- getMetaRange i d <- withMetaId i (prettyATop m)- return $ show d ++ " [ at " ++ prettyShow r ++ " ]"+ return $ d <+> "[ at" <+> pretty r <+> "]" getWarningsAndNonFatalErrors :: TCM WarningsAndNonFatalErrors getWarningsAndNonFatalErrors = do@@ -912,7 +940,7 @@ , "x =" TP.<+> TP.pretty x ] ]- reportSDoc "interactive.meta.scope" 20 $ TP.text $ show $ getMetaScope mv+ reportSDoc "interactive.meta.scope" 90 $ TP.text $ show $ getMetaScope mv -- Andreas, 2016-01-19, issue #1783: need piApplyM instead of just piApply OfType x <$> reifyUnblocked t rewriteJudg mv (IsSort i t) = do@@ -945,45 +973,61 @@ M.PostponedTypeCheckingProblem{} -> False -- | Create type of application of new helper function that would solve the goal.-metaHelperType :: Rewrite -> InteractionId -> Range -> String -> TCM (OutputConstraint' Expr Expr)-metaHelperType norm ii rng s = case words s of- [] -> failure- f : _ -> withInteractionId ii $ do- ensureName f- A.Application h args <- A.appView . getBody . deepUnscope <$> parseExprIn ii rng ("let " ++ f ++ " = _ in " ++ s)- inCxt <- hasElem <$> getContextNames+metaHelperType :: Rewrite -> InteractionId -> Range -> String -> TCM (OutputConstraint' Expr C.Name)+metaHelperType norm ii rng s = withInteractionId ii do+ -- Parse the raw application.+ ce <- parseExpr rng s+ -- Operator-parse into simple application of @h@ to @cargs@.+ (h, cargs) <- applicationView [] ce+ -- Scope check arguments+ args <- mapM (fmap deepUnscope . concreteToAbstract_) cargs+ -- Andreas, 2025-09-14:+ -- The 'deepUnscope' has been taken from the previous version of the implementation.+ -- Removing it changes the way the type of the helper function is printed,+ -- sometimes for the better, sometimes for the worse.+ -- TODO: investigate why and how this 'deepUnscope' affects the printing,+ -- and whether we should remove it here.++ cxtNames <- getContextNames+ reportSDoc "interaction.helper" 30 $ TP.vcat $+ [ "args =" TP.<+> prettyTCM args+ , "cxt =" TP.<+> prettyTCM cxtNames+ ] cxtArgs <- getContextArgs- enclosingFunctionName <- ipcQName . envClause <$> getEnv+ enclosingFunctionName <- ipcQName . view eClause <$> getEnv a0 <- (`piApply` cxtArgs) <$> (getMetaType =<< lookupInteractionId ii) -- Konstantin, 2022-10-23: We don't want to print section parameters in helper type. freeVars <- getCurrentModuleFreeVars ctx <- getContext- let contextForAbstracting = take (size ctx - freeVars) ctx+ let contextForAbstracting = cxTake (size ctx - freeVars) ctx -- Andreas, 2019-10-11: I actually prefer pi-types over ->.- let runInPrintingEnvironment = localTC (\e -> e { envPrintDomainFreePi = True, envPrintMetasBare = True })+ let runInPrintingEnvironment = localTC (set ePrintDomainFreePi True . set ePrintMetasBare True) . escapeContext impossible (length contextForAbstracting) . withoutPrintingGeneralization . dontFoldLetBindings - case mapM (isVar . namedArg) args >>= \ xs -> xs <$ guard (all inCxt xs) of+ case mapM (isVar . namedArg) args of -- Andreas, 2019-10-11 -- If all arguments are variables, there is no need to abstract. -- We simply make exactly the given arguments visible and all other hidden.- Just xs -> do+ -- Andreas, 2025-10-22, issue #8150:+ -- Also, the arguments need to be in the same order as in the context.+ Just xs | xs `List.isSubsequenceOf` cxtNames -> do let inXs = hasElem xs let hideButXs ce = setHiding (if inXs (ctxEntryName ce) then NotHidden else Hidden) ce- let tel = contextToTel . map hideButXs $ contextForAbstracting+ let tel = contextToTel . Context . map hideButXs $ contextForAbstracting OfType' h <$> do runInPrintingEnvironment $ reify $ telePiVisible tel a0 - -- If some arguments are not variables (in this case, @args@ is not empty).- Nothing -> do+ -- If some arguments are not variables or not in the right order (in this case, @args@ is not empty).+ _ -> do -- cleanupType relies on with arguments being named 'w', -- so we'd better rename any actual 'w's to avoid confusion.- let tel = runIdentity . onNamesTel unW . contextToTel $ contextForAbstracting+ let tel = runIdentity . onNamesTel unW . contextToTel . Context $+ contextForAbstracting let a = runIdentity . onNames unW $ a0 vtys <- mapM (\ a -> fmap (Arg (getArgInfo a) . fmap OtherType) $ inferExpr $ namedArg a) $ List1.fromListSafe __IMPOSSIBLE__ args@@ -1012,11 +1056,20 @@ return $ OfType' h a where failure = interactionError ExpectedApplication- ensureName f = do- ce <- parseExpr rng f- flip (caseMaybe $ isName ce) (\ _ -> return ()) $ do- reportSLn "interaction.helper" 10 $ "ce = " ++ show ce- failure++ -- An application view for concrete expressions that rejects operator applications.+ -- Takes a suffix of the arguments in left-to-right order (e.g. the empty list)+ -- and returns the head and the arguments in left-to-right order.+ applicationView :: [NamedArg C.Expr] -> C.Expr -> TCM (C.Name, [NamedArg C.Expr])+ applicationView args = \case+ C.Ident (C.QName x) -> return (x, args)+ C.App _ e e1 -> applicationView (e1 : args) e+ C.RawApp _ es -> applicationView args =<< parseApplication es+ C.Paren _ e -> applicationView args e+ -- Allowing operator applications would not make sense.+ -- C.OpApp _ x _ args -> failure+ _ -> failure+ isVar :: A.Expr -> Maybe A.Name isVar = \case A.Var x -> Just x@@ -1102,16 +1155,17 @@ withMetaInfo info $ do -- List of local variables. cxt <- getContext- let localVars = zipWith raise [1..] cxt+ let localVars = flattenContext cxt -- List of let-bindings.- letVars <- Map.toAscList <$> asksTC envLetBindings+ letVars <- Map.toAscList <$> viewTC eLetBindings -- Reify the types and filter out bindings without a name.- (++) <$> forMaybeM (reverse localVars) mkVar+ (++) <$> forMaybeM localVars mkVar <*> forMaybeM letVars mkLet where mkVar :: ContextEntry -> TCM (Maybe ResponseContextEntry)- mkVar (CtxVar name Dom{ domInfo = ai, unDom = t }) = do+ mkVar (CtxVar name dom@(unDom -> t)) = do+ let ai = dom ^. dInfo if shouldHide ai name then return Nothing else Just <$> do let n = nameConcrete name x <- abstractToConcrete_ name@@ -1121,7 +1175,7 @@ mkLet :: (Name, Open M.LetBinding) -> TCM (Maybe ResponseContextEntry) mkLet (name, lb) = do- LetBinding _ tm !dom <- getOpen lb+ LetBinding isAxiom _ tm !dom <- getOpen lb if shouldHide (domInfo dom) name then return Nothing else Just <$> do let n = nameConcrete name x <- abstractToConcrete_ name@@ -1129,8 +1183,11 @@ ty <- reifyUnblocked =<< normalForm norm dom -- Remove let bindings from x and later, to avoid folding to x = x, or using bindings -- not introduced when x was defined.- v <- removeLetBindingsFrom name $ reifyUnblocked =<< normalForm norm tm- return $ ResponseContextEntry n x ty (Just v) s+ mv <- case isAxiom of+ -- Andreas, 2026-01-29, issue #8344: do not print bindings for 'LetAxiom's.+ YesAxiom -> pure Nothing+ NoAxiom -> Just <$> do removeLetBindingsFrom name $ reifyUnblocked =<< normalForm norm tm+ return $ ResponseContextEntry n x ty mv s shouldHide :: ArgInfo -> A.Name -> Bool shouldHide ai n = not (isInstance ai) && (isNoName n || nameIsRecordName n)@@ -1247,7 +1304,7 @@ let tel = telFromList [defaultDom ("_", t)] pat = [defaultArg $ unnamed $ deBruijnNamedVar "c" 0] -- Gallais, 2023-08-24: #6787 we need to locally ignore the- -- --without-K or --cubical-compatible options to figure out+ -- --without-K or --cubical=compatible options to figure out -- that refl is a valid constructor for refl ≡ refl. cubical <- isJust <$> cubicalOption@@ -1295,7 +1352,7 @@ let err = __IMPOSSIBLE__ -- Andreas, 2024-08-03: cannot trigger this error: -- let err = genericError "The file has not been loaded yet."- caseMaybeM (useTC stCurrentModule) err $ \(current, topCurrent) -> do+ Strict.caseMaybeM (useTC stCurrentModule) err $ \(current :!: topCurrent) -> do caseMaybeM (getVisitedModule topCurrent) __IMPOSSIBLE__ $ \ mi -> do let scope = iInsideScope $ miInterface mi tel <- lookupSection current@@ -1326,19 +1383,21 @@ types = map (snd <$>) $ telToList tel gamma :: ListTel' A.Name gamma = fromMaybe __IMPOSSIBLE__ $- zipWith' (\ x dom -> (x,) <$> dom) names types+ zipWithSameLen (\ x dom -> (x,) <$> dom) names types reportSDoc "interaction.top" 20 $ TP.vcat [ "BasicOps.atTopLevel" , " names = " TP.<+> TP.sep (map prettyA names) , " types = " TP.<+> TP.sep (map prettyTCM types) ] M.withCurrentModule current $- withScope_ scope $+ evalWithScope scope $ do+ -- András, 2025-08-30: building fresh scope from interface+ recomputeInverseScope addContext gamma $ do -- We're going inside the top-level module, so we have to set the- -- checkpoint for it and all its submodules to the new checkpoint.+ -- checkpoints for it and all its submodules to the new checkpoint. cp <- viewTC eCurrentCheckpoint- stModuleCheckpoints `modifyTCLens` fmap (const cp)+ setAllModuleCheckpoints cp m -- | Parse a name.
src/full/Agda/Interaction/BuildLibrary.hs view
@@ -1,6 +1,6 @@ -- | Type-check all files of a library (option @--build-library@). -module Agda.Interaction.BuildLibrary (buildLibrary) where+module Agda.Interaction.BuildLibrary (buildLibrary, printAccumulatedWarnings) where import Control.Monad.Except (throwError) import Control.Monad.IO.Class (liftIO)@@ -10,11 +10,10 @@ import qualified Data.Set as Set import System.Directory (getCurrentDirectory)-import System.FilePath ( (</>) ) import qualified System.FilePath.Find as Find import Agda.Interaction.FindFile (hasAgdaExtension, checkModuleName)-import Agda.Interaction.Imports (Source)+import Agda.Interaction.Imports (TCWorkers, Source, MainInterface(..)) import qualified Agda.Interaction.Imports as Imp import Agda.Interaction.Library (pattern AgdaLibFile, _libIncludes, _libPragmas, getAgdaLibFile) import Agda.Interaction.Options (optOnlyScopeChecking)@@ -65,40 +64,61 @@ -- (Code copied from Agda.Main.) opts <- commandLineOptions- let mode = if optOnlyScopeChecking opts- then Imp.ScopeCheck- else Imp.TypeCheck+ par <- Imp.wantsParallelChecking - forM_ files \ inputFile -> do- path :: AbsolutePath- <- liftIO (absolute inputFile)- sf :: SourceFile- <- srcFromPath path- src :: Source- <- Imp.parseSource sf- let- m :: TopLevelModuleName- m = Imp.srcModuleName src- setCurrentRange (beginningOfFile path) do- checkModuleName m (Imp.srcOrigin src) Nothing- _ <- withCurrentModule noModuleName- $ withTopLevelModule m- $ checkModule m src- return ()+ checks <- forM files \ inputFile -> do - -- Print accumulated warnings+ path :: AbsolutePath+ <- liftIO (absolute inputFile)+ sf :: SourceFile+ <- srcFromPath path++ -- András, 2026-08-19: issue 8627: for some reason, checking+ -- primitive modules in the following throws coinfectivity error,+ -- but since they're already checked by importPrimitiveModules,+ -- there's no point checking them anyway.+ isBuiltinModule (srcFileId sf) >>= \case+ Just b | isPrimitiveModule b ->+ pure $ pure ()+ _ -> do+ src :: Source+ <- Imp.parseSource sf+ let+ m :: TopLevelModuleName+ m = Imp.srcModuleName src+ setCurrentRange (beginningOfFile path) do+ checkModuleName m (Imp.srcOrigin src) Nothing+ withCurrentModule noModuleName+ $ withTopLevelModule m+ $ checkModule par m src++ sequence_ checks+ printAccumulatedWarnings++printAccumulatedWarnings :: TCM ()+printAccumulatedWarnings = do unlessNullM (tcWarnings . classifyWarnings . Set.toAscList <$> getAllWarnings AllWarnings) $ \ ws -> do let banner = text $ "\n" ++ delimiter "All done; warnings encountered" alwaysReportSDoc "warning" 1 $ vsep $ (banner :) $ map prettyTCM $ Set.toAscList ws -checkModule :: TopLevelModuleName -> Imp.Source -> TCM ()-checkModule m src = do- mi <- Imp.getNonMainModuleInfo m (Just src)+postCheckModule :: TopLevelModuleName -> Source -> ModuleInfo -> TCM ()+postCheckModule m src mi = do -- Here we ignore InfectiveImport warnings since we don't have an actual parent module that can -- be infected.- let isInfectiveWarning InfectiveImport{} = True- isInfectiveWarning _ = False- warns = filter (not . isInfectiveWarning . tcWarning) $ Set.toAscList $ miWarnings mi- tcWarningsToError warns- return ()+ let+ isInfectiveWarning InfectiveImport{} = True+ isInfectiveWarning _ = False+ warns = filter (not . isInfectiveWarning . tcWarning) $ Set.toAscList $ miWarnings mi+ tcWarningsToError (TopLevelModuleNameWithSourceFile m (Imp.srcOrigin src)) warns++checkModule :: Maybe TCWorkers -> TopLevelModuleName -> Source -> TCM (TCM ())+checkModule (Just w) m src = bracket_ (useTC stPragmaOptions) (stPragmaOptions `setTCLens`) do+ Imp.setOptionsFromSourcePragmas True src+ mip <- Imp.chaseModule w m NotMainInterface (Just src)+ pure $ mip >>= postCheckModule m src++checkModule Nothing m src = do+ mi <- Imp.getNonMainModuleInfo m (Just src)+ postCheckModule m src mi+ pure $ pure ()
src/full/Agda/Interaction/CommandLine.hs view
@@ -22,6 +22,7 @@ import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Common import Agda.Syntax.Common.Pretty+import Agda.Syntax.Common.Pretty.ANSI (putDocLn) import Agda.Syntax.Internal (telToList, alwaysUnblock) import qualified Agda.Syntax.Internal as I import Agda.Syntax.Parser@@ -107,8 +108,7 @@ Just _ -> do go =<< liftTCM (eval $ fromJust ms) `catchError` \e ->- do s <- renderError e- liftIO $ putStrLn s+ do putDocLn =<< prettyError e loop runInteractionLoop :: Maybe AbsolutePath -> TCM () -> (AbsolutePath -> TCM CheckResult) -> TCM ()@@ -135,15 +135,18 @@ where reload :: ReplM () = do checked <- checkCurrentFile- liftTCM $ setScope $ maybe emptyScopeInfo (iInsideScope . crInterface) checked+ liftTCM $ do+ case checked of+ Nothing -> setScope emptyScopeInfo+ Just scope -> do setScope (iInsideScope $ crInterface scope)+ recomputeInverseScope -- Andreas, 2021-01-27, issue #5132, make Set and Prop available from Agda.Primitive -- if no module is loaded. when (isNothing checked) $ do -- @open import Agda.Primitive using (Set; Prop)@ void $ liftTCM importPrimitives `catchError` \e -> do- s <- renderError e- liftIO $ putStrLn s+ putDocLn =<< prettyError e liftIO $ putStrLn "Failed." commands =@@ -175,7 +178,7 @@ withCurrentFile cont = do mpath <- gets currentFile i <- traverse idFromFile mpath- localTC (\ e -> e { envCurrentPath = i }) cont+ localTC (set eCurrentPath i) cont loadFile :: ReplM () -> [String] -> ReplM () loadFile reload [file] = do@@ -186,7 +189,7 @@ showConstraints :: [String] -> TCM () showConstraints [] =- do cs <- BasicOps.getConstraints+ do cs <- BasicOps.getConstraints AsIs liftIO $ putStrLn $ unlines (List.map prettyShow cs) showConstraints _ = liftIO $ putStrLn ":constraints [cid]" @@ -253,7 +256,7 @@ giveMeta :: [String] -> TCM () giveMeta s | length s >= 2 = do- _ <- actOnMeta s $ \ ii e -> give WithoutForce ii Nothing e+ _ <- actOnMeta s $ \ ii e -> give WithoutForce ii e return () giveMeta _ = liftIO $ putStrLn $ ": give" ++ " metaid expr" @@ -261,7 +264,7 @@ refineMeta :: [String] -> TCM () refineMeta s | length s >= 2 = do- _ <- actOnMeta s $ \ ii e -> refine WithoutForce ii Nothing e+ _ <- actOnMeta s $ \ ii e -> refine WithoutForce ii e return () refineMeta _ = liftIO $ putStrLn $ ": refine" ++ " metaid expr"
+ src/full/Agda/Interaction/Emacs/Lisp.hs view
@@ -0,0 +1,52 @@+-- | Abstract elisp syntax.++module Agda.Interaction.Emacs.Lisp+ ( Lisp(..)+ , response+ , putResponse+ ) where++import Agda.Syntax.Common.Pretty++-- | Simple Emacs Lisp expressions.++data Lisp a+ = A a+ -- ^ Atom.+ | Cons (Lisp a) (Lisp a)+ -- Cons cell.+ | L [Lisp a]+ -- ^ List.+ | Q (Lisp a)+ -- Quoted expression.+ deriving Eq++instance Pretty a => Pretty (Lisp a) where+ pretty (A a ) = pretty a+ pretty (Cons a b) = parens (pretty a <+> "." <+> pretty b)+ pretty (L xs) = parens (hsep (map pretty xs))+ pretty (Q x) = "'" <> pretty x++-- instance Show (Lisp String) where+-- showsPrec _ (A a) = showString a+-- showsPrec p (Cons a b) = showString "(" . showsPrec p a . showString " . " .+-- showsPrec p b . showString ")"+-- showsPrec p (L xs) = showString "(" . foldr (.) (showString ")")+-- (List.intersperse (showString " ")+-- (map (showsPrec p) xs))+-- showsPrec p (Q x) = showString "'" . showsPrec p x++-- | Formats a response command.+--+-- Replaces @'\n'@ with spaces to ensure that each command is a+-- single line.+response :: Lisp String -> String+response = (++ "\n") . map replaceNewLines . prettyShow+ where+ replaceNewLines '\n' = ' '+ replaceNewLines c = c++-- | Writes a response command to standard output.++putResponse :: Lisp String -> IO ()+putResponse = putStr . response
src/full/Agda/Interaction/EmacsCommand.hs view
@@ -4,99 +4,74 @@ ------------------------------------------------------------------------ module Agda.Interaction.EmacsCommand- ( Lisp(..)- , response- , putResponse- , display_info'+ ( displayInfo , clearRunningInfo- , clearWarning , displayRunningInfo+ , displayVerboseInfo ) where --- import qualified Data.List as List--import Agda.Syntax.Common.Pretty-import Agda.Utils.String---- | Simple Emacs Lisp expressions.--data Lisp a- = A a- -- ^ Atom.- | Cons (Lisp a) (Lisp a)- -- Cons cell.- | L [Lisp a]- -- ^ List.- | Q (Lisp a)- -- Quoted expression.- deriving Eq+import Prelude hiding (null) -instance Pretty a => Pretty (Lisp a) where- pretty (A a ) = pretty a- pretty (Cons a b) = parens (pretty a <+> "." <+> pretty b)- pretty (L xs) = parens (hsep (map pretty xs))- pretty (Q x) = "'" <> pretty x+import Data.Bifunctor (second)+import Data.Text qualified as Text --- instance Show (Lisp String) where--- showsPrec _ (A a) = showString a--- showsPrec p (Cons a b) = showString "(" . showsPrec p a . showString " . " .--- showsPrec p b . showString ")"--- showsPrec p (L xs) = showString "(" . foldr (.) (showString ")")--- (List.intersperse (showString " ")--- (map (showsPrec p) xs))--- showsPrec p (Q x) = showString "'" . showsPrec p x+import Agda.Syntax.Common.Pretty (DocTree) --- | Formats a response command.------ Replaces @'\n'@ with spaces to ensure that each command is a--- single line.-response :: Lisp String -> String-response = (++ "\n") . map replaceNewLines . show . pretty- where- replaceNewLines '\n' = ' '- replaceNewLines c = c+import Agda.Interaction.Emacs.Lisp+import Agda.Interaction.Highlighting.Emacs (HighlightingInfo, lispifyHighlightingInfo_) --- | Writes a response command to standard output.+import Agda.TypeChecking.Monad.Base.Types (ModuleToSource) -putResponse :: Lisp String -> IO ()-putResponse = putStr . response+import Agda.Utils.Null+import Agda.Utils.String (quote)+import Agda.Utils.DocTree (treeToTextNoAnn, treeToTextWithAnn) --- | @displayInBuffer buffername append header content@ displays @content@--- (with header @header@) in some suitable way in the buffer @buffername@.+-- | @displayInfo header content append m@ displays @content@+-- with header @header@ in some suitable way in the Agda information buffer. -- If @append@ is @True@, then the content is appended to previous content -- (if any), otherwise any previous content is deleted.--displayInBuffer :: String -> Bool -> String -> String -> Lisp String-displayInBuffer buffername append header content =- L [ A buffername- , A (quote header)- , A (quote content)- , A (if append then "t" else "nil")- ]+-- If @m@ is @Just 'ModuleToSource'@ then @content@ is rendered with annotations,+-- otherwise annotations in @content@ are discarded and just the text is displayed. -display_info' :: Bool -> String -> String -> Lisp String-display_info' = displayInBuffer "agda2-info-action"+displayInfo :: String -> DocTree -> Bool -> Maybe ModuleToSource -> Lisp String+displayInfo header content append m = L $ concat+ [ [ A "agda2-info-action"+ , A (quote header)+ , A (quote $ Text.unpack t)+ , A (if append then "t" else "nil")+ ]+ , map Q ann+ ]+ where+ (t, ann) = processAnnotations content m ------------------------------------------------------------------------ -- Running info --- | The name of the running info buffer.+-- | Header to display in the Agda information buffer for "running info". -runningInfoBufferName :: String-runningInfoBufferName = "*Type-checking*"+runningInfoHeader :: String+runningInfoHeader = "*Type-checking*" -- | Clear the running info buffer. clearRunningInfo :: Lisp String-clearRunningInfo =- display_info' False runningInfoBufferName ""---- | Clear the warning buffer-clearWarning :: Lisp String-clearWarning = L [ A "agda2-close-warning" ]+clearRunningInfo = displayInfo runningInfoHeader empty False Nothing -- | Display running information about what the type-checker is up to. -displayRunningInfo :: String -> Lisp String-displayRunningInfo s =- display_info' True runningInfoBufferName s+displayRunningInfo :: DocTree -> Maybe ModuleToSource -> Lisp String+displayRunningInfo t = displayInfo runningInfoHeader t True++displayVerboseInfo :: DocTree -> Maybe ModuleToSource -> Lisp String+displayVerboseInfo t m = L $ concat+ [ [ A "agda2-verbose"+ , A (quote $ Text.unpack tx)]+ , map Q anns]+ where+ (tx, anns) = processAnnotations t m++processAnnotations :: DocTree -> Maybe ModuleToSource -> (Text.Text, [Lisp String])+processAnnotations t = \case+ Nothing -> (, []) $ treeToTextNoAnn t+ Just m2s -> second (lispifyHighlightingInfo_ m2s) $ treeToTextWithAnn t
src/full/Agda/Interaction/EmacsTop.hs view
@@ -3,43 +3,56 @@ module Agda.Interaction.EmacsTop ( mimicGHCi , namedMetaOf- , showGoals , showInfoError+ , prettyGoals+ , prettyInfoError , explainWhyInScope , prettyResponseContext , prettyTypeOfMeta+ , prettyNormalForm+ , prettyInferredType ) where +import Prelude hiding (null)+ import Control.Monad import Control.Monad.IO.Class ( MonadIO(..) ) import Control.Monad.State ( evalStateT ) import Control.Monad.Trans ( lift ) -import qualified Data.List as List+import Data.List qualified as List import Agda.Syntax.Common-import Agda.Syntax.Common.Pretty+import Agda.Syntax.Common.Pretty as P+import Agda.Syntax.Abstract qualified as A import Agda.Syntax.Abstract.Pretty (prettyATop) import Agda.Syntax.Concrete as C -import Agda.TypeChecking.Errors ( explainWhyInScope, getAllWarningsOfTCErr, renderError, verbalize )-import qualified Agda.TypeChecking.Pretty as TCP+import Agda.TypeChecking.Errors ( explainWhyInScope, getAllWarningsOfTCErr, verbalize, prettyError )+import Agda.TypeChecking.Pretty qualified as TCP import Agda.TypeChecking.Pretty (prettyTCM)-import Agda.TypeChecking.Pretty.Warning (prettyTCWarnings)+import Agda.TypeChecking.Pretty.Warning (prettyTCWarnings') import Agda.TypeChecking.Monad+ import Agda.Interaction.AgdaTop import Agda.Interaction.Base import Agda.Interaction.BasicOps as B import Agda.Interaction.Response as R-import Agda.Interaction.EmacsCommand hiding (putResponse)+import Agda.Interaction.Emacs.Lisp+import Agda.Interaction.EmacsCommand ( displayInfo, clearRunningInfo, displayRunningInfo, displayVerboseInfo) import Agda.Interaction.Highlighting.Emacs import Agda.Interaction.Highlighting.Precise (TokenBased(..)) import Agda.Interaction.Command (localStateCommandM)-import Agda.Utils.Function (applyWhen)-import Agda.Utils.Null (empty)+import Agda.Interaction.Options ( DiagnosticsColours(..), optDiagnosticsColour )++import Agda.Utils.DocTree ( renderToTree )+import Agda.Utils.Function ( applyWhen )+import Agda.Utils.Functor ( (<.>) )+import Agda.Utils.Null import Agda.Utils.Maybe import Agda.Utils.String import Agda.Utils.Time (CPUTime)+ import Agda.VersionCommit ----------------------------------@@ -50,127 +63,151 @@ -- 'mimicGHCi' reads the Emacs frontend commands from stdin, -- interprets them and print the result into stdout. mimicGHCi :: TCM () -> TCM ()-mimicGHCi = repl (liftIO . mapM_ (putStrLn . prettyShow) <=< lispifyResponse) "Agda2> "+mimicGHCi = repl (liftIO . putStrLn . prettyShow <=< lispifyResponse) "Agda2> " -- | Convert Response to an elisp value for the interactive emacs frontend. -lispifyResponse :: Response -> TCM [Lisp String]-lispifyResponse (Resp_HighlightingInfo info remove method modFile) =- (:[]) <$> liftIO (lispifyHighlightingInfo info remove method modFile)-lispifyResponse (Resp_DisplayInfo info) = lispifyDisplayInfo info-lispifyResponse (Resp_ClearHighlighting tokenBased) =- return [ L $ A "agda2-highlight-clear" :- case tokenBased of- NotOnlyTokenBased -> []- TokenBased ->- [ Q (lispifyTokenBased tokenBased) ]- ]-lispifyResponse Resp_DoneAborting = return [ L [ A "agda2-abort-done" ] ]-lispifyResponse Resp_DoneExiting = return [ L [ A "agda2-exit-done" ] ]-lispifyResponse Resp_ClearRunningInfo = return [ clearRunningInfo ]-lispifyResponse (Resp_RunningInfo n s)- | n <= 1 = return [ displayRunningInfo s ]- | otherwise = return [ L [A "agda2-verbose", A (quote s)] ]-lispifyResponse (Resp_Status s)- = return [ L [ A "agda2-status-action"- , A (quote $ List.intercalate "," $ catMaybes [checked, showImpl, showIrr])- ]- ]- where- checked = boolToMaybe (sChecked s) "Checked"- showImpl = boolToMaybe (sShowImplicitArguments s) "ShowImplicit"- showIrr = boolToMaybe (sShowIrrelevantArguments s) "ShowIrrelevant"+lispifyResponse :: Response -> TCM (Lisp String)+lispifyResponse = \case -lispifyResponse (Resp_JumpToError f p) = return- [ lastTag 3 $- L [ A "agda2-maybe-goto", Q $ L [A (quote f), A ".", A (show p)] ]- ]-lispifyResponse (Resp_InteractionPoints is) = return- [ lastTag 1 $- L [A "agda2-goals-action", Q $ L $ map showNumIId is]- ]-lispifyResponse (Resp_GiveAction ii s)- = return [ L [ A "agda2-give-action", showNumIId ii, A s' ] ]- where- s' = case s of- Give_String str -> quote str- Give_Paren -> "'paren"- Give_NoParen -> "'no-paren"-lispifyResponse (Resp_MakeCase ii variant pcs) = return- [ lastTag 2 $ L [ A cmd, Q $ L $ map (A . quote) pcs ] ]- where- cmd = case variant of- R.Function -> "agda2-make-case-action"- R.ExtendedLambda -> "agda2-make-case-action-extendlam"-lispifyResponse (Resp_SolveAll ps) = return- [ lastTag 2 $- L [ A "agda2-solveAll-action", Q . L $ concatMap prn ps ]- ]- where- prn (ii,e)= [showNumIId ii, A $ quote $ prettyShow e]--- TODO: For now, I piggy-back on the Resp_SolveAll implementation-lispifyResponse (Resp_Mimer ii msol) = return $ case msol of- Nothing ->- [ lastTag 1 $ -- TODO: What is this lastTag used for?- L [ A "agda2-info-action", A $ quote "*Mimer*", A $ quote "No solution found" ]- ]- Just str ->- [ lastTag 1 $ -- TODO: What is this lastTag used for?- L [ A "agda2-solve-action", showNumIId ii, A $ quote str ]- ]+ Resp_HighlightingInfo info remove method modFile file ->+ liftIO (lispifyHighlightingInfo info remove method modFile file) -lispifyDisplayInfo :: DisplayInfo -> TCM [Lisp String]-lispifyDisplayInfo info = case info of+ Resp_DisplayInfo info ->+ lispifyDisplayInfo info++ Resp_ClearHighlighting tokenBased ->+ return $ L $+ A "agda2-highlight-clear" :+ case tokenBased of+ TokenBased -> [ Q (lispifyTokenBased tokenBased) ]+ NotOnlyTokenBased -> []++ Resp_DoneAborting ->+ return $ L [ A "agda2-abort-done" ]++ Resp_DoneExiting ->+ return $ L [ A "agda2-exit-done" ]++ Resp_ClearRunningInfo ->+ return clearRunningInfo++ Resp_RunningInfo n docTree+ | n <= 1 -> displayRunningInfo docTree <$> wantBufferHighlighting+ | otherwise -> displayVerboseInfo docTree <$> wantBufferHighlighting++ Resp_Status s ->+ return $ L+ [ A "agda2-status-action"+ , A (quote $ List.intercalate "," $ catMaybes [checked, showImpl, showIrr])+ ]+ where+ checked = boolToMaybe (sChecked s) "Checked"+ showImpl = boolToMaybe (sShowImplicitArguments s) "ShowImplicit"+ showIrr = boolToMaybe (sShowIrrelevantArguments s) "ShowIrrelevant"++ Resp_JumpToError f p ->+ return $ lastTag 3 $ L+ [ A "agda2-maybe-goto"+ , Q $ L [ A (quote f), A ".", A (show p) ]+ ]++ Resp_InteractionPoints is ->+ return $ lastTag 1 $ L+ [ A "agda2-goals-action"+ , Q $ L $ map showNumIId is+ ]++ Resp_GiveAction ii s ->+ return $ L+ [ A "agda2-give-action"+ , showNumIId ii+ , A s'+ ]+ where+ s' = case s of+ Give_String str -> quote str+ Give_Paren -> "'paren"+ Give_NoParen -> "'no-paren"++ Resp_MakeCase ii variant pcs ->+ return $ lastTag 2 $ L+ [ A cmd+ , Q $ L $ map (A . quote) pcs+ ]+ where+ cmd = case variant of+ R.Function -> "agda2-make-case-action"+ R.ExtendedLambda -> "agda2-make-case-action-extendlam"++ Resp_SolveAll ps ->+ return $ lastTag 2 $ L+ [ A "agda2-solveAll-action"+ , Q $ L $ concatMap prn ps+ ]+ where+ prn (ii,e)= [showNumIId ii, A $ quote $ prettyShow e]++ Resp_Mimer ii msol ->+ return $ lastTag 1 $ L $ case msol of+ Nothing ->+ [ A "agda2-info-action"+ , A $ quote "*Mimer*"+ , A $ quote "No solution found"+ ]+ Just str ->+ [ A "agda2-solve-action"+ , showNumIId ii+ , A $ quote str+ ]++lispifyDisplayInfo :: DisplayInfo -> TCM (Lisp String)+lispifyDisplayInfo = \case+ Info_CompilationOk backend ws -> do- warnings <- prettyTCWarnings (tcWarnings ws)- errors <- prettyTCWarnings (nonFatalErrors ws)+ warnings <- prettyTCWarnings' (tcWarnings ws)+ errors <- prettyTCWarnings' (nonFatalErrors ws) let- msg = concat+ msg = hcat [ "The module was successfully compiled with backend "- , prettyShow backend+ , pretty backend , ".\n" ] -- abusing the goals field since we ignore the title- (body, _) = formatWarningsAndErrors msg warnings errors- format body "*Compilation result*"+ (_title, body) = formatWarningsAndErrors msg warnings errors+ format "*Compilation result*" body+ Info_Constraints s -> do doc <- TCP.vcat $ map prettyTCM s- format (render doc) "*Constraints*"+ format "*Constraints*" doc+ Info_AllGoalsWarnings ms ws -> do- goals <- showGoals ms- warnings <- prettyTCWarnings (tcWarnings ws)- errors <- prettyTCWarnings (nonFatalErrors ws)- let (body, title) = formatWarningsAndErrors goals warnings errors- format body ("*All" ++ title ++ "*")- Info_Auto s -> format s "*Auto*"- Info_Error err -> do- s <- showInfoError err- format s "*Error*"- Info_Time s -> format (render $ prettyTimed s) "*Time*"+ goals <- prettyGoals ms+ warnings <- prettyTCWarnings' (tcWarnings ws)+ errors <- prettyTCWarnings' (nonFatalErrors ws)+ let (title, body) = formatWarningsAndErrors goals warnings errors+ format ("*All" ++ title ++ "*") body++ Info_Auto s ->+ format "*Auto*" $ P.text s++ Info_Error err -> format' "*Error*" =<< prettyInfoError err++ Info_Time time ->+ format "*Time*" $ prettyTimed time+ Info_NormalForm state cmode time expr -> do- exprDoc <- evalStateT prettyExpr state+ exprDoc <- prettyNormalForm state cmode expr let doc = maybe empty prettyTimed time $$ exprDoc lbl | cmode == HeadCompute = "*Head Normal Form*" | otherwise = "*Normal Form*"- format (render doc) lbl- where- prettyExpr = localStateCommandM- $ lift- $ B.atTopLevel- $ allowNonTerminatingReductions- $ (if computeIgnoreAbstract cmode then ignoreAbstractMode else inConcreteMode)- $ (B.showComputed cmode)- $ expr+ format lbl doc+ Info_InferredType state time expr -> do- exprDoc <- evalStateT prettyExpr state+ exprDoc <- prettyInferredType state expr let doc = maybe empty prettyTimed time $$ exprDoc- format (render doc) "*Inferred Type*"- where- prettyExpr = localStateCommandM- $ lift- $ B.atTopLevel- $ TCP.prettyA- $ expr+ format "*Inferred Type*" doc+ Info_ModuleContents modules tel types -> do doc <- localTCState $ do typeDocs <- addContext tel $ forM types $ \ (x, t) -> do@@ -182,21 +219,27 @@ , "Names" , nest 2 $ align 10 typeDocs ]- format (render doc) "*Module contents*"+ format "*Module contents*" doc+ Info_SearchAbout hits names -> do hitDocs <- forM hits $ \ (x, t) -> do doc <- prettyTCM t return (prettyShow x, ":" <+> doc) let doc = "Definitions about" <+> text (List.intercalate ", " $ words names) $$ nest 2 (align 10 hitDocs)- format (render doc) "*Search About*"+ format "*Search About*" doc+ Info_WhyInScope why -> do doc <- explainWhyInScope why- format (render doc) "*Scope Info*"+ format "*Scope Info*" doc+ Info_Context ii ctx -> do doc <- localTCState (prettyResponseContext ii False ctx)- format (render doc) "*Context*"- Info_Intro_NotFound -> format "No introduction forms found." "*Intro*"+ format "*Context*" doc++ Info_Intro_NotFound ->+ format "*Intro*" "No introduction forms found."+ Info_Intro_ConstructorUnknown ss -> do let doc = sep [ "Don't know which constructor to introduce of" , let mkOr [] = []@@ -204,24 +247,31 @@ mkOr (x:xs) = text x : mkOr xs in nest 2 $ fsep $ punctuate comma (mkOr ss) ]- format (render doc) "*Intro*"- Info_Version -> format ("Agda version " ++ versionWithCommitInfo) "*Agda Version*"- Info_GoalSpecific ii kind -> lispifyGoalSpecificDisplayInfo ii kind+ format "*Intro*" doc -lispifyGoalSpecificDisplayInfo :: InteractionId -> GoalDisplayInfo -> TCM [Lisp String]+ Info_Version ->+ format "*Agda Version*" ("Agda version" <+> text versionWithCommitInfo)++ Info_GoalSpecific ii kind ->+ lispifyGoalSpecificDisplayInfo ii kind++lispifyGoalSpecificDisplayInfo :: InteractionId -> GoalDisplayInfo -> TCM (Lisp String) lispifyGoalSpecificDisplayInfo ii kind = localTCState $ withInteractionId ii $ case kind of+ Goal_HelperFunction helperType -> do doc <- inTopContext $ prettyATop helperType- return [ L [ A "agda2-info-action-and-copy"- , A $ quote "*Helper function*"- , A $ quote (render doc ++ "\n")- , A "nil"- ]- ]+ return $ L+ [ A "agda2-info-action-and-copy"+ , A $ quote "*Helper function*"+ , A $ quote (render doc ++ "\n")+ , A "nil"+ ]+ Goal_NormalForm cmode expr -> do doc <- showComputed cmode expr- format (render doc) "*Normal Form*" -- show?+ format "*Normal Form*" doc+ Goal_GoalType norm aux ctx bndry constraints -> do ctxDoc <- prettyResponseContext ii True ctx goalDoc <- prettyTypeOfMeta norm ii@@ -244,26 +294,50 @@ [ TCP.text $ delimiter "Constraints" , TCP.vcat $ map prettyTCM constraints ]- doc <- TCP.vcat $- [ "Goal:" TCP.<+> return goalDoc- , return (vcat (boundaryDoc "Boundary (wanted)" bndry))- , return auxDoc- , TCP.text (replicate 60 '\x2014')- , return ctxDoc- ] ++ constraintsDoc- format (render doc) "*Goal type etc.*"+ doc <- TCP.vcat $ concat+ [ [ "Goal:" TCP.<+> return goalDoc+ , return (vcat (boundaryDoc "Boundary (wanted)" bndry))+ , return auxDoc+ ]+ , [ TCP.text (delimiter "Context") | not $ null ctxDoc ]+ , [ return ctxDoc ]+ , constraintsDoc+ ]+ format "*Goal type etc.*" doc+ Goal_CurrentGoal norm -> do doc <- prettyTypeOfMeta norm ii- format (render doc) "*Current Goal*"+ format "*Current Goal*" doc+ Goal_InferredType expr -> do doc <- prettyATop expr- format (render doc) "*Inferred Type*"+ format "*Inferred Type*" doc --- | Format responses of DisplayInfo+format :: String -> Doc -> TCM (Lisp String)+format header = format' header -format :: String -> String -> TCM [Lisp String]-format content bufname = return [ display_info' False bufname content ]+-- | Format responses of 'DisplayInfo'.+format'+ :: String+ -- ^ String to use as a header.+ -> Doc+ -- ^ The document to print.+ -> TCM (Lisp String)+format' header content = displayInfo header (renderToTree content) False <$>+ wantBufferHighlighting +-- | Do we want highlighting in the Agda information buffer?+-- 'Nothing' with option @--color=never@.+wantBufferHighlighting :: TCM (Maybe ModuleToSource)+wantBufferHighlighting = do+ col <- commandLineOptions <&> optDiagnosticsColour <&> \case+ AutoColour -> True+ AlwaysColour -> True+ NeverColour -> False+ if col+ then Just <$> useSession lensModuleToSource+ else return Nothing+ -- | Adds a \"last\" tag to a response. lastTag :: Integer -> Lisp String -> Lisp String@@ -276,49 +350,54 @@ -------------------------------------------------------------------------------- --- | Given strings of goals, warnings and errors, return a pair of the--- body and the title for the info buffer-formatWarningsAndErrors :: String -> String -> String -> (String, String)-formatWarningsAndErrors g w e = (body, title)+-- | Given goals, warnings and errors, return a pair of the+-- title and the body for the info buffer.+formatWarningsAndErrors :: Doc -> [Doc] -> [Doc] -> (String, Doc)+formatWarningsAndErrors g ws es = (title, body) where isG = not $ null g- isW = not $ null w- isE = not $ null e- title = List.intercalate "," $ catMaybes- [ " Goals" <$ guard isG- , " Errors" <$ guard isE- , " Warnings" <$ guard isW- , " Done" <$ guard (not (isG || isW || isE))- ]+ isW = not $ null ws+ isE = not $ null es+ title = List.intercalate "," $ concat+ [ [ " Goals" | isG ]+ , [ " Errors" | isE ]+ , [ " Warnings" | isW ]+ , [ " Done" | not (isG || isW || isE) ]+ ]+ body = vcat $ concat+ [ [ g ]+ , [ text $ delimiter "Error" | isE && (isG || isW) ]+ , es+ , [ text $ delimiter "Warnings" | isW && (isG || isE) ]+ , ws+ ] - body = List.intercalate "\n" $ catMaybes- [ g <$ guard isG- , delimiter "Error" <$ guard (isE && (isG || isW))- , e <$ guard isE- , delimiter "Warnings" <$ guard (isW && (isG || isE))- , w <$ guard isW- ]+-- | Serializing 'Info_Error'.+showInfoError :: Info_Error -> TCM String+showInfoError = render <.> prettyInfoError +-- | Turn an 'Info_Error' into a 'Doc'.+prettyInfoError :: Info_Error -> TCM Doc+prettyInfoError = \case+ Info_GenericError err -> do+ e <- prettyError err+ ws <- prettyTCWarnings' =<< getAllWarningsOfTCErr err+ let (_title, body) = formatWarningsAndErrors empty ws [e]+ return body --- | Serializing Info_Error-showInfoError :: Info_Error -> TCM String-showInfoError (Info_GenericError err) = do- e <- renderError err- w <- prettyTCWarnings =<< getAllWarningsOfTCErr err- let (body, _) = formatWarningsAndErrors "" w e- return body-showInfoError (Info_CompilationError warnings) = do- s <- prettyTCWarnings warnings- return $ unlines- [ "You need to fix the following errors before you can compile the module:"- , ""- , s- ]-showInfoError (Info_HighlightingParseError ii) =- return $ "Highlighting failed to parse expression in " ++ show ii-showInfoError (Info_HighlightingScopeCheckError ii) =- return $ "Highlighting failed to scope check expression in " ++ show ii+ Info_CompilationError warnings -> do+ docs <- prettyTCWarnings' warnings+ return $ vcat $+ "You need to fix the following errors before you can compile the module:" :+ "" :+ docs + Info_HighlightingParseError ii ->+ return $ "Highlighting failed to parse expression in" <+> pretty ii++ Info_HighlightingScopeCheckError ii ->+ return $ "Highlighting failed to scope check expression in" <+> pretty ii+ -- | Pretty-prints the context of the given meta-variable. prettyResponseContext@@ -377,10 +456,34 @@ prettyTypeOfMeta :: Rewrite -> InteractionId -> TCM Doc prettyTypeOfMeta norm ii = do- form <- B.typeOfMeta norm ii- case form of+ B.typeOfMeta norm ii >>= \case OfType _ e -> prettyATop e- _ -> prettyATop form+ form -> prettyATop form++-- | Pretty-print the result of a compute command in the command state+-- captured when the command completed. Shared with the JSON frontend+-- ("Agda.Interaction.JSONTop") so that both frontends render the+-- expression identically.+prettyNormalForm :: CommandState -> ComputeMode -> A.Expr -> TCM Doc+prettyNormalForm state cmode expr = evalStateT prettyExpr state+ where+ prettyExpr = localStateCommandM+ $ lift+ $ B.atTopLevel+ $ (B.withComputeIgnoreAbstract cmode)+ $ (B.showComputed cmode)+ $ expr++-- | Pretty-print an inferred type in the command state captured when the+-- inference command completed. Shared with the JSON frontend.+prettyInferredType :: CommandState -> A.Expr -> TCM Doc+prettyInferredType state expr = evalStateT prettyExpr state+ where+ prettyExpr = localStateCommandM+ $ lift+ $ B.atTopLevel+ $ TCP.prettyA+ $ expr -- | Prefix prettified CPUTime with "Time:" prettyTimed :: CPUTime -> Doc
src/full/Agda/Interaction/ExitCode.hs view
@@ -14,7 +14,7 @@ | TCMError -- ^ 42 | OptionError -- ^ 71 | CommandError -- ^ 113- | ImpossibleError -- ^ 154+ | ImpossibleError -- ^ 120 deriving (Show, Eq, Enum, Bounded) agdaErrorToInt :: AgdaError -> Int@@ -22,7 +22,7 @@ agdaErrorToInt TCMError = 42 agdaErrorToInt OptionError = 71 agdaErrorToInt CommandError = 113-agdaErrorToInt ImpossibleError = 154+agdaErrorToInt ImpossibleError = 120 -- ^ Return the error corresponding to an exit code from the -- Agda process
src/full/Agda/Interaction/FindFile.hs view
@@ -33,7 +33,6 @@ import Agda.Syntax.Concrete import Agda.Syntax.Parser-import Agda.Syntax.Parser.Literate (literateExtsShortList) import Agda.Syntax.Position import Agda.Syntax.TopLevelModuleName @@ -60,6 +59,7 @@ import Agda.Syntax.Common.Pretty ( Pretty(..), prettyShow ) import qualified Agda.Syntax.Common.Pretty as P import Agda.Utils.Singleton+import Agda.Utils.Lens import Agda.Utils.Impossible @@ -109,9 +109,9 @@ -- Invariant: All paths are absolute. data FindError- = NotFound [AbsolutePath]- -- ^ The file was not found.- -- It should have had one of the given file names.+ = NotFound (List1 AbsolutePath)+ -- ^ An Agda module was not found.+ -- We were looking for it in one of the given include directories. | Ambiguous (List2 AbsolutePath) -- ^ Several matching files were found. deriving Show@@ -121,14 +121,9 @@ findErrorToTypeError :: TopLevelModuleName -> FindError -> TypeError findErrorToTypeError m = \case- NotFound files -> FileNotFound m files+ NotFound dirs -> FileNotFound m dirs Ambiguous files -> AmbiguousTopLevelModuleName m files --- findErrorToTypeError :: MonadFileId m => TopLevelModuleName -> FindError -> m TypeError--- findErrorToTypeError m = \case--- NotFound files -> FileNotFound m <$> mapM srcFilePath files--- Ambiguous files -> AmbiguousTopLevelModuleName m <$> mapM srcFilePath files- -- | Finds the source file corresponding to a given top-level module -- name. The returned paths are absolute. --@@ -147,11 +142,9 @@ -- SIDE EFFECT: Updates 'stModuleToSource'. findFile' :: TopLevelModuleName -> TCM (Either FindError SourceFile) findFile' m = do- dirs <- getIncludeDirs- modToSrc <- useTC stModuleToSource- (r, modToSrc) <- liftIO $ runStateT (findFile'' dirs m) modToSrc- stModuleToSource `setTCLens` modToSrc- return r+ dirs <- getIncludeDirs+ stateSessionLensM lensModuleToSource \modToSrc -> do+ liftIO $ runStateT (findFile'' dirs m) modToSrc -- | A variant of 'findFile'' which manipulates an extra 'ModuleToSourceId' @@ -160,14 +153,12 @@ -- ^ Include paths. -> TopLevelModuleName -> StateT ModuleToSourceId TCM (Either FindError SourceFile)-findFile'_ incs m = do- dict <- useTC stFileDict- m2s <- get+findFile'_ incs m = stateSessionLensM lensFileDict \dict -> do+ m2s <- get (r, ModuleToSource dict' m2s') <- liftIO $ runStateT (findFile'' incs m) $ ModuleToSource dict m2s- setTCLens stFileDict dict' put m2s'- return r+ return (r, dict') -- | A variant of 'findFile'' which does not require 'TCM'. @@ -190,8 +181,7 @@ put $ ModuleToSource dict' $ Map.insert m src modToSrc return (Right src) [] -> do- filesShortList <- liftIO $ fileList $ List2.toList parseFileExtsShortList- return (Left (NotFound filesShortList))+ return (Left (NotFound dirs)) f0:f1:fs -> return (Left (Ambiguous $ List2 f0 f1 fs)) where fileList exts = mapM absolute@@ -238,10 +228,10 @@ file <- srcFilePath src0 findFile' name >>= \case - Left (NotFound files) -> typeError $+ Left (NotFound dirs) -> typeError $ case mexpected of- Nothing -> ModuleNameDoesntMatchFileName name files- Just expected -> ModuleNameUnexpected name expected+ Nothing -> ModuleNameDoesntMatchFileName name dirs+ Just expected -> ModuleNameUnexpected (TopLevelModuleNameWithSourceFile name src0) expected Left (Ambiguous files) -> typeError $ AmbiguousTopLevelModuleName name files@@ -262,10 +252,6 @@ -- OverlappingProjects is the correct error for -- test/Fail/customized/NestedProjectRoots -- -- typeError $ ModuleNameUnexpected name expected---parseFileExtsShortList :: List2 String-parseFileExtsShortList = List2.cons ".agda" literateExtsShortList -- | Remove an Agda file extension from a filepath, if possible. stripAgdaExtension :: FilePath -> Maybe FilePath
src/full/Agda/Interaction/Highlighting/Dot/Backend.hs view
@@ -217,7 +217,7 @@ } postCompileDot- :: (MonadIO m, ReadTCState m)+ :: (MonadIO m) => DotCompileEnv -> IsMain -> Map TopLevelModuleName DotModule
src/full/Agda/Interaction/Highlighting/Emacs.hs view
@@ -3,7 +3,9 @@ -- | Functions which give precise syntax highlighting info to Emacs. module Agda.Interaction.Highlighting.Emacs- ( lispifyHighlightingInfo+ ( HighlightingInfo+ , lispifyHighlightingInfo+ , lispifyHighlightingInfo_ , lispifyTokenBased ) where @@ -16,8 +18,8 @@ import Agda.Interaction.Highlighting.Common import Agda.Interaction.Highlighting.Precise-import Agda.Interaction.Highlighting.Range (Range(..))-import Agda.Interaction.EmacsCommand+import Agda.Utils.Range (Range(..))+import Agda.Interaction.Emacs.Lisp import Agda.Interaction.Response import Agda.TypeChecking.Monad (HighlightingMethod(..), ModuleToSource, topLevelModuleFilePath)@@ -29,9 +31,6 @@ import Agda.Utils.String (quote) ---------------------------------------------------------------------------- Read/show functions- -- | Shows meta information in such a way that it can easily be read -- by Emacs. @@ -66,6 +65,14 @@ lispifyTokenBased TokenBased = A "t" lispifyTokenBased NotOnlyTokenBased = A "nil" +-- | Run 'showAspects' on a whole 'RangeMap'.+lispifyHighlightingInfo_ ::+ ModuleToSource+ -- ^ Must contain a mapping for every definition site's module.+ -> HighlightingInfo+ -> [Lisp String]+lispifyHighlightingInfo_ m2s = map (showAspects m2s) . toList+ -- | Turns syntax highlighting information into a list of -- S-expressions. @@ -80,25 +87,29 @@ -> HighlightingMethod -> ModuleToSource -- ^ Must contain a mapping for every definition site's module.+ -> Maybe FilePath -> IO (Lisp String)-lispifyHighlightingInfo h remove method modFile =+lispifyHighlightingInfo h remove method modFile target = case chooseHighlightingMethod h method of Direct -> direct Indirect -> indirect where info :: [Lisp String]- info = (case remove of- RemoveHighlighting -> A "remove"- KeepHighlighting -> A "nil") :- map (showAspects modFile) (toList h)+ info =+ A (case remove of+ RemoveHighlighting -> "remove"+ KeepHighlighting -> "nil") :+ lispifyHighlightingInfo_ modFile h direct :: IO (Lisp String)- direct = return $ L (A "agda2-highlight-add-annotations" :- map Q info)+ direct = return $ L $+ A "agda2-highlight-add-annotations" :+ A (maybe "nil" quote target) : map Q info indirect :: IO (Lisp String) indirect = do filepath <- writeToTempFile (prettyShow $ L info) return $ L [ A "agda2-highlight-load-and-delete-action" , A (quote filepath)+ , A (maybe "nil" quote target) ]
src/full/Agda/Interaction/Highlighting/FromAbstract.hs view
@@ -2,8 +2,8 @@ -- -- Implements one big fold over abstract syntax. --- {-# OPTIONS_GHC -fwarn-unused-imports #-} -- Data.Semigroup is redundant in later GHC versions-{-# OPTIONS_GHC -fwarn-unused-binds #-}+{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-binds #-} module Agda.Interaction.Highlighting.FromAbstract ( runHighlighter@@ -12,19 +12,16 @@ import Prelude hiding (null) -import Control.Applicative import Control.Monad.Reader ( MonadReader(..), asks, Reader, runReader ) -import qualified Data.Map as Map import Data.Maybe-import Data.Semigroup ( Semigroup(..) ) -- for ghc 8.0 import Data.Void ( Void ) import Agda.Interaction.Highlighting.Precise hiding ( singleton ) import qualified Agda.Interaction.Highlighting.Precise as H import Agda.Interaction.Highlighting.Range ( rToR ) -- Range is ambiguous -import Agda.Syntax.Abstract ( IsProjP(..) )+import Agda.Syntax.Abstract ( IsProjP(..), anameName, getAmbiguous, nameBindingSite ) import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Common as Common import Agda.Syntax.Concrete ( FieldAssignment'(..), TacticAttribute' )@@ -33,14 +30,13 @@ import Agda.Syntax.Literal 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.Scope.Base ( ResolvedName(..), exactConName ) import Agda.Syntax.TopLevelModuleName import Agda.TypeChecking.Monad hiding (ModuleInfo, MetaInfo, Primitive, Constructor, Record, Function, Datatype) import Agda.Utils.Function-import Agda.Utils.Functor import Agda.Utils.List ( initLast1 ) import Agda.Utils.List1 ( List1 ) import qualified Agda.Utils.List1 as List1@@ -214,9 +210,9 @@ A.Open mi x dir -> hl mi <> hl x <> hl dir A.FunDef _di x cs -> hl x <> hl cs A.DataSig _di er x tel e -> hl er <> hl x <> hl tel <> hl e- A.DataDef _di x _uc pars cs -> hl x <> hl pars <> hl cs+ A.DataDef _di x _pc _uc pars cs -> hl x <> hl pars <> hl cs A.RecSig _di er x tel e -> hl er <> hl x <> hl tel <> hl e- A.RecDef _di x _uc dir bs e ds -> hl x <> hl dir <> hl bs <> hl e <> hl ds+ A.RecDef _di x _pc _uc _eta dir bs e ds-> hl x <> hl dir <> hl bs <> hl e <> hl ds 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@@ -226,7 +222,7 @@ A.UnfoldingDecl _r names -> hl names where hl a = hilite a- hlField x = hiliteField (concreteQualifier x) (concreteBase x) (Just $ bindingSite x)+ hlField x = hiliteField (concreteQualifier x) (concreteBase x) (Just $ nameBindingSite x) instance Hilite A.Pragma where hilite = \case@@ -234,9 +230,9 @@ A.BuiltinPragma b x -> singleAspect Keyword b <> hilite x A.BuiltinNoDefPragma b k x -> singleAspect Keyword b <> hiliteQName (Just $ kindOfNameToNameKind k) x A.CompilePragma b x _foreign -> singleAspect Keyword b <> hilite x+ A.ForeignPragma b _foreign -> singleAspect Keyword b A.RewritePragma r xs -> singleAspect Keyword r <> hilite xs A.StaticPragma x -> hilite x- A.EtaPragma x -> hilite x A.InjectivePragma x -> hilite x A.InjectiveForInferencePragma x -> hilite x A.NotProjectionLikePragma x -> hilite x@@ -273,6 +269,8 @@ A.QuoteTerm _r -> mempty A.Unquote _r -> mempty A.DontCare e -> hl e+ A.Qualified m e -> hl m <> hl e+ A.Highlighted m e -> pure (H.singleton (rToR $ getRange e) m) <> hl e where hl a = hilite a @@ -360,7 +358,7 @@ hilite = \case A.LetBind _r ai x t e -> hl ai <> hl x <> hl t <> hl e A.LetAxiom _r ai x t -> hl ai <> hl x <> hl t- A.LetPatBind _r p e -> hl p <> hl e+ A.LetPatBind _r ai p e -> hl ai <> hl p <> hl e A.LetApply mi er x es _c dir -> hl mi <> hl er <> hl x <> hl es <> hl dir A.LetOpen mi x dir -> hl mi <> hl x <> hl dir@@ -455,10 +453,10 @@ hilite = \case VarName x _bindSrc -> hiliteBound x DefinedName _acc x _suffix -> hilite $ anameName x- FieldName xs -> hiliteProjection $ A.AmbQ $ fmap anameName xs- ConstructorName i xs -> hiliteAmbiguousQName k $ A.AmbQ $ fmap anameName xs+ FieldName xs -> hiliteProjection $ A.ambigName xs+ ConstructorName i xs -> hiliteAmbiguousQName k $ A.ambigName xs where k = kindOfNameToNameKind <$> exactConName i- PatternSynResName xs -> hilitePatternSynonym $ A.AmbQ $ fmap anameName xs+ PatternSynResName xs -> hilitePatternSynonym $ A.ambigName xs UnknownName -> mempty instance Hilite A.QName where@@ -516,7 +514,7 @@ :: Maybe NameKind -- ^ Is 'NameKind' already known from the context? -> A.AmbiguousQName -> Hiliter-hiliteAmbiguousQName mkind (A.AmbQ qs) = do+hiliteAmbiguousQName mkind x = do kind <- ifJust mkind (pure . Just) {-else-} $ do kinds <- asks hleNameKinds pure $ listToMaybe $ List1.catMaybes $ fmap kinds qs@@ -526,7 +524,8 @@ flip foldMap qs $ \ q -> hiliteAName q include $ nameAsp' kind where- include = List1.allEqual $ fmap bindingSite qs+ qs = getAmbiguous x+ include = List1.allEqual $ fmap nameBindingSite qs hiliteBound :: A.Name -> Hiliter hiliteBound x =@@ -598,7 +597,7 @@ mFilePos :: Maybe DefinitionSite mFilePos = do r <- mR- P.Pn { P.srcFile = Strict.Just f, P.posPos = p } <- P.rStart r+ P.Pn (Strict.Just f) p _ _ <- P.rStart r mod <- P.rangeFileName f -- Andreas, 2017-06-16, Issue #2604: Symbolic anchors. -- We drop the file name part from the qualifiers, since@@ -657,7 +656,7 @@ hiliteCName (concreteQualifier x) (concreteBase x) (rangeOfFixityDeclaration currentModule)- (if include then Just $ bindingSite x else Nothing)+ (if include then Just $ nameBindingSite x else Nothing) asp <> notationFile currentModule where@@ -707,6 +706,3 @@ concreteQualifier :: A.QName -> [C.Name] concreteQualifier = map A.nameConcrete . A.mnameToList . A.qnameModule--bindingSite :: A.QName -> Range-bindingSite = A.nameBindingSite . A.qnameName
src/full/Agda/Interaction/Highlighting/Generate.hs view
@@ -32,7 +32,7 @@ import qualified Data.IntMap as IntMap import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HMap-import Data.Semigroup (Semigroup(..))+import Data.Semigroup (sconcat) import Data.Sequence (Seq) import qualified Data.Set as Set import qualified Data.Text.Lazy as Text@@ -43,6 +43,7 @@ import Agda.Interaction.Highlighting.Range (rToR, rangeToRange, overlappings, Ranges) import Agda.Interaction.Highlighting.FromAbstract+import Agda.Interaction.Options.Types (optMdOnlyAgdaBlocks) import qualified Agda.TypeChecking.Errors as TCM import Agda.TypeChecking.MetaVars (isBlockedTerm, hasTwinMeta)@@ -51,10 +52,12 @@ import qualified Agda.TypeChecking.Monad as TCM import qualified Agda.TypeChecking.Monad.Base.Warning as W import qualified Agda.TypeChecking.Pretty as TCM-import Agda.TypeChecking.Positivity.Occurrence+import Agda.TypeChecking.Positivity.Occurrence (Occurrence(..))+import Agda.TypeChecking.Positivity.Warnings import Agda.TypeChecking.Warnings ( raiseWarningsOnUsage ) import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Abstract.Name (nameBindingSite) import Agda.Syntax.Concrete.Definitions as W ( DeclarationWarning(..), DeclarationWarning'(..) ) import Agda.Syntax.Common (Induction(..), pattern Ranged) import qualified Agda.Syntax.Common.Aspect as Aspect@@ -210,9 +213,10 @@ -- ^ The file contents. Note that the file is /not/ read from -- disk. -> TCM HighlightingInfo-generateTokenInfoFromSource file input =+generateTokenInfoFromSource file input = do+ mdOnlyAgdaBlocks <- optMdOnlyAgdaBlocks <$> commandLineOptions runPM $ tokenHighlighting . fst . fst <$>- Pa.parseFile Pa.tokensParser file input+ Pa.parseFile mdOnlyAgdaBlocks 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@@ -234,26 +238,31 @@ aToF a r = H.singleton (rToR r) (mempty { aspect = Just a }) tokenToHI :: T.Token -> HighlightingInfoBuilder- tokenToHI (T.TokKeyword T.KwForall i) = aToF Symbol (getRange i)- tokenToHI (T.TokKeyword T.KwREWRITE _) = mempty -- #4361, REWRITE is not always a Keyword- tokenToHI (T.TokKeyword _ i) = aToF Keyword (getRange i)+ tokenToHI (T.TokKeyword T.KwForall i) = aToF Symbol (getRange i)+ tokenToHI (T.TokKeyword T.KwREWRITE _) = mempty -- #4361, REWRITE is not always a Keyword+ tokenToHI (T.TokKeyword _ i) = aToF Keyword (getRange i) tokenToHI (T.TokSymbol T.SymQuestionMark i) = aToF Hole (getRange i) tokenToHI (T.TokSymbol _ i) = aToF Symbol (getRange i)- tokenToHI (T.TokLiteral (Ranged r (L.LitNat _))) = aToF Number r- tokenToHI (T.TokLiteral (Ranged r (L.LitWord64 _))) = aToF Number r- tokenToHI (T.TokLiteral (Ranged r (L.LitFloat _))) = aToF Number r- tokenToHI (T.TokLiteral (Ranged r (L.LitString _))) = aToF String r- tokenToHI (T.TokLiteral (Ranged r (L.LitChar _))) = aToF String r- tokenToHI (T.TokLiteral (Ranged r (L.LitQName _))) = aToF String r- tokenToHI (T.TokLiteral (Ranged r (L.LitMeta _ _))) = aToF String r- tokenToHI (T.TokComment (i, _)) = aToF Comment (getRange i)- tokenToHI (T.TokTeX (i, _)) = aToF Background (getRange i)- tokenToHI (T.TokMarkup (i, _)) = aToF Markup (getRange i)- tokenToHI (T.TokId {}) = mempty- tokenToHI (T.TokQId {}) = mempty- tokenToHI (T.TokString (i,s)) = aToF Pragma (getRange i)- tokenToHI (T.TokDummy {}) = mempty- tokenToHI (T.TokEOF {}) = mempty+ tokenToHI (T.TokComment (i, _)) = aToF Comment (getRange i)+ tokenToHI (T.TokTeX (i, _)) = aToF Background (getRange i)+ tokenToHI (T.TokMarkup (i, _)) = aToF Markup (getRange i)+ tokenToHI (T.TokId {}) = mempty+ tokenToHI (T.TokQId {}) = mempty+ tokenToHI (T.TokString (i,s)) = aToF Pragma (getRange i)+ tokenToHI (T.TokDummy {}) = mempty+ tokenToHI (T.TokEOF {}) = mempty+ tokenToHI (T.TokQual cls _ i) = case cls of+ T.QualDo -> aToF Keyword (getRange i)+ T.QualOpenIdiom{} -> aToF Symbol (getRange i)+ T.QualEmptyIdiom{} -> aToF Symbol (getRange i)+ tokenToHI (T.TokLiteral (Ranged r l)) = case l of+ L.LitNat{} -> aToF Number r+ L.LitWord64{} -> aToF Number r+ L.LitFloat{} -> aToF Number r+ L.LitString{} -> aToF String r+ L.LitChar{} -> aToF String r+ L.LitQName{} -> aToF String r+ L.LitMeta{} -> aToF String r -- | Builds a 'NameKinds' function. @@ -277,27 +286,13 @@ let syntax :: NameKindMap syntax = runBuilder (declaredNames decl :: NameKindBuilder) HMap.empty return $ \ n -> unionsMaybeWith mergeNameKind- [ defnToKind . theDef <$> HMap.lookup n local+ [ TCM.defnToNameKind . theDef <$> HMap.lookup n local , con <$ Map.lookup n locPatSyns- , defnToKind . theDef <$> HMap.lookup n imported+ , TCM.defnToNameKind . theDef <$> HMap.lookup n imported , con <$ Map.lookup n impPatSyns , HMap.lookup n syntax ] where- defnToKind :: TCM.Defn -> NameKind- defnToKind TCM.Axiom{} = Postulate- defnToKind TCM.DataOrRecSig{} = Postulate- defnToKind TCM.GeneralizableVar{} = Generalizable- defnToKind d@TCM.Function{}- | isProperProjection d = Field- | isMacro d = Macro -- AIM XL, issue #7324- | otherwise = Function- defnToKind TCM.Datatype{} = Datatype- defnToKind TCM.Record{} = Record- defnToKind TCM.Constructor{ TCM.conSrcCon = c } = Constructor $ I.conInductive c- defnToKind TCM.Primitive{} = Primitive- defnToKind TCM.PrimitiveSort{} = Primitive- defnToKind TCM.AbstractDefn{} = __IMPOSSIBLE__ con :: NameKind con = Constructor Inductive@@ -381,7 +376,10 @@ -- | Generate highlighting for error. errorHighlighting :: TCErr -> TCM HighlightingInfoBuilder-errorHighlighting e = errorHighlighting' (getRange e) <$> TCM.renderError e+errorHighlighting e = mconcat+ [ extraErrorHighlighting e+ , errorHighlighting' (getRange e) <$> TCM.renderError e+ ] errorHighlighting' :: Range -- ^ Error range.@@ -397,6 +395,24 @@ } ] +-- | Some errors point to things out of the errorneous expression/declaration,+-- so we might to highlight these things as well.+extraErrorHighlighting :: TCErr -> TCM HighlightingInfoBuilder+extraErrorHighlighting = \case+ TypeError _ _ cl ->+ case clValue cl of+ -- Andreas, 2025-09-15.+ -- The identifier that would be shadowed by the clashing definition+ -- is highlighted as dead code.+ -- (Not sure how good this is.)+ ClashingDefinition _ y _ -> return $ deadcodeHighlighting $ I.nameBindingSite $ clashingQName y+ ShadowedModule x ms -> deadcodeHighlighting . snd <$> TCM.prettyShadowedModule x ms+ -- 'prettyShadowedModule' mostly duplicates the work done by @'renderError' ('ShadowedModule' x ms)@+ -- in 'errorHighlighting',+ -- but since throwing an error is a once-in-a-run thing we need not worry.+ _ -> mempty+ _ -> mempty+ -- | Highlighting for warnings that are considered fatal. errorWarningHighlighting :: HasRange a => a -> HighlightingInfoBuilder@@ -420,6 +436,7 @@ ConstructorDoesNotFitInData _dataOrRecord c _s1 _s2 _err -> errorWarningHighlighting $ getRange c `catchNull` getRange w CoinductiveEtaRecord _x -> deadcodeHighlighting w+ UnguardedEtaRecordW _x -> errorWarningHighlighting w -- #3965 highlight each unreachable clause independently: they -- may be interleaved with actually reachable clauses! UnreachableClauses _ rs -> foldMap deadcodeHighlighting rs@@ -450,7 +467,11 @@ where r = getRange q FixingPolarity _ q _ -> if null r then cosmeticProblemHighlighting w else deadcodeHighlighting r where r = getRange q+ IgnoringRew _ q -> if null r then cosmeticProblemHighlighting w else deadcodeHighlighting r+ where r = getRange q IllformedAsClause{} -> deadcodeHighlighting w+ UnusedImports m Nothing -> deadcodeHighlighting w+ UnusedImports m xs -> cosmeticProblemHighlighting w <> foldMap deadcodeHighlighting xs UselessPragma r _ -> deadcodeHighlighting r UselessPublic{} -> deadcodeHighlighting w UselessHiding xs -> foldMap deadcodeHighlighting xs@@ -460,8 +481,8 @@ ClashesViaRenaming _ xs -> foldMap deadcodeHighlighting xs -- #4154, TODO: clashing renamings are not dead code, but introduce problems. -- Should we have a different color?- WrongInstanceDeclaration{} -> instanceProblemHighlighting w- InstanceWithExplicitArg{} -> instanceProblemHighlighting w+ WrongInstanceDeclaration kwr -> instanceProblemHighlighting kwr <> instanceProblemHighlighting w+ InstanceWithExplicitArg kwr _ -> instanceProblemHighlighting kwr <> instanceProblemHighlighting w InstanceNoOutputTypeName{} -> instanceProblemHighlighting w InstanceArgWithExplicitArg{} -> instanceProblemHighlighting w InversionDepthReached{} -> mempty@@ -476,8 +497,10 @@ CoInfectiveImport{} -> errorWarningHighlighting w InvalidDisplayForm{} -> deadcodeHighlighting w UnusedVariablesInDisplayForm xs -> foldMap deadcodeHighlighting xs+ ShouldBeEtaRecordPattern -> catchallHighlighting $ getRange w TooManyArgumentsToSort _ args -> errorWarningHighlighting args RewritesNothing -> cosmeticProblemHighlighting w+ RecursiveRecordNeedsInductivity _x -> errorWarningHighlighting w WithClauseProjectionFixityMismatch p _ _ _ -> cosmeticProblemHighlighting p WithoutKFlagPrimEraseEquality -> mempty ConflictingPragmaOptions{} -> mempty@@ -490,8 +513,10 @@ RewriteMaybeNonConfluent{} -> confluenceErrorHighlighting w RewriteAmbiguousRules{} -> confluenceErrorHighlighting w RewriteMissingRule{} -> confluenceErrorHighlighting w- IllegalRewriteRule x _ -> deadcodeHighlighting x+ IllegalRewriteRule (GlobalRewrite x) _ -> deadcodeHighlighting x+ IllegalRewriteRule (LocalRewrite _ x _) _ -> deadcodeHighlighting x NotARewriteRule x _ -> deadcodeHighlighting x+ InferredLocalRewrite _ _ -> mempty PragmaCompileErased{} -> deadcodeHighlighting w PragmaCompileList{} -> deadcodeHighlighting w PragmaCompileMaybe{} -> deadcodeHighlighting w@@ -504,6 +529,7 @@ -> deadcodeHighlighting w PragmaExpectsUnambiguousProjectionOrFunction{} -> deadcodeHighlighting w+ UnknownJSPrimitive{} -> mempty NoMain{} -> mempty NotInScopeW{} -> deadcodeHighlighting w UnsupportedIndexedMatch{} -> mempty@@ -520,6 +546,7 @@ Pa.UnknownAttribute{} -> deadcodeHighlighting w Pa.UnsupportedAttribute{} -> deadcodeHighlighting w Pa.MultipleAttributes{} -> deadcodeHighlighting w+ Pa.MismatchedBrackets{} -> errorWarningHighlighting w Pa.OverlappingTokensWarning{} -> mempty MissingTypeSignatureForOpaque{} -> errorWarningHighlighting w NotAffectedByOpaque{} -> deadcodeHighlighting w@@ -533,12 +560,15 @@ InstanceNotInArgumentPosition{} -> errorWarningHighlighting w MacroInLetBindings{} -> errorWarningHighlighting w AbstractInLetBindings{} -> errorWarningHighlighting w+ IllegalDeclarationInDataDefinition{} -> errorWarningHighlighting w+ DefinitionBeforeDeclaration x -> cosmeticProblemHighlighting w <> cosmeticProblemHighlighting (nameBindingSite x) NicifierIssue (DeclarationWarning _ w) -> case w of -- we intentionally override the binding of `w` here so that our pattern of -- using `getRange w` still yields the most precise range information we -- can get. NotAllowedInMutual{} -> deadcodeHighlighting w+ DivergentModalityInClause{} -> deadcodeHighlighting w EmptyAbstract{} -> deadcodeHighlighting w EmptyConstructor{} -> deadcodeHighlighting w EmptyInstance{} -> deadcodeHighlighting w@@ -550,6 +580,7 @@ EmptyGeneralize{} -> deadcodeHighlighting w EmptyField{} -> deadcodeHighlighting w EmptyPolarityPragma{} -> deadcodeHighlighting w+ FixityDeclarationForNonOperator{}-> deadcodeHighlighting w HiddenGeneralize{} -> mempty -- Andreas, 2022-03-25, issue #5850 -- We would like @deadcodeHighlighting w@ for the braces in@@ -557,18 +588,22 @@ -- Highlighting the variable instead might be misleading, -- suggesting that it is not generalized over. UselessAbstract{} -> deadcodeHighlighting w+ UselessImport{} -> deadcodeHighlighting w UselessInstance{} -> deadcodeHighlighting w UselessMacro{} -> deadcodeHighlighting w UselessPrivate{} -> deadcodeHighlighting w InvalidCatchallPragma{} -> deadcodeHighlighting w+ InvalidEtaEqualityPragma{} -> deadcodeHighlighting w InvalidNoPositivityCheckPragma{} -> deadcodeHighlighting w InvalidNoUniverseCheckPragma{} -> deadcodeHighlighting w InvalidTerminationCheckPragma{} -> deadcodeHighlighting w InvalidCoverageCheckPragma{} -> deadcodeHighlighting w InvalidConstructorBlock{} -> deadcodeHighlighting w+ InvalidDataOrRecDefParameter{} -> deadcodeHighlighting w+ InvalidTacticAttribute{} -> deadcodeHighlighting w+ InvalidRewriteAttribute{} -> deadcodeHighlighting w OpenImportAbstract{} -> cosmeticProblemHighlighting w OpenImportPrivate{} -> cosmeticProblemHighlighting w- SafeFlagEta {} -> errorWarningHighlighting w SafeFlagInjective {} -> errorWarningHighlighting w SafeFlagNoCoverageCheck {} -> errorWarningHighlighting w SafeFlagNoPositivityCheck {} -> errorWarningHighlighting w@@ -586,8 +621,8 @@ PragmaNoTerminationCheck{} -> mempty PragmaCompiled{} -> errorWarningHighlighting w UnknownFixityInMixfixDecl{} -> mempty- UnknownNamesInFixityDecl{} -> mempty- UnknownNamesInPolarityPragmas{} -> mempty+ UnknownNamesInFixityDecl{} -> errorWarningHighlighting w+ UnknownNamesInPolarityPragmas{} -> errorWarningHighlighting w -- Backends CustomBackendWarning{} -> mempty@@ -615,11 +650,10 @@ terminationErrorHighlighting termErrs = functionDefs `mappend` callSites where m = parserBased { otherAspects = Set.singleton TerminationProblem }- functionDefs = foldMap (\x -> H.singleton (rToR $ bindingSite x) m) $+ functionDefs = foldMap (\x -> H.singleton (rToR $ nameBindingSite x) m) $ concatMap termErrFunctions termErrs callSites = foldMap (\r -> H.singleton (rToR r) m) $ concatMap (map getRange . termErrCalls) termErrs- bindingSite = A.nameBindingSite . A.qnameName -- | Generate syntax highlighting for not-strictly-positive inductive -- definitions.@@ -737,11 +771,11 @@ -- get ranges of interesting unsolved constraints rs = (`mapMaybe` (map theConstraint cs)) $ \case Closure{ clValue = IsEmpty r t } -> Just r- Closure{ clEnv = e, clValue = ValueCmp{} } -> Just $ getRange (envRange e)- Closure{ clEnv = e, clValue = ElimCmp{} } -> Just $ getRange (envRange e)- Closure{ clEnv = e, clValue = SortCmp{} } -> Just $ getRange (envRange e)- Closure{ clEnv = e, clValue = LevelCmp{} } -> Just $ getRange (envRange e)- Closure{ clEnv = e, clValue = CheckSizeLtSat{} } -> Just $ getRange (envRange e)+ Closure{ clEnv = e, clValue = ValueCmp{} } -> Just $! getRange (view eRange e)+ Closure{ clEnv = e, clValue = ElimCmp{} } -> Just $! getRange (view eRange e)+ Closure{ clEnv = e, clValue = SortCmp{} } -> Just $! getRange (view eRange e)+ Closure{ clEnv = e, clValue = LevelCmp{} } -> Just $! getRange (view eRange e)+ Closure{ clEnv = e, clValue = CheckSizeLtSat{} } -> Just $! getRange (view eRange e) _ -> Nothing
src/full/Agda/Interaction/Highlighting/HTML/Base.hs view
@@ -50,6 +50,7 @@ -- The defined operator (!!) attaches a list of such Attributes import Agda.Interaction.Highlighting.Precise hiding (toList)+import Agda.Interaction.Highlighting.HTML.Forester import Agda.Syntax.Common import Agda.Syntax.TopLevelModuleName@@ -172,7 +173,7 @@ doLog <- ask lift $ doLog message -runLogHtmlWith :: Monad m => HtmlLogAction m -> LogHtmlT m a -> m a+runLogHtmlWith :: HtmlLogAction m -> LogHtmlT m a -> m a runLogHtmlWith = flip runReaderT renderSourceFile :: HtmlOptions -> HtmlInputSourceFile -> Text@@ -182,7 +183,7 @@ highlightOccur = htmlOptHighlightOccurrences opts htmlHighlight = htmlOptHighlight opts renderSourcePage (HtmlInputSourceFile moduleName fileType sourceCode hinfo) =- page cssFile highlightOccur onlyCode moduleName pageContents+ page cssFile highlightOccur onlyCode fileType moduleName pageContents where tokens = tokenStream sourceCode hinfo onlyCode = highlightOnlyCode htmlHighlight fileType@@ -242,18 +243,24 @@ page :: FilePath -- ^ URL to the CSS file. -> Bool -- ^ Highlight occurrences -> Bool -- ^ Whether to reserve literate+ -> FileType -- ^ Type of file -> TopLevelModuleName -- ^ Module to be highlighted. -> Html -> Text page css highlightOccurrences htmlHighlight+ fileType modName pageContent =- renderHtml $ if htmlHighlight- then pageContent- else Html5.docTypeHtml $ hdr <> rest+ renderF $ if htmlHighlight+ then pageContent+ else Html5.docTypeHtml $ hdr <> rest where++ renderF = case fileType of+ TreeFileType -> renderForesterHtml+ _ -> renderHtml hdr = Html5.head $ mconcat [ Html5.meta !! [ Attr.charset "utf-8" ]
+ src/full/Agda/Interaction/Highlighting/HTML/Forester.hs view
@@ -0,0 +1,147 @@+module Agda.Interaction.Highlighting.HTML.Forester+ ( renderForesterHtml,+ )+where++import Data.ByteString (ByteString)+import Data.ByteString qualified as S (isInfixOf)+import Data.List (isInfixOf)+import Data.Monoid (mappend, mempty)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding (decodeUtf8)+import Data.Text.Lazy qualified as L+import Data.Text.Lazy.Builder (Builder)+import Data.Text.Lazy.Builder qualified as B+import Text.Blaze.Html5 (Html)+import Text.Blaze.Internal+ ( ChoiceString (..),+ MarkupM (..),+ StaticString (getText),+ )++fromChoiceString ::+ -- | Decoder for bytestrings+ (ByteString -> Text) ->+ -- | String to render+ ChoiceString ->+ -- | Resulting builder+ Builder+fromChoiceString _ (Static s) = B.fromText $ getText s+fromChoiceString _ (String s) = B.fromText $ T.pack s+fromChoiceString _ (Text s) = B.fromText s+fromChoiceString d (ByteString s) = B.fromText $ d s+fromChoiceString d (PreEscaped x) = case x of+ String s -> B.fromText $ T.pack s+ Text s -> B.fromText s+ s -> fromChoiceString d s+fromChoiceString d (External x) = case x of+ -- Check that the sequence "</" is *not* in the external data.+ String s -> if "</" `isInfixOf` s then mempty else B.fromText (T.pack s)+ Text s -> if "</" `T.isInfixOf` s then mempty else B.fromText s+ ByteString s -> if "</" `S.isInfixOf` s then mempty else B.fromText (d s)+ s -> fromChoiceString d s+fromChoiceString d (AppendChoiceString x y) =+ fromChoiceString d x `mappend` fromChoiceString d y+fromChoiceString _ EmptyChoiceString = mempty+{-# INLINE fromChoiceString #-}++modify_open :: StaticString -> Text+modify_open open =+ let a = getText open+ in T.cons '<' (T.append "html:" (T.tail a))++modify_key :: StaticString -> Text+modify_key key =+ let a = getText key+ in T.dropEnd 2 (T.strip a)++-- Escape for forester lexer+wrap_verb :: Builder -> Builder+wrap_verb w = B.fromLazyText $ L.foldr go "" (B.toLazyText w)+ where+ go :: Char -> L.Text -> L.Text+ go '[' acc = L.append "\\startverb[\\stopverb" acc+ go ']' acc = L.append "\\startverb]\\stopverb" acc+ go x acc = L.cons x acc++renderMarkupBuilderWith ::+ (ByteString -> Text) ->+ Html ->+ Builder+renderMarkupBuilderWith d = go mempty+ where+ go :: Builder -> MarkupM b -> Builder+ go attrs (Parent _ open close content) =+ mconcat+ [ B.fromText "\\",+ B.fromText (modify_open open),+ B.fromText ">",+ attrs,+ B.fromText "{",+ go mempty content,+ B.fromText "}"+ ]+ go attrs (CustomParent tag content) =+ mconcat+ [ B.fromText "\\<html:",+ fromChoiceString d tag,+ B.fromText ">",+ attrs,+ B.fromText "{",+ go mempty content,+ fromChoiceString d tag,+ B.fromText "}"+ ]+ go attrs (Leaf _ begin end _) =+ mconcat+ [ B.fromText (modify_open begin),+ B.fromText ">",+ attrs,+ B.fromText "{}"+ ]+ go attrs (CustomLeaf tag close _) =+ mconcat+ [ B.fromText "\\<html:",+ fromChoiceString d tag,+ attrs,+ B.fromText ">{}"+ ]+ go attrs (AddAttribute _ key value h) =+ go+ ( mconcat+ [ B.singleton '[',+ B.fromText (modify_key key),+ B.fromText "]{",+ wrap_verb (fromChoiceString d value),+ B.fromText "}",+ attrs+ ]+ )+ h+ go attrs (AddCustomAttribute key value h) =+ go+ ( mconcat+ [ B.singleton '[',+ fromChoiceString d key,+ B.fromText "]{",+ wrap_verb (fromChoiceString d value),+ B.fromText "}",+ attrs+ ]+ )+ h+ go _ (Content content _) = wrap_verb (fromChoiceString d content)+ go _ (Comment comment _) = B.fromText "% " <> fromChoiceString d comment+ go attrs (Append h1 h2) = go attrs h1 <> go attrs h2+ go _ (Empty _) = mempty+ {-# NOINLINE go #-}+{-# INLINE renderMarkupBuilderWith #-}++renderMarkupWith :: (ByteString -> Text) -> Html -> L.Text+renderMarkupWith d = B.toLazyText . renderMarkupBuilderWith d+{-# INLINE renderMarkupWith #-}++renderForesterHtml :: Html -> L.Text+renderForesterHtml = renderMarkupWith decodeUtf8+{-# INLINE renderForesterHtml #-}
src/full/Agda/Interaction/Highlighting/JSON.hs view
@@ -8,7 +8,7 @@ import Agda.Interaction.Highlighting.Common import Agda.Interaction.Highlighting.Precise hiding (String)-import Agda.Interaction.Highlighting.Range (Range(..))+import Agda.Utils.Range (Range(..)) import Agda.Interaction.JSON import Agda.Interaction.Response @@ -51,8 +51,9 @@ -> HighlightingMethod -> ModuleToSource -- ^ Must contain a mapping for every definition site's module.+ -> Maybe FilePath -> IO Value-jsonifyHighlightingInfo info remove method modFile =+jsonifyHighlightingInfo info remove method modFile file = case chooseHighlightingMethod info method of Direct -> direct Indirect -> indirect@@ -66,17 +67,19 @@ ] direct :: IO Value- direct = return $ object+ direct = return $ object $ [ "kind" .= String "HighlightingInfo" , "direct" .= True , "info" .= result- ]+ ] ++ fileField indirect :: IO Value indirect = do filepath <- writeToTempFile (BS.unpack (encode result))- return $ object+ return $ object $ [ "kind" .= String "HighlightingInfo" , "direct" .= False , "filepath" .= filepath- ]+ ] ++ fileField++ fileField = maybe [] (\path -> ["file" .= path]) file
src/full/Agda/Interaction/Highlighting/LaTeX.hs view
@@ -8,4 +8,5 @@ import Agda.Interaction.Highlighting.LaTeX.Backend as Exports ( latexBackend+ , latexBackendName )
src/full/Agda/Interaction/Highlighting/LaTeX/Backend.hs view
@@ -2,6 +2,7 @@ module Agda.Interaction.Highlighting.LaTeX.Backend ( latexBackend+ , latexBackendName ) where import Agda.Interaction.Highlighting.LaTeX.Base@@ -35,18 +36,18 @@ , OptDescr(..) ) +import Agda.Syntax.Common (BackendName) import Agda.Syntax.Position (mkRangeFile, rangeFilePath) import Agda.Syntax.TopLevelModuleName (TopLevelModuleName, projectRoot) import Agda.TypeChecking.Monad ( HasOptions(commandLineOptions) , MonadDebug- , stModuleToSourceId- , useTC+ , useSession, lensModuleToSourceId , ReadTCState , reportS , MonadFileId- , srcFilePath+ , srcFilePath, ReadTCState ) import Agda.Utils.FileName (filePath, mkAbsolute)@@ -76,6 +77,8 @@ , latexFlagGenerateLaTeX = False } +-- | Command-line flag options for LaTeX.+-- The 'latexPragmaOptions' are not included here since they have a different 'Flag' type. latexFlagsDescriptions :: [OptDescr (Flag LaTeXFlags)] latexFlagsDescriptions = [ Option [] ["latex"] (NoArg latexFlag)@@ -96,12 +99,15 @@ data LaTeXModule = LaTeXModule data LaTeXDef = LaTeXDef +latexBackendName :: BackendName+latexBackendName = "LaTeX"+ latexBackend :: Backend latexBackend = Backend latexBackend' latexBackend' :: Backend' LaTeXFlags LaTeXCompileEnv LaTeXModuleEnv LaTeXModule LaTeXDef latexBackend' = Backend'- { backendName = "LaTeX"+ { backendName = latexBackendName , backendVersion = Nothing , options = defaultLaTeXFlags , commandLineFlags = latexFlagsDescriptions@@ -125,13 +131,13 @@ logLaTeX = LogLaTeXDebugT . (reportS "compile.latex" 1) . T.unpack . logMsgToText -- Resolve the raw flags into usable LaTeX options.-resolveLaTeXOptions :: (HasOptions m, ReadTCState m, MonadFileId m)+resolveLaTeXOptions :: (ReadTCState m, HasOptions m, MonadFileId m) => LaTeXFlags -> TopLevelModuleName -> m LaTeXOptions resolveLaTeXOptions flags moduleName = do options <- commandLineOptions- modFiles <- useTC stModuleToSourceId+ modFiles <- useSession lensModuleToSourceId let msrc = Map.lookup moduleName modFiles mf <- traverse srcFilePath msrc let
src/full/Agda/Interaction/Highlighting/LaTeX/Base.hs view
@@ -191,7 +191,7 @@ deriving (Eq, Show) -- | Run function for the @LaTeX@ monad.-runLaTeX :: MonadLogLaTeX m =>+runLaTeX :: LaTeXT m a -> Env -> State -> m (a, State, [Output]) runLaTeX = runRWST @@ -481,7 +481,7 @@ output $ Text $ -- we return the escaped token wrapped in commands corresponding -- to its aspect (if any) and other aspects (e.g. error, unsolved meta)- foldr (\c t -> cmdPrefix <> T.pack c <> cmdArg t)+ foldr (\c t -> cmdPrefix <> c <> cmdArg t) (escape tok) $ map fromOtherAspect (toList $ otherAspects $ info tok') ++ concatMap fromAspect (toList $ aspect $ info tok')@@ -495,11 +495,33 @@ -- Translation from OtherAspect to command strings. So far it happens -- to correspond to @show@ but it does not have to (cf. fromAspect)- fromOtherAspect :: OtherAspect -> String- fromOtherAspect = show+ fromOtherAspect :: OtherAspect -> Text+ fromOtherAspect a = let s = T.pack (show a) in+ -- Andreas, 2026-02-17, issue #8402+ -- Expand OtherAspect into all of its cases+ -- such that a developer adding to OtherAspect gets alerted here.+ -- All ASPECTs need a corresponding @\AgdaASPECT@ command in agda.sty.+ case a of+ Error -> s+ ErrorWarning -> s+ DottedPattern -> s+ UnsolvedMeta -> s+ UnsolvedConstraint -> s+ TerminationProblem -> s+ PositivityProblem -> s+ Deadcode -> s+ ShadowingInTelescope -> s+ CoverageProblem -> s+ TypeChecks -> s+ MissingDefinition -> s+ InstanceProblem -> s+ CosmeticProblem -> s+ CatchallClause -> s+ ConfluenceProblem -> s - fromAspect :: Aspect -> [String]- fromAspect a = let s = [show a] in case a of+ fromAspect :: Aspect -> [Text]+ fromAspect a = let s = [T.pack $ show a] in case a of+ URL url -> [ "HRef", cmdArg url ] Comment -> s Keyword -> s Hole -> s@@ -519,9 +541,10 @@ -- -- The choice of "Postulate" works for this example, but might -- be less appropriate for others.- Name (Just kind) isOp ->- (\c -> if isOp then ["Operator", c] else [c]) $- case kind of+ Name (Just kind) isOp -> if isOp then ["Operator", c] else [c]+ where+ sk = T.pack $ show kind+ c = case kind of Bound -> sk Generalizable -> sk Constructor Inductive -> "InductiveConstructor"@@ -535,8 +558,6 @@ Record -> sk Argument -> sk Macro -> sk- where- sk = show kind -- | Escapes special characters. escape :: Text -> Text@@ -557,9 +578,6 @@ '\\' -> "\\textbackslash{}" ' ' -> "\\ " _ -> [ char ]-#if __GLASGOW_HASKELL__ < 810-escape _ = __IMPOSSIBLE__-#endif -- | Every element in the list should consist of either one or more -- newline characters, or one or more space characters. Two adjacent@@ -713,14 +731,16 @@ 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])- []+ logFileSystem $ unwords $+ [defaultStyFile, "was not found. Copying a default version of", defaultStyFile, "into", dir] liftIO $ do styFile <- getDataFileName $ latexDataDir </> defaultStyFile copyFile styFile agdaSty +logFileSystem :: (MonadLogLaTeX m) => String -> m ()+logFileSystem s = logLaTeX $ LogMessage FileSystem (T.pack s) []+ -- | Generates a LaTeX file for the given interface. generateLaTeXIO :: (MonadLogLaTeX m, MonadIO m) => LaTeXOptions -> Interface -> m () generateLaTeXIO opts i = do@@ -733,6 +753,7 @@ (latexOptSourceFileName opts) (iSource i) (iHighlighting i)+ logFileSystem $ unwords [ "writing", outPath ] liftIO $ do createDirectoryIfMissing True (takeDirectory outPath) BS.writeFile outPath latex
src/full/Agda/Interaction/Highlighting/Precise.hs view
@@ -32,7 +32,7 @@ import Control.DeepSeq import Data.Function (on)-import Data.Semigroup+import Data.Semigroup ( Endo(..) ) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap@@ -41,11 +41,11 @@ import GHC.Generics (Generic) -import qualified Agda.Syntax.Common as Common+import Agda.Syntax.Common qualified as Common import Agda.Syntax.TopLevelModuleName-import Agda.Syntax.Scope.Base ( KindOfName(..) )+import Agda.Syntax.Abstract.Name ( KindOfName(..) ) -import Agda.Interaction.Highlighting.Range+import Agda.Utils.Range import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe@@ -311,13 +311,3 @@ instance Monoid PositionMap where mempty = PositionMap { positionMap = IntMap.empty } mappend = (<>)----------------------------------------------------------------------------- NFData instances--instance NFData Aspect-instance NFData OtherAspect-instance NFData DefinitionSite--instance NFData Aspects where- rnf (Aspects a b c d _) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
src/full/Agda/Interaction/Highlighting/Range.hs view
@@ -1,99 +1,24 @@+{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-} --- | Ranges.+-- | Converting generic ranges to Agda's ranges. module Agda.Interaction.Highlighting.Range- ( Range(..)- , rangeInvariant- , Ranges(..)- , rangesInvariant- , overlapping- , overlappings- , empty- , rangeToPositions- , rangesToPositions+ ( module Agda.Utils.Range , rToR , rangeToRange- , minus ) where -import Prelude hiding (null)--import Control.DeepSeq--import qualified Agda.Syntax.Position as P--import Agda.Utils.List-import Agda.Utils.Maybe-import Agda.Utils.Null---- | Character ranges. The first character in the file has position 1.--- Note that the 'to' position is considered to be outside of the--- range.------ Invariant: @'from' '<=' 'to'@.--data Range = Range { from, to :: !Int }- deriving (Eq, Ord, Show)--instance Null Range where- empty = Range 0 0- null r = to r <= from r--instance NFData Range where- rnf (Range _ _) = ()---- | The 'Range' invariant.--rangeInvariant :: Range -> Bool-rangeInvariant r = from r <= to r---- | Zero or more consecutive and separated ranges.--newtype Ranges = Ranges [Range]- deriving (Eq, Show, NFData)---- | The 'Ranges' invariant.--rangesInvariant :: Ranges -> Bool-rangesInvariant (Ranges rs) = allConsecutive (\ r s -> to r < from s) rs----------------------------------------------------------------------------- Queries---- | 'True' iff the ranges overlap.------ The ranges are assumed to be well-formed.--overlapping :: Range -> Range -> Bool-overlapping r1 r2 = not (r1 `isLeftOf` r2) && not (r2 `isLeftOf` r1)--isLeftOf :: Range -> Range -> Bool-isLeftOf r1 r2 = to r1 <= from r2--overlappings :: Ranges -> Ranges -> Bool--- specification: overlappings (Ranges r1s) (Ranges r2s) = or [ overlapping r1 r2 | r1 <- r1s, r2 <- r2s ]-overlappings (Ranges r1s) (Ranges r2s) =- isNothing $ mergeStrictlyOrderedBy isLeftOf r1s r2s----------------------------------------------------------------------------- Conversion---- | Converts a range to a list of positions.--rangeToPositions :: Range -> [Int]-rangeToPositions r = [from r .. to r - 1]---- | Converts several ranges to a list of positions.--rangesToPositions :: Ranges -> [Int]-rangesToPositions (Ranges rs) = concatMap rangeToPositions rs+import Agda.Syntax.Position qualified as P+import Agda.Utils.Range -- | Converts a 'P.Range' to a 'Ranges'. rToR :: P.Range -> Ranges rToR r = Ranges (map iToR (P.rangeIntervals r)) where- iToR (P.Interval () P.Pn{ P.posPos = pos1 } P.Pn{ P.posPos = pos2 }) =+ iToR (P.Interval () P.Pn'{ P.posPos = pos1 } P.Pn'{ P.posPos = pos2 }) = Range { from = fromIntegral pos1, to = fromIntegral pos2 } -- | Converts a 'P.Range', seen as a continuous range, to a 'Range'.@@ -106,26 +31,3 @@ { from = fromIntegral $ P.posPos s , to = fromIntegral $ P.posPos e }----------------------------------------------------------------------------- Operations---- | @minus xs ys@ computes the difference between @xs@ and @ys@: the--- result contains those positions which are present in @xs@ but not--- in @ys@.------ Linear in the lengths of the input ranges.--minus :: Ranges -> Ranges -> Ranges-minus (Ranges rs1) (Ranges rs2) = Ranges (m rs1 rs2)- where- m [] _ = []- m xs [] = xs- m (x:xs) (y:ys)- | null y = m (x:xs) ys- | to x < from y = x : m xs (y:ys)- | to y < from x = m (x:xs) ys- | from x < from y = Range { from = from x, to = from y } :- m (Range { from = from y, to = to x } : xs) (y:ys)- | to y < to x = m (Range { from = to y, to = to x } : xs) ys- | otherwise = m xs (y:ys)
src/full/Agda/Interaction/Highlighting/Vim.hs view
@@ -11,17 +11,17 @@ import System.FilePath -import Agda.Syntax.Scope.Base+import Agda.Syntax.Abstract.Name (AbstractName(..), KindOfName (FldName)) import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty import Agda.Syntax.Concrete.Name as CName+import Agda.Syntax.Scope.Base import Agda.TypeChecking.Monad -import Agda.Utils.List1 ( List1, pattern (:|) )-import qualified Agda.Utils.List1 as List1-import qualified Agda.Utils.IO.UTF8 as UTF8-import Agda.Utils.Tuple-import Agda.Syntax.Common.Pretty+import Agda.Utils.IO.UTF8 qualified as UTF8+import Agda.Utils.List1 ( List1, pattern (:|) )+import Agda.Utils.List1 qualified as List1 vimFile :: FilePath -> FilePath vimFile file =@@ -66,7 +66,7 @@ . List.sortBy (compare `on` f) foo :: String -> [List1 String] -> [(Int, String)]- foo cat = map (length . List1.head /\ match cat)+ foo cat = map (length . List1.head &&& match cat) toVim :: NamesInScope -> String toVim ns = unlines $ matches mcons micons mdefs midefs mflds miflds
src/full/Agda/Interaction/Imports.hs view
@@ -15,7 +15,7 @@ , crSource , Source(..)- , scopeCheckImport+ , scopeCheckFileImport , parseSource , typeCheckMain , getNonMainInterface@@ -24,76 +24,96 @@ , importPrimitiveModules , raiseNonFatalErrors + , MainInterface(..)+ , TCWorkers+ , wantsParallelChecking+ , chaseModule+ , setOptionsFromSourcePragmas+ -- Currently only used by test/api/Issue1168.hs: , readInterface ) where import Prelude hiding (null) +import Control.Exception qualified as E import Control.Monad.Except ( MonadError(..), ExceptT, runExceptT, withExceptT ) import Control.Monad.IO.Class ( MonadIO(..) ) import Control.Monad.State ( MonadState(..), execStateT ) import Control.Monad.Trans.Maybe-import qualified Control.Exception as E+import Control.Concurrent+import Control.DeepSeq import Data.Either+import Data.Monoid import Data.List (intercalate)-import qualified Data.List as List+import Data.List qualified as List import Data.Maybe import Data.Map (Map)-import qualified Data.Map as Map-import qualified Data.HashMap.Strict as HMap+import Data.Map qualified as Map+import Data.HashMap.Strict qualified as HMap+import Data.ByteString qualified as B import Data.Set (Set)-import qualified Data.Set as Set+import Data.Set qualified as Set import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL +import GHC.Conc+ import System.Directory (doesFileExist, removeFile) import System.FilePath ( (</>) )+import System.IO+import System.IO.Error (isUserError, isFullError) import Agda.Benchmarking -import qualified Agda.Syntax.Abstract as A-import qualified Agda.Syntax.Concrete as C+import Agda.Syntax.Concrete.Definitions qualified as C+import Agda.Syntax.Abstract qualified as A+import Agda.Syntax.Concrete qualified as C import Agda.Syntax.Concrete.Attribute+import Agda.Syntax.Concrete.Generic import Agda.Syntax.Abstract.Name import Agda.Syntax.Common import Agda.Syntax.Common.Pretty hiding (Mode)+import Agda.Syntax.Common.Pretty qualified as Pretty import Agda.Syntax.Parser import Agda.Syntax.Position import Agda.Syntax.Scope.Base+import Agda.Syntax.Scope.UnusedImports (warnUnusedImports) import Agda.Syntax.TopLevelModuleName import Agda.Syntax.Translation.ConcreteToAbstract ( TopLevel( TopLevel ) , TopLevelInfo( TopLevelInfo, topLevelDecls, topLevelScope) , checkAttributes, concreteToAbstract_ )-import qualified Agda.Syntax.Translation.ConcreteToAbstract as CToA+import Agda.Syntax.Translation.ConcreteToAbstract qualified as CToA import Agda.TypeChecking.InstanceArguments import Agda.TypeChecking.Errors import Agda.TypeChecking.Warnings hiding (warnings) import Agda.TypeChecking.Reduce import Agda.TypeChecking.Rewriting.Confluence ( checkConfluenceOfRules, sortRulesOfSymbol )+import Agda.TypeChecking.Rewriting.NonLinPattern (getMatchables) import Agda.TypeChecking.MetaVars ( openMetasToPostulates )+import Agda.TypeChecking.Monad.State as S import Agda.TypeChecking.Monad-import Agda.TypeChecking.Serialise+import Agda.TypeChecking.Serialise (decode, encodeFile, decodeInterface, deserializeHashes) import Agda.TypeChecking.Primitive import Agda.TypeChecking.Pretty as P import Agda.TypeChecking.DeadCode-import qualified Agda.TypeChecking.Monad.Benchmark as Bench+import Agda.TypeChecking.Monad.Benchmark qualified as Bench import Agda.TheTypeChecker -import Agda.Interaction.BasicOps ( getGoals, showGoals )+import Agda.Interaction.BasicOps ( getGoals, prettyGoals ) import Agda.Interaction.FindFile import Agda.Interaction.Highlighting.Generate-import qualified Agda.Interaction.Highlighting.Precise as Highlighting ( convert )+import Agda.Interaction.Highlighting.Precise qualified as Highlighting ( convert ) import Agda.Interaction.Highlighting.Vim import Agda.Interaction.Library import Agda.Interaction.Options-import qualified Agda.Interaction.Options.Lenses as Lens+import Agda.Interaction.Options.Lenses qualified as Lens import Agda.Interaction.Options.Warnings (unsolvedWarnings) import Agda.Interaction.Response (RemoveTokenBasedHighlighting(KeepHighlighting))@@ -105,16 +125,19 @@ import Agda.Utils.Lens import Agda.Utils.List ( nubOn ) import Agda.Utils.Maybe-import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.Maybe.Strict qualified as Strict import Agda.Utils.Monad import Agda.Utils.Null-import qualified Agda.Utils.ProfileOptions as Profile+import Agda.Interaction.Options.ProfileOptions qualified as Profile import Agda.Utils.Singleton-import qualified Agda.Utils.Set1 as Set1-import qualified Agda.Utils.Trie as Trie-+import Agda.Utils.Set1 qualified as Set1+import Agda.Utils.Trie qualified as Trie import Agda.Utils.Impossible+import Agda.Utils.IORef.Strict+import Agda.Utils.Tuple.Strict (Pair(..))+import Agda.Utils.Tuple.Strict qualified as Strict + -- | Whether to ignore interfaces (@.agdai@) other than built-in modules ignoreInterfaces :: HasOptions m => m Bool@@ -125,6 +148,11 @@ ignoreAllInterfaces :: HasOptions m => m Bool ignoreAllInterfaces = optIgnoreAllInterfaces <$> commandLineOptions +-- | Whether to write interface files (@.agdai@)++writeInterfaces :: HasOptions m => m Bool+writeInterfaces = optWriteInterfaces <$> commandLineOptions+ -- | The decorated source code. data Source = Source@@ -165,13 +193,18 @@ source <- runPM $ readFilePM rf0 let txt = TL.unpack source + -- Get the literate markdown option.+ mdOnlyAgdaBlocks <- optMdOnlyAgdaBlocks <$> commandLineOptions+ -- Bootstrapping: parse the module name. parsedModName0 <- moduleName f . fst . fst =<< do- runPMDropWarnings $ parseFile moduleParser rf0 txt+ runPMDropWarnings $ parseFile mdOnlyAgdaBlocks moduleParser rf0 txt -- Now parse again, with module name present to be filled into the ranges. let rf = mkRangeFile f $ Just parsedModName0- ((parsedMod, attrs), fileType) <- runPM $ parseFile moduleParser rf txt+ setCurrentRange (beginningOfFile rf) do++ ((parsedMod, attrs), fileType) <- runPM $ parseFile mdOnlyAgdaBlocks moduleParser rf txt parsedModName <- moduleName f parsedMod libs <- getAgdaLibFiles f parsedModName@@ -301,6 +334,7 @@ check _ (BuiltinRewriteRelations xs) (BuiltinRewriteRelations ys) = return () check _ _ _ = __IMPOSSIBLE__ sequence_ $ Map.intersectionWithKey check bs bi+ addImportedThings sig (iMetaBindings i)@@ -312,9 +346,11 @@ warns (iOpaqueBlocks i) (iOpaqueNames i)+ reportSLn "import.iface.merge" 50 $ " Rebinding primitives " ++ show prim mapM_ rebind prim+ whenJustM (optConfluenceCheck <$> pragmaOptions) \ confChk -> do let rews = concat $ HMap.elems $ sig ^. sigRewriteRules verboseS "import.iface.confluence" 20 do@@ -322,17 +358,26 @@ else do reportSDoc "" 1 $ P.vcat $ map (P.nest 2) $ "Checking confluence of imported rewrite rules" :- map (("-" P.<+>) . prettyTCM . rewName) rews+ map (("-" P.<+>) . prettyTCM . grName) rews -- Andreas, 2025-06-28, PR #7934 and issue #7969: -- Global confluence checker requires rules to be sorted -- according to the generality of their lhs when (confChk == GlobalConfluenceCheck) $- forM_ (nubOn id $ map rewHead rews) sortRulesOfSymbol- checkConfluenceOfRules confChk rews+ forM_ (nubOn id $ map grHead rews) sortRulesOfSymbol++ -- #8273: We need to ensure the module we are importing is considered+ -- imported when checking confluence.+ --+ -- Ideally we would probably add the imports earlier, but this seems very+ -- fiddly to do correctly. Instead, we just locally add the imports+ -- for the duration of checking confluence and revert the state+ -- afterwards.+ locallyAddImport (iTopLevelModuleName i) $+ checkConfluenceOfRules confChk rews where rebind (x, q) = do- PrimImpl _ pf <- lookupPrimitiveFunction x+ (_, pf) <- lookupPossiblyTrustedPrimitiveFunction x stImportedBuiltins `modifyTCLens` Map.insert (someBuiltin x) (Prim pf{ primFunName = q }) addImportedThings@@ -349,29 +394,56 @@ -> TCM () addImportedThings isig metas ibuiltin patsyns display userwarn partialdefs warnings oblock oid = do- stImports `modifyTCLens` \ imp -> unionSignature imp isig+ stImports `modifyTCLens` \ imp -> importSignature imp isig stImportedMetaStore `modifyTCLens` HMap.union metas- stImportedBuiltins `modifyTCLens` \ imp -> Map.union imp ibuiltin+ stImportedBuiltins `modifyTCLens` \ imp -> Map.unionWith unionBuiltin imp ibuiltin stImportedUserWarnings `modifyTCLens` \ imp -> Map.union imp userwarn stImportedPartialDefs `modifyTCLens` \ imp -> Set.union imp partialdefs stPatternSynImports `modifyTCLens` \ imp -> Map.union imp patsyns- stImportedDisplayForms `modifyTCLens` \ imp -> HMap.unionWith (++) imp display+ stImportedDisplayForms `modifyTCLens` \ imp -> HMap.unionWith (<>) imp display stTCWarnings `modifyTCLens` \ imp -> Set.union imp warnings stOpaqueBlocks `modifyTCLens` \ imp -> imp `Map.union` oblock stOpaqueIds `modifyTCLens` \ imp -> imp `Map.union` oid +-- | Merges two signatures, assuming the second is being imported into the first+--+-- This is not commutative: `Map.union` is left-biased and we also assume that+-- updates from rewrite rules in the first signature do not need to be+-- re-applied (rewrite rules in the current signature cannot refer to+-- definitions that are not in the current signature)+importSignature ::+ Signature+ -- ^ Current signature+ -> Signature+ -- ^ Signature being imported+ -> Signature+ -- ^ Merged signature+importSignature (Sig a b c d) (Sig a' b' c' d') =+ Sig (Map.union a a')+ (fixupDefs $ HMap.union b b') -- definitions are unique (in at most one module) but need to be fixed to account for the new rewrite rules+ (HMap.unionWith mappend c c') -- rewrite rules are accumulated+ (d <> d') -- instances are accumulated+ where+ -- #8218: Rewrite rules can modify the signature (e.g. definitional+ -- injectivity of the head symbol). We need to replay these adjustments when+ -- importing because rewrite rules might be defined in a different module+ -- from the definitions they modify.+ fixupDefs ds = foldr (\(f, rews) -> updateDefsForRewrites f rews+ $ rews >>= getMatchables)+ ds (HMap.toList c')+ -- | Scope checks the given module, generating an interface or retrieving an existing one. -- Returns the module name and exported scope from the interface. ---scopeCheckImport ::+scopeCheckFileImport :: TopLevelModuleName -> TCM (ModuleName, Map ModuleName Scope)-scopeCheckImport top = do+scopeCheckFileImport top = do reportSLn "import.scope" 15 $ "Scope checking " ++ prettyShow top verboseS "import.scope" 30 $ do visited <- prettyShow <$> getPrettyVisitedModules reportSLn "import.scope" 30 $ " visited: " ++ visited- -- Since scopeCheckImport is called from the scope checker,+ -- Since scopeCheckFileImport is called from the scope checker, -- we need to reimburse her account. i <- Bench.billTo [] $ getNonMainInterface top Nothing addImport top@@ -397,77 +469,6 @@ let s = iScope i return (iModuleName i, s) --- | If the module has already been visited (without warnings), then--- its interface is returned directly. Otherwise the computation is--- used to find the interface and the computed interface is stored for--- potential later use.--alreadyVisited :: TopLevelModuleName ->- MainInterface ->- PragmaOptions ->- TCM ModuleInfo ->- TCM ModuleInfo-alreadyVisited x isMain currentOptions getModule =- case isMain of- MainInterface TypeCheck -> useExistingOrLoadAndRecordVisited ModuleTypeChecked- NotMainInterface -> useExistingOrLoadAndRecordVisited ModuleTypeChecked- MainInterface ScopeCheck -> useExistingOrLoadAndRecordVisited ModuleScopeChecked- where- useExistingOrLoadAndRecordVisited :: ModuleCheckMode -> TCM ModuleInfo- useExistingOrLoadAndRecordVisited mode = fromMaybeM loadAndRecordVisited (existingWithoutWarnings mode)-- -- Case: already visited.- --- -- A module with warnings should never be allowed to be- -- imported from another module.- existingWithoutWarnings :: ModuleCheckMode -> TCM (Maybe ModuleInfo)- existingWithoutWarnings mode = runMaybeT $ exceptToMaybeT $ do- mi <- maybeToExceptT "interface has not been visited in this context" $ MaybeT $- getVisitedModule x-- when (miMode mi < mode) $- throwError "previously-visited interface was not sufficiently checked"-- unless (null $ miWarnings mi) $- throwError "previously-visited interface had warnings"-- reportSLn "import.visit" 10 $ " Already visited " ++ prettyShow x-- lift $ processResultingModule mi-- processResultingModule :: ModuleInfo -> TCM ModuleInfo- processResultingModule mi = do- let ModuleInfo { miInterface = i, miPrimitive = isPrim, miWarnings = ws } = mi-- -- Check that imported options are compatible with current ones (issue #2487),- -- but give primitive modules a pass- -- compute updated warnings if needed- wt <- fromMaybe ws <$> getOptionsCompatibilityWarnings isMain isPrim currentOptions i-- return mi { miWarnings = wt }-- loadAndRecordVisited :: TCM ModuleInfo- loadAndRecordVisited = do- reportSLn "import.visit" 5 $ " Getting interface for " ++ prettyShow x- mi <- processResultingModule =<< getModule- reportSLn "import.visit" 5 $ " Now we've looked at " ++ prettyShow x-- -- Interfaces are not stored if we are only scope-checking, or- -- if any warnings were encountered.- case (isMain, null $ miWarnings mi) of- (MainInterface ScopeCheck, _) -> return ()- (_, False) -> return ()- _ -> storeDecodedModule mi-- reportS "warning.import" 10- [ "module: " ++ show (moduleNameParts x)- , "WarningOnImport: " ++ show (iImportWarning (miInterface mi))- ]-- visitModule mi- return mi-- -- | The result and associated parameters of a type-checked file, -- when invoked directly via interaction or a backend. -- Note that the constructor is not exported.@@ -489,6 +490,192 @@ , crSource' = crSource } +-- | Structure necessary for synchronising parallel type-checking workers.+data TCWorkers = Workers+ { workerThreads :: !(MVar (HMap.HashMap TopLevelModuleName (MVar (Maybe TCErr))))+ -- ^ Synchronized map containing synchronisation points for each+ -- worker to signal completion (or failure).+ , workerModules :: !(IORef DecodedModules)+ -- ^ The shared 'DecodedModules' where workers can put their results.+ , workerStarted :: !(IORef Int)+ -- ^ How many threads have actually started their work. Used for progress reporting.+ }++-- | If the user has asked for it, prepare the type checker for loading+-- in parallel, and return a 'TCWorkers' instance that can be used to+-- coordinate a number of type-checking tasks.+--+-- The given module name, when encountered, will be treated as the+-- 'MainInterface'.+wantsParallelChecking :: TCM (Maybe TCWorkers)+wantsParallelChecking = fmap optParallelChecking commandLineOptions >>= \case+ Sequential -> pure Nothing+ Parallel{} -> Just <$> do+ -- If we're doing parallel type-checking, we have to synchronise the+ -- interaction callback to make sure we don't end up with mangled logs+ -- (or, worse, mangled Lisp!).+ out <- liftIO $ newMVar ()+ cb <- getInteractionOutputCallback+ setInteractionOutputCallback \r -> bracket_ (liftIO (takeMVar out)) (liftIO . putMVar out) $+ cb r++ threads <- liftIO $ newMVar mempty+ results <- liftIO . newIORef =<< getDecodedModules+ started <- liftIO $ newIORef 0+ pure Workers+ { workerThreads = threads+ , workerModules = results+ , workerStarted = started+ }++-- | Gets the prefix string to use for reporting the progress message+-- (Checking, Loading, etc.) for the module this worker is responsible+-- for.+-- As a side-effect, updates the 'workerStarted' count.+thisWorkerPrefix :: TCWorkers -> TCM String+thisWorkerPrefix workers = do+ -- In general, we don't know ahead-of-time how many modules we will+ -- end up checking (e.g. with --build-library, this fluctuates), but+ -- the number of modules for which we have a result slot is a pretty+ -- good estimate.+ sz <- show . HMap.size <$> liftIO (readMVar (workerThreads workers))+ me <- liftIO $ atomicModifyIORef (workerStarted workers) \n -> (n + 1, show (n + 1))+ let+ pad = replicate (length sz - length me) ' '+ out = "(" <> pad <> me <> "/" <> sz <> ") "+ out `deepseq` pure out++-- | Type-check the given module, using a 'TCWorkers' instance to check+-- its imports in parallel.+--+-- Returns an action which *waits* for completion of type-checking of+-- the given module. Note that the given action updates the+-- 'DecodedModules' in the TC state where it is called to the current+-- results of parallel type-checking. The state after running this+-- action is guaranteed to contain a 'DecodedModule' for the given+-- 'TopLevelModuleName'.+--+-- If the given 'MainInterface' indicates that we are checking the main+-- module, its checking will happen in the calling thread, and in the+-- calling TC state. Otherwise, a thread (with isolated TC state) is+-- created to check it.+--+-- Regardless of whether we spawned a new thread or not, checking of the+-- given module will block until all of its imports have been checked.+chaseModule+ :: TCWorkers -- ^ For synchronization+ -> TopLevelModuleName -- ^ The name of the module to check+ -> MainInterface -- ^ Are we checking the main module?+ -> Maybe Source -- ^ Pre-parsed source+ -> TCM (TCM ModuleInfo)+chaseModule workers mod main msrc = do+ let+ -- This is the generic action for waiting on the result of checking+ -- a module. The MVar is used just for signaling.+ use var = liftIO (readMVar var) >>= \case+ Just exc -> throwError exc+ Nothing -> do+ setDecodedModules =<< liftIO (readIORef (workerModules workers))+ getDecodedModule mod >>= \case+ Just mi -> pure mi+ Nothing -> __IMPOSSIBLE_VERBOSE__ $+ "internal error: parallel loading had thread responsible for "+ <> show (Agda.Syntax.Common.Pretty.pretty mod)+ <> " marked as ready, but it has not been decoded"++ has = modifyMVar (workerThreads workers) \wmap -> case HMap.lookup mod wmap of+ Just var -> pure (wmap, Left var)+ Nothing -> do+ var <- newEmptyMVar+ let nmap = HMap.insert mod var wmap+ nmap `seq` pure (nmap, Right var)++ -- In the critical section that holds workerThreads, we just decide+ -- whether to spawn a new thread or not.+ -- If the module already had an entry (Left), we can immediately+ -- return the waiting thunk.+ liftIO has >>= \case+ Left var -> use var <$ reportSDoc "import.parallel" 15 ("reusing " <> P.pretty mod)++ -- Otherwise, we have to handle spawning the new thread to do+ -- type-checking.+ Right var -> use var <$ do+ stack <- viewTC eImportStack++ let+ -- If this is the call corresponding to checking the main+ -- module, we don't start a new thread.+ -- This is because we want to be in the state from checking the+ -- main module, e.g. for interactive checking.+ --+ -- If we *are* starting a new thread, we must install an+ -- exception handler to catch any TCErrs that make it to the top+ -- level, so that they can propagate back to the main thread+ -- eventually.+ detach cont+ | MainInterface _ <- main = cont+ | otherwise = do+ forkTCM $ flip catchError (liftIO . putMVar var . Just) $ do+ -- If we're starting a new thread, we also need to parse the source file.+ -- For debugging/profiling/etc., label the thread with the+ -- name of the module that we're checking.+ liftIO do+ let name = show (Agda.Syntax.Common.Pretty.pretty mod)+ me <- myThreadId+ labelThread me ("TC " <> name)+ cont++ detach do+ reportSDoc "import.parallel" 15 $ "checking " <> P.pretty mod+ src <- maybe (parseSource =<< findFile mod) pure msrc++ -- Now we traverse through all the imports and collect the+ -- "promises" for waiting on them. This will spawn the threads+ -- to check them.+ imports <- flip foldDecl (srcModule src) \case+ C.Import opn r x as is -> do+ let dec = C.NiceImport opn r x as is+ traceCall (ScopeCheckDeclaration dec) do++ tl <- S.topLevelModuleName (rawTopLevelModuleNameForQName x)++ -- This is a bit fiddly. 'getInterface' below will push mod+ -- onto the import stack, so if we push it around the entire+ -- thread, we get a spurious cyclic import error.+ --+ -- However, we can't also push tl, because *its* worker+ -- thread would end up pushing it, so *it* would be on the+ -- stack twice, too!+ --+ -- We have to check for import cycles here because GHC does+ -- not seem to always generate the proper "thread blocked+ -- indefinitely on MVar operation".+ act <- locallyTC eImportStack (mod:) do+ locallyTC eImportStack (tl:) checkForImportCycle+ chaseModule workers tl NotMainInterface Nothing++ pure $ Endo (act:)++ _ -> pure mempty++ -- Now we wait for all the dependencies and, when that's done,+ -- we can just type-check the module as usual.+ -- Waiting for the dependencies will have moved us to a TC state+ -- where they have been placed in the DecodedModules map, so the+ -- normal type-checking code will just reuse them when we get+ -- around to actually scope checking the import.+ sequence_ (appEndo imports [])++ prefix <- thisWorkerPrefix workers+ mi <- locallyTC eChasePrefix (const (Just prefix)) $+ getInterface mod main (Just src)++ -- After we're done, update the shared DecodedModules map and+ -- signal our completion.+ liftIO do+ atomicModifyIORef (workerModules workers) \v -> (Map.insert mod mi v, ())+ putMVar var Nothing+ -- | Type checks the main file of the interaction. -- This could be the file loaded in the interacting editor (emacs), -- or the file passed on the command line.@@ -522,12 +709,12 @@ -- Now do the type checking via getInterface. checkModuleName' (srcModuleName src) (srcOrigin src) - mi <- getInterface (srcModuleName src) (MainInterface mode) (Just src)+ mi <- wantsParallelChecking >>= \case+ Just workers -> join $ chaseModule workers (srcModuleName src) (MainInterface mode) (Just src)+ Nothing -> getInterface (srcModuleName src) (MainInterface mode) (Just src) stCurrentModule `setTCLens'`- Just ( iModuleName (miInterface mi)- , iTopLevelModuleName (miInterface mi)- )+ Strict.Just (iModuleName (miInterface mi) :!: iTopLevelModuleName (miInterface mi)) return $ CheckResult' mi src @@ -542,24 +729,25 @@ importPrimitiveModules :: TCM () importPrimitiveModules = whenM (optLoadPrimitives <$> pragmaOptions) $ do reportSLn "import.main" 10 "Importing the primitive modules."- libdirPrim <- useTC stPrimitiveLibDir+ libdirPrim <- useSession lensPrimitiveLibDir 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+ -- set root verbosity to 0 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_ (map (filePath libdirPrim </>) $ Set.toList primitiveModules) \ f -> do- sf <- srcFromPath (mkAbsolute f)- primSource <- parseSource sf- checkModuleName' (srcModuleName primSource) (srcOrigin primSource)- void $ getNonMainInterface (srcModuleName primSource) (Just primSource)+ withHighlightingLevel None $ do+ locallyTC eImplPrimitiveImporting (\_ -> True) $ do+ forM_ (map (filePath libdirPrim </>) $ Set.toList primitiveModules) \ f -> do+ sf <- srcFromPath (mkAbsolute f)+ primSource <- parseSource sf+ checkModuleName' (srcModuleName primSource) (srcOrigin primSource)+ void $ getNonMainInterface (srcModuleName primSource) (Just primSource) reportSLn "import.main" 10 $ "Done importing the primitive modules." @@ -578,7 +766,7 @@ -> TCM Interface getNonMainInterface x msrc = do mi <- getNonMainModuleInfo x msrc- tcWarningsToError $ Set.toAscList $ miWarnings mi+ tcWarningsToError (TopLevelModuleNameWithSourceFile x $ miSourceFile mi) $ Set.toAscList $ miWarnings mi return (miInterface mi) getNonMainModuleInfo@@ -592,9 +780,14 @@ bracket_ (useTC stPragmaOptions) (stPragmaOptions `setTCLens`) $ getInterface x NotMainInterface msrc --- | A more precise variant of 'getNonMainInterface'. If warnings are--- encountered then they are returned instead of being turned into--- errors.+-- | If the module has already been visited (without warnings), then+-- its interface is returned directly.+--+-- Otherwise the interface is loaded via 'getStoredInterface'.+--+-- If that fails it is created via 'createInterface' or, for non-main modules,+-- 'createInterfaceIsolated'.+-- A such created interface is stored for potential later use. getInterface :: TopLevelModuleName@@ -602,16 +795,34 @@ -> Maybe Source -- ^ Optional: the source code and some information about the source code. -> TCM ModuleInfo-getInterface x isMain msrc =- addImportCycleCheck x $ do- -- We remember but reset the pragma options locally- -- Issue #3644 (Abel 2020-05-08): Set approximate range for errors in options- currentOptions <- useTC stPragmaOptions- setCurrentRange (C.modPragmas . srcModule <$> msrc) $- -- Now reset the options- setCommandLineOptions . stPersistentOptions . stPersistentState =<< getTC+getInterface x isMain msrc = locallyTC eImportStack (x :) do - alreadyVisited x isMain currentOptions $ do+ -- We remember but reset the pragma options locally.+ currentOptions <- useTC stPragmaOptions+ -- Issue #3644 (Abel 2020-05-08): Set approximate range for errors in options.+ setCurrentRange (C.modPragmas . srcModule <$> msrc) $ do+ -- Now reset the options+ setCommandLineOptions =<< getsTC (stPersistentOptions . stPersistentState)++ -- Lookup x in the collection of visited modules.+ getVisitedModule x >>= \case++ -- Case: already visited and usable.+ Just mi+ -- We can only reuse a sufficiently checked module,+ -- e.g. we cannot import a just scope-checked module when type-checking a module.+ | miMode mi >= moduleCheckMode isMain+ -- A module with warnings should never be allowed to be imported from another module.+ , null $ miWarnings mi -> do+ reportSLn "import.visit" 10 $ " Already visited " ++ prettyShow x+ addOptionsCompatibilityWarnings currentOptions mi++ -- Case: not already visited or unusable.+ _ -> do++ -- Load the module.+ reportSLn "import.visit" 5 $ " Getting interface for " ++ prettyShow x+ file <- case msrc of Nothing -> findFile x Just src -> do@@ -624,8 +835,9 @@ -- To prevent this, we register the connection in @ModuleToSource@ here, -- where we have the correct spelling of the file name. let file = srcOrigin src- modifyTCLens stModuleToSourceId $ Map.insert x file+ modifySession lensModuleToSourceId $ Map.insert x file pure file+ reportSDoc "import.iface" 15 do path <- srcFilePath file P.text $ List.intercalate "\n" $ map (" " ++)@@ -636,32 +848,57 @@ reportSLn "import.iface" 15 $ " Check for cycle" checkForImportCycle - -- -- Andreas, 2014-10-20 AIM XX:- -- -- Always retype-check the main file to get the iInsideScope- -- -- which is no longer serialized.- -- let maySkip = isMain == NotMainInterface- -- Andreas, 2015-07-13: Serialize iInsideScope again.- -- Andreas, 2020-05-13 issue #4647: don't skip if reload because of top-level command- stored <- runExceptT $ Bench.billTo [Bench.Import] $ do- getStoredInterface x file msrc+ mi <- Bench.billTo [Bench.Import] (getStoredInterface x file msrc)+ `catchExceptT` \ reason -> do - let recheck = \reason -> do reportSLn "import.iface" 5 $ concat [" ", prettyShow x, " is not up-to-date because ", reason, "."] setCommandLineOptions . stPersistentOptions . stPersistentState =<< getTC- modl <- case isMain of- MainInterface _ -> createInterface x file isMain msrc+ mi <- case isMain of+ MainInterface{} -> createInterface x file isMain msrc NotMainInterface -> createInterfaceIsolated x file msrc -- Ensure that the given module name matches the one in the file.- let topLevelName = iTopLevelModuleName (miInterface modl)+ let topLevelName = iTopLevelModuleName (miInterface mi) unless (topLevelName == x) do path <- srcFilePath file typeError $ OverlappingProjects path topLevelName x - return modl+ pure mi - either recheck pure stored+ mi <- addOptionsCompatibilityWarnings currentOptions mi+ reportSLn "import.visit" 5 $ " Now we've looked at " ++ prettyShow x + -- Interfaces are not stored if we are only scope-checking, or+ -- if any warnings were encountered.+ when (moduleCheckMode isMain == ModuleTypeChecked && null (miWarnings mi)) do+ storeDecodedModule mi++ reportS "warning.import" 10+ [ "module: " ++ show (moduleNameParts x)+ , "WarningOnImport: " ++ show (iImportWarning (miInterface mi))+ ]++ -- Record the module as visited.+ visitModule mi+ return mi+ where+ addOptionsCompatibilityWarnings :: PragmaOptions -> ModuleInfo -> TCM ModuleInfo+ addOptionsCompatibilityWarnings currentOptions+ mi@ModuleInfo{ miInterface = i, miIsBuiltin = isBuiltin, miWarnings = ws } = do++ -- Andreas, 2026-02-03, issue #8361, debug printing by @nad.+ -- For testing whether 'isBuiltinModule' is thread-safe.+ reportSDoc "import.iface.builtin" 25 do+ P.hsep [ "The module", prettyTCM (iTopLevelModuleName i), "is"+ , if maybe False isPrimitiveModule isBuiltin then "primitive." else "not primitive."+ ]++ -- Check that imported options are compatible with current ones (issue #2487),+ -- but give primitive modules a pass.+ -- Compute updated warnings if needed.+ ws' <- fromMaybe ws <$> getOptionsCompatibilityWarnings isMain currentOptions mi+ return mi{ miWarnings = ws' }+ -- | If checking produced non-benign warnings, error out. -- raiseNonFatalErrors :: (HasOptions m, MonadTCError m)@@ -681,12 +918,16 @@ reportSDoc "import.iface.options" 25 $ P.nest 2 $ "imported options =" P.<+> showOptions imported forM_ infectiveCoinfectiveOptions $ \opt -> do unless (icOptionOK opt current imported) $ do+ reportSDoc "import.iface.options" 25 $ P.nest 2 $+ "incompatible: " <> P.text (icOptionDescription opt)+ <> ", current: " <> P.pretty (icOptionActive opt current)+ <> ", imported: " <> P.pretty (icOptionActive opt imported) put False warning $ (case icOptionKind opt of Infective -> InfectiveImport Coinfective -> CoInfectiveImport)- (icOptionWarning opt importedModule)+ (icOptionWarning opt current imported importedModule) where showOptions opts = P.prettyList $@@ -697,17 +938,43 @@ -- | Compare options and return collected warnings. -- | Returns `Nothing` if warning collection was skipped. -getOptionsCompatibilityWarnings :: MainInterface -> Bool -> PragmaOptions -> Interface -> TCM (Maybe (Set TCWarning))-getOptionsCompatibilityWarnings isMain isPrim currentOptions i = runMaybeT $ exceptToMaybeT $ do- -- We're just dropping these reasons-for-skipping messages for now.- -- 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)- (iTopLevelModuleName i)) $- throwError "No warnings to collect because options were compatible"- lift $ getAllWarnings' isMain ErrorWarnings+getOptionsCompatibilityWarnings ::+ MainInterface+ -> PragmaOptions+ -> ModuleInfo+ -> TCM (Maybe (Set TCWarning))+getOptionsCompatibilityWarnings isMain currentOptions info = + -- are we importing a primitive module implicitly?+ viewTC eImplPrimitiveImporting >>= \case+ True -> pure Nothing+ False -> case info of+ ModuleInfo{ miIsBuiltin = isBuiltin+ , miInterface = Interface{ iOptionsUsed, iTopLevelModuleName = m }+ , miSourceFile } -> do++ -- Add range to name of imported module.+ m' <- if not $ null $ getRange m then pure m else do+ path <- srcFilePath miSourceFile+ pure $ setRange (rangeFromAbsolutePath path) m++ case isBuiltin of+ Just IsAgdaPrimitive ->+ pure Nothing+ Just IsAgdaPrimitiveCubical ->+ case _optCubical currentOptions of+ Nothing -> do+ warning $ CoInfectiveImport $+ Pretty.fsep $+ Pretty.pwords "Module imports the cubical primitive module" +++ Pretty.pwords "but does not enable a --cubical[={full,erased,no-glue}] option."+ Just <$> getAllWarnings' isMain ErrorWarnings+ Just _ -> pure Nothing+ _ ->+ ifM (checkOptionsCompatible currentOptions iOptionsUsed m')+ {-then-} (pure Nothing) -- No warnings to collect because options were compatible.+ {-else-} (Just <$> getAllWarnings' isMain ErrorWarnings)+ -- | Try to get the interface from interface file or cache. getStoredInterface :: HasCallStack@@ -718,6 +985,7 @@ -> Maybe Source -> ExceptT String TCM ModuleInfo getStoredInterface x file@(SourceFile fi) msrc = do+ -- Check whether interface file exists and is in cache -- in the correct version (as testified by the interface file hash). --@@ -768,7 +1036,7 @@ (ifile, hashes) <- getIFileHashesET - let ifp = (filePath . intFilePath $ ifile)+ let ifp = filePath $ intFilePath $ ifile Bench.billTo [Bench.Deserialization] $ do checkSourceHashET (fst hashes)@@ -784,7 +1052,7 @@ path <- srcFilePath file lift $ typeError $ OverlappingProjects path topLevelName x - isPrimitiveMod <- isPrimitiveModule fi+ isBuiltinMod <- isBuiltinModule fi lift $ chaseMsg "Loading " x $ Just ifp -- print imported warnings@@ -793,8 +1061,9 @@ loadDecodedModule file $ ModuleInfo { miInterface = i , miWarnings = empty- , miPrimitive = isPrimitiveMod+ , miIsBuiltin = isBuiltinMod , miMode = ModuleTypeChecked+ , miSourceFile = file } -- Check if we have cached the module.@@ -835,7 +1104,14 @@ reportWarningsForModule :: MonadDebug m => TopLevelModuleName -> Set TCWarning -> m () reportWarningsForModule x warns = do unlessNull (filter ((Strict.Just (Just x) ==) . fmap rangeFileName . tcWarningOrigin) $ Set.toAscList warns) \ ws ->- alwaysReportSDoc "warning" 1 $ P.vsep $ map P.prettyTCM ws+ alwaysReportSDoc "warning" 1 $+ -- Andreas, 2025-08-01, PR #8040+ -- Make sure that imported warnings coming from different modules are separated by an empty line.+ -- E.g. test/Succeed/ImportWarnings+ -- Technique from PR #7473:+ P.vcat $ concatMap (\ w -> [ "", P.prettyTCM w ]) ws+ -- Technique from PR #7362:+ -- P.vsep $ map P.prettyTCM ws -- | Check whether the loaded module is up-to-date -- and merge into state if this is the case.@@ -890,6 +1166,7 @@ unlessNull badHashMessages (throwError . unlines) reportSLn "import.iface" 5 $ prettyShow name ++ ": interface is valid and can be merged into the state."+ lift $ mergeInterface i Bench.billTo [Bench.Highlighting] $ lift $ ifTopLevelAndHighlightingLevelIs NonInteractive $@@ -904,8 +1181,8 @@ -- we do it in a fresh state, suitably initialize, -- in order to forget some state changes after successful type checking. -createInterfaceIsolated- :: TopLevelModuleName+createInterfaceIsolated ::+ TopLevelModuleName -- ^ Module name of file we process. -> SourceFile -- ^ File we process.@@ -914,11 +1191,10 @@ -> TCM ModuleInfo createInterfaceIsolated x file msrc = do cleanCachedLog-- ms <- getImportPath- range <- asksTC envRange- call <- asksTC envCall- mf <- useTC stModuleToSource+ ms <- viewTC eImportStack+ pref <- viewTC eChasePrefix+ range <- viewTC eRange+ call <- viewTC eCall vs <- getVisitedModules ds <- getDecodedModules opts <- stPersistentOptions . stPersistentState <$> getTC@@ -931,39 +1207,46 @@ opaqueblk <- useTC stOpaqueBlocks opaqueid <- useTC stOpaqueIds ipatsyns <- getPatternSynImports- ho <- getInteractionOutputCallback+ -- Andreas, 2026-10-24, issue #8875:+ -- Library warnings (e.g. LibraryVersionConflict) may explain an error+ -- in the imported module, so we add them to the state of the error.+ let isLibraryWarning = \case+ LibraryWarning{} -> True+ _ -> False+ libWarns <- Set.filter (isLibraryWarning . tcWarning) <$> useTC stTCWarnings+ let addLibWarns = \case+ err@TypeError{} | not (null libWarns) ->+ err{ tcErrState = over stTCWarnings (Set.union libWarns) $ tcErrState err }+ err -> err -- Every interface is treated in isolation. Note: Some changes to -- the persistent state may not be preserved if an error other -- than a type error or an IO exception is encountered in an -- imported module.- (mi, newModToSource, newDecodedModules) <- (either throwError pure =<<) $+ (mi, newDecodedModules) <- (either (throwError . addLibWarns) pure =<<) $ withoutCache $ -- The cache should not be used for an imported module, and it -- should be restored after the module has been type-checked freshTCM $- withImportPath ms $- localTC (\e -> e- -- Andreas, 2014-08-18:- -- Preserve the range of import statement- -- for reporting termination errors in- -- imported modules:- { envRange = range- , envCall = call- }) $ do+ localTC (+ -- Andreas, 2014-08-18:+ -- Preserve the range of import statement+ -- for reporting termination errors in+ -- imported modules:+ set eRange range+ . set eCall call+ . set eImportStack ms+ . set eChasePrefix pref+ ) do setDecodedModules ds setCommandLineOptions opts- setInteractionOutputCallback ho- stModuleToSource `setTCLens` mf setVisitedModules vs addImportedThings isig metas ibuiltin ipatsyns display userwarn partialdefs empty opaqueblk opaqueid r <- createInterface x file NotMainInterface msrc- mf' <- useTC stModuleToSource ds' <- getDecodedModules- return (r, mf', ds')+ return (r, ds') - stModuleToSource `setTCLens` newModToSource setDecodedModules newDecodedModules -- We skip the file which has just been type-checked to@@ -992,7 +1275,9 @@ -> Maybe String -- ^ Optionally: the file name. -> TCM () chaseMsg kind x file = do- indentation <- (`replicate` ' ') <$> asksTC (pred . length . envImportPath)+ indentation <- viewTC eChasePrefix >>= \case+ Just pref -> pure pref+ Nothing -> (`replicate` ' ') . pred . length <$> viewTC eImportStack traceImports <- optTraceImports <$> commandLineOptions let maybeFile = caseMaybe file "." $ \ f -> " (" ++ f ++ ")." vLvl | kind == "Checking"@@ -1024,31 +1309,18 @@ readInterface :: InterfaceFile -> TCM (Maybe Interface) readInterface file = do let ifp = filePath $ intFilePath file- -- Decode the interface file- (s, close) <- liftIO $ readBinaryFile' ifp- do mi <- liftIO . E.evaluate =<< decodeInterface s-- -- Close the file. Note- -- ⑴ that evaluate ensures that i is evaluated to WHNF (before- -- the next IO operation is executed), and- -- ⑵ that decode returns Nothing if an error is encountered,- -- so it is safe to close the file here.- liftIO close-- return $ constructIScope <$> mi- -- Catch exceptions and close- `catchError` \e -> liftIO close >> handler e- -- Catch exceptions- `catchError` handler- where- handler = \case+ bstr <- (liftIO $ Just <$!> B.readFile ifp) `catchError` \case IOException _ _ e -> do alwaysReportSLn "" 0 $ "IO exception: " ++ show e return Nothing -- Work-around for file locking bug. -- TODO: What does this refer to? Please -- document. e -> throwError e+ case bstr of+ Just bstr -> runMaybeT (constructIScope <$!> decodeInterface bstr)+ Nothing -> pure Nothing + -- | Writes the given interface to the given file. -- -- The written interface is decoded and returned.@@ -1072,14 +1344,18 @@ filteredIface <- pruneTemporaryInstances filteredIface reportSLn "import.iface.write" 50 $ "Writing interface file with hash " ++ show (iFullHash filteredIface) ++ "."- encodedIface <- encodeFile fp filteredIface+ iface <- encodeFile fp filteredIface reportSLn "import.iface.write" 5 "Wrote interface file."- fromMaybe __IMPOSSIBLE__ <$> (Bench.billTo [Bench.Deserialization] (decode encodedIface))+ pure iface `catchError` \e -> do alwaysReportSLn "" 1 $ "Failed to write interface " ++ fp ++ "."- liftIO $- whenM (doesFileExist fp) $ removeFile fp+ -- Andreas, 2025-09-12, issue #8098, don't delete when writing failed on a readonly file.+ -- Only delete file when disk is full or Agda had an internal error during serialization.+ case e of+ IOException _ _ ioe | not (isUserError ioe), not (isFullError ioe)+ -> return ()+ _ -> liftIO $ whenM (doesFileExist fp) $ removeFile fp throwError e -- | Tries to type check a module and write out its interface. The@@ -1089,30 +1365,27 @@ -- If appropriate this function writes out syntax highlighting -- information. -createInterface- :: TopLevelModuleName -- ^ The expected module name.+createInterface ::+ 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.+ -> Maybe Source -- ^ Optional information about the source code. -> TCM ModuleInfo createInterface mname sf@(SourceFile sfi) isMain msrc = do+ stFileId `setTCLens'` Strict.Just sfi file <- srcFilePath sf- let fp = filePath file- let checkMsg = case isMain of- MainInterface ScopeCheck -> "Reading "- _ -> "Checking"- withMsgs = bracket_- (chaseMsg checkMsg mname $ Just fp)- (const $ do ws <- getAllWarnings AllWarnings- let classified = classifyWarnings $ Set.toAscList ws- reportWarningsForModule mname $ tcWarnings classified- when (null (nonFatalErrors classified)) $ chaseMsg "Finished" mname Nothing)-- withMsgs $- Bench.billTo [Bench.TopModule mname] $- localTC (\ e -> e { envCurrentPath = Just sfi }) do+ let+ fp = filePath file+ onlyScope = ModuleScopeChecked == moduleCheckMode isMain+ checkMsg = if onlyScope then "Reading "+ else "Checking"+ withMsgs = bracket_ (chaseMsg checkMsg mname $ Just fp) $ const $ do+ ws <- getAllWarnings AllWarnings+ let classified = classifyWarnings $ Set.toAscList ws+ reportWarningsForModule mname $ tcWarnings classified+ when (null (nonFatalErrors classified)) $ chaseMsg "Finished" mname Nothing - let onlyScope = isMain == MainInterface ScopeCheck+ withMsgs $ Bench.billTo [Bench.TopModule mname] $ localTC (set eCurrentPath (Just sfi)) do reportSLn "import.iface.create" 5 $ "Creating interface for " ++ prettyShow mname ++ "..."@@ -1138,11 +1411,11 @@ setOptionsFromSourcePragmas checkConsistency src checkAttributes (srcAttributes src) syntactic <- optSyntacticEquality <$> pragmaOptions- localTC (\env -> env { envSyntacticEqualityFuel = syntactic }) $ do+ localTC (set eSyntacticEqualityFuel syntactic) $ do verboseS "import.iface.create" 15 $ do- nestingLevel <- asksTC (pred . length . envImportPath)- highlightingLevel <- asksTC envHighlightingLevel+ nestingLevel <- asksTC (pred . length . view eImportStack)+ highlightingLevel <- viewTC eHighlightingLevel reportSLn "import.iface.create" 15 $ unlines [ " nesting level: " ++ show nestingLevel , " highlighting level: " ++ show highlightingLevel@@ -1209,8 +1482,11 @@ -- Profiling: Count number of metas. whenProfile Profile.Metas $ do m <- fresh- tickN "metas" (fromIntegral (metaId m))+ tickN "metas" (metaId m) + -- Generate unused imports warning.+ warnUnusedImports+ -- Highlighting from type checker. reportSLn "import.iface.highlight" 15 $ prettyShow mname ++ ": Starting highlighting from type info." Bench.billTo [Bench.Highlighting] $ do@@ -1235,11 +1511,11 @@ whenM (optGenerateVimFile <$> commandLineOptions) $ -- Generate Vim file.- withScope_ scope $ generateVimFile $ filePath $ srcPath+ evalWithScope scope $ generateVimFile $ filePath $ srcPath reportSLn "import.iface.create" 15 $ prettyShow mname ++ ": Finished highlighting from type info." setScope scope- reportSLn "scope.top" 50 $ "SCOPE " ++ show scope+ reportSLn "scope.top" 90 $ "SCOPE " ++ show scope -- TODO: It would be nice if unsolved things were highlighted -- after every mutual block.@@ -1247,7 +1523,7 @@ openMetas <- getOpenMetas unless (null openMetas) $ do reportSLn "import.metas" 10 $ prettyShow mname ++ ": We have unsolved metas."- reportSLn "import.metas" 10 =<< showGoals =<< getGoals+ reportSDoc "import.metas" 10 $ prettyGoals =<< getGoals ifTopLevelAndHighlightingLevelIs NonInteractive printUnsolvedInfo @@ -1287,26 +1563,31 @@ mallWarnings <- getAllWarnings' isMain ErrorWarnings + isWritingInterfaces <- writeInterfaces+ reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": Considering writing to interface file."- finalIface <- constructIScope <$> case (null mallWarnings, isMain) of- (False, _) -> do+ finalIface <- constructIScope <$> case (null mallWarnings, isMain, isWritingInterfaces) of+ (False, _, _) -> do -- Andreas, 2018-11-15, re issue #3393 -- The following is not sufficient to fix #3393 -- since the replacement of metas by postulates did not happen. -- -- | not (allowUnsolved && all (isUnsolvedWarning . tcWarning) allWarnings) -> do reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": We have warnings, skipping writing interface file." return i- (True, MainInterface ScopeCheck) -> do+ (True, MainInterface ScopeCheck , _) -> do reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": We are just scope-checking, skipping writing interface file." return i- (True, _) -> Bench.billTo [Bench.Serialization] $ do+ (_, _, False) -> do+ reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": We are not writing any interfaces, skipping writing interface file."+ return i+ (True, _, _) -> Bench.billTo [Bench.Serialization] $ do reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": Actually calling writeInterface." -- The file was successfully type-checked (and no warnings were -- encountered), so the interface should be written out. ifile <- toIFile sf serializedIface <- writeInterface ifile i reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": Finished writing to interface file."- return serializedIface+ pure serializedIface -- -- Restore the open metas, as we might continue in interaction mode. -- Actually, we do not serialize the metas if checking the MainInterface@@ -1318,25 +1599,26 @@ -- Get the statistics of the current module -- and add it to the accumulated statistics. localStatistics <- getStatistics- lensAccumStatistics `modifyTCLens` Map.unionWith (+) localStatistics+ lensAccumStatistics `modifyTCLens'` (<>) localStatistics reportSLn "import.iface" 25 $ prettyShow mname ++ ": Added statistics to the accumulated statistics." - isPrimitiveMod <- isPrimitiveModule sfi+ isBuiltinMod <- isBuiltinModule sfi return ModuleInfo { miInterface = finalIface , miWarnings = mallWarnings- , miPrimitive = isPrimitiveMod+ , miIsBuiltin = isBuiltinMod , miMode = moduleCheckMode isMain+ , miSourceFile = sf } -- | Expert version of 'getAllWarnings'; if 'isMain' is a -- 'MainInterface', the warnings definitely include also unsolved -- warnings. -getAllWarnings' :: (ReadTCState m, MonadWarning m, MonadTCM m) => MainInterface -> WhichWarnings -> m (Set TCWarning)-getAllWarnings' (MainInterface _) = getAllWarningsPreserving unsolvedWarnings-getAllWarnings' NotMainInterface = getAllWarningsPreserving Set.empty+getAllWarnings' :: (MonadWarning m, MonadTCM m) => MainInterface -> WhichWarnings -> m (Set TCWarning)+getAllWarnings' MainInterface{} = getAllWarningsPreserving unsolvedWarnings+getAllWarnings' NotMainInterface = getAllWarningsPreserving Set.empty -- Andreas, issue 964: not checking null interactionPoints -- anymore; we want to serialize with open interaction points now!@@ -1400,7 +1682,7 @@ let !mh = moduleNameId (srcModuleName src) !opaqueBlocks = Map.filterWithKey (\(OpaqueId _ mod) _ -> mod == mh) opaqueBlocks'- isLocal qnm = case nameId (qnameName qnm) of+ isLocal qnm = case nameId qnm of NameId _ mh' -> mh' == mh !opaqueIds = Map.filterWithKey (\qnm (OpaqueId _ mod) -> isLocal qnm || mod == mh) opaqueIds' @@ -1452,10 +1734,10 @@ getInterfaceFileHashes :: InterfaceFile -> IO (Maybe (Hash, Hash)) getInterfaceFileHashes fp = do let ifile = filePath $ intFilePath fp- (s, close) <- readBinaryFile' ifile- let hs = decodeHashes s- maybe 0 (uncurry (+)) hs `seq` close- return hs+ h <- openBinaryFile ifile ReadMode+ bstr <- B.hGetSome h (2 * hashSize)+ hClose h+ deserializeHashes bstr moduleHash :: TopLevelModuleName -> TCM Hash moduleHash m = iFullHash <$> getNonMainInterface m Nothing
src/full/Agda/Interaction/Imports.hs-boot view
@@ -9,4 +9,4 @@ import Agda.Syntax.TopLevelModuleName ( TopLevelModuleName ) import Agda.TypeChecking.Monad.Base ( TCM ) -scopeCheckImport :: TopLevelModuleName -> TCM (ModuleName, Map ModuleName Scope)+scopeCheckFileImport :: TopLevelModuleName -> TCM (ModuleName, Map ModuleName Scope)
src/full/Agda/Interaction/InteractionTop.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE NondecreasingIndentation #-} {-# OPTIONS_GHC -fno-cse #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Agda.Interaction.InteractionTop ( module Agda.Interaction.InteractionTop@@ -21,12 +21,13 @@ import Control.Monad.STM import Control.Monad.State ( StateT ) -import qualified Data.Char as Char-import Data.Function (on)-import qualified Data.List as List-import qualified Data.Map as Map-import qualified Data.Set as Set+import Data.Char qualified as Char+import Data.Either ( partitionEithers )+import Data.Function ( on )+import Data.List qualified as List+import Data.Map qualified as Map import Data.Maybe+import Data.Set qualified as Set import System.Directory import System.FilePath@@ -42,6 +43,7 @@ import Agda.Syntax.Position import Agda.Syntax.Parser import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty hiding (Mode) import Agda.Syntax.Concrete as C import Agda.Syntax.Concrete.Glyph import Agda.Syntax.Abstract as A@@ -58,6 +60,7 @@ import Agda.Interaction.FindFile import Agda.Interaction.Options import Agda.Interaction.Options.Lenses as Lenses+import Agda.Interaction.Options.ProfileOptions qualified as Profile import Agda.Interaction.MakeCase import Agda.Interaction.SearchAbout import Agda.Interaction.Response hiding (Function, ExtendedLambda)@@ -73,7 +76,6 @@ import Agda.Compiler.Backend import Agda.Mimer.Mimer as Mimer-import qualified Control.DeepSeq as DeepSeq import Agda.Utils.Either import Agda.Utils.FileName@@ -81,11 +83,11 @@ import Agda.Utils.Hash import Agda.Utils.IO (showIOException) import Agda.Utils.Lens-import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.List (sortOnM)+import Agda.Utils.Maybe.Strict qualified as Strict+import Agda.Utils.Maybe (whenJust) import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Syntax.Common.Pretty hiding (Mode)-import qualified Agda.Utils.ProfileOptions as Profile import Agda.Utils.Singleton import Agda.Utils.String import Agda.Utils.Time@@ -221,12 +223,23 @@ unsolved <- lift $ computeUnsolvedInfo err <- lift $ errorHighlighting e- modFile <- lift $ useTC stModuleToSource+ modFile <- lift $ useSession lensModuleToSource+ -- `theCurrentFile` may have been reset by `onFail`; use the IOTCM+ -- path to distinguish another file from the current buffer.+ currentPath <- gets theCurrentFilePath+ let errorFile = case rangeFile (getRange e) of+ Strict.Just rf+ | Just (rangeFilePath rf) /= currentPath ->+ Just $ filePath $ rangeFilePath rf+ | otherwise -> Nothing+ Strict.Nothing -> Nothing method <- case method of Nothing -> lift $ viewTC eHighlightingMethod Just m -> return m- let info = convert $ err <> unsolved- -- Errors take precedence over unsolved things.+ let errorInfo = convert err+ unsolvedInfo = convert unsolved+ info = errorInfo <> unsolvedInfo+ -- Errors take precedence over unsolved things. showImpl <- lift $ optShowImplicit <$> useTC stPragmaOptions showIrr <- lift $ optShowIrrelevant <$> useTC stPragmaOptions@@ -234,8 +247,15 @@ mapM_ putResponse $ [ Resp_DisplayInfo $ Info_Error $ Info_GenericError e ] ++ tellEmacsToJumpToError (getRange e) ++- [ Resp_HighlightingInfo info KeepHighlighting- method modFile ] +++ (case errorFile of+ Just file ->+ [ Resp_HighlightingInfo errorInfo KeepHighlighting+ method modFile (Just file)+ , Resp_HighlightingInfo unsolvedInfo KeepHighlighting+ method modFile Nothing+ ]+ Nothing ->+ [ Resp_HighlightingInfo info KeepHighlighting method modFile Nothing ]) ++ [ Resp_Status $ Status { sChecked = False , sShowImplicitArguments = showImpl , sShowIrrelevantArguments = showIrr@@ -250,9 +270,10 @@ -- loaded interfaces for example). runInteraction :: IOTCM -> CommandM ()-runInteraction iotcm =+runInteraction iotcm = do+ currentAbs <- liftIO $ absolute current+ modify $ \s -> s { theCurrentFilePath = Just currentAbs } handleCommand inEmacs onFail $ do- currentAbs <- liftIO $ absolute current cf <- gets theCurrentFile cmd <- if independent cmd then return cmd else do when (Just currentAbs /= (currentFilePath <$> cf)) $ do@@ -276,10 +297,8 @@ IOTCM current highlighting highlightingMethod cmd = iotcm Nothing inEmacs :: forall a. CommandM a -> CommandM a- inEmacs = liftCommandMT $ withEnv $ initEnv- { envHighlightingLevel = highlighting- , envHighlightingMethod = highlightingMethod- }+ inEmacs = liftCommandMT $ withEnv $ initEnv & eHighlightingLevel .~ highlighting+ & eHighlightingMethod .~ highlightingMethod -- If an independent command fails we should reset theCurrentFile (Issue853). onFail | independent cmd = modify $ \ s -> s { theCurrentFile = Nothing }@@ -402,7 +421,7 @@ _ <- forkIO (readCommands 0) - return (CommandQueue { .. })+ return (CommandQueue { commands, abort }) --------------------------------------------------------- @@ -465,8 +484,6 @@ updateInteractionPointsAfter Cmd_abort{} = False updateInteractionPointsAfter Cmd_exit{} = False --- | Interpret an interaction- getBackendName :: CompilerBackend -> BackendName getBackendName = \case LaTeX -> "LaTeX"@@ -474,14 +491,29 @@ OtherBackend "GHCNoMain" -> "GHC" OtherBackend b -> b +-- | Interpret an interaction.+--+-- For each goal command specific to an 'InteractionPoint'+-- that comes with a 'Range' for this interaction point+-- we first synchronize this 'Range' with the 'Range'+-- Agda has stored for the interaction meta.+-- In general, we consider the 'Range' sent with the command+-- as more up-to-date than the the 'Range' Agda has stored.+-- This is because the editor keeps track of changes+-- (that usually modify the position of interaction points),+-- but Agda does not.+--+-- Some goal commands carry a 'Range' for reasons of uniformity but do not use it.+-- For those, we do not synchronize the range.+ interpret :: Interaction -> CommandM () -interpret (Cmd_load m argv) =+interpret (Cmd_load m argv) = do cmd_load' m argv True mode $ \_ -> interpret $ Cmd_metas AsIs where mode = TypeCheck -interpret (Cmd_compile backend file argv) =+interpret (Cmd_compile backend file argv) = do cmd_load' file argv allowUnsolved mode $ \ checkResult -> do ws <- lift $ applyFlagsToTCWarnings $ crWarnings checkResult case null ws of@@ -496,14 +528,15 @@ isMain | OtherBackend "GHCNoMain" <- backend = NotMain | otherwise = IsMain -interpret (Cmd_backend_top backend cmd) =+interpret (Cmd_backend_top backend cmd) = do callBackendInteractTop (getBackendName backend) cmd -interpret (Cmd_backend_hole ii rng s backend cmd) =+interpret (Cmd_backend_hole ii rng s backend cmd) = do+ rng <- syncInteractionRange ii rng callBackendInteractHole (getBackendName backend) cmd ii rng s -interpret Cmd_constraints =- display_info . Info_Constraints =<< lift B.getConstraints+interpret (Cmd_constraints norm) = do+ display_info . Info_Constraints =<< lift (B.getConstraints norm) interpret (Cmd_metas norm) = do ms <- lift $ B.getGoals' norm (max Simplified norm)@@ -516,10 +549,10 @@ Imp.raiseNonFatalErrors result unlessM (null <$> getOpenMetas) __IMPOSSIBLE__ -interpret (Cmd_show_module_contents_toplevel norm s) =+interpret (Cmd_show_module_contents_toplevel norm s) = do atTopLevel $ showModuleContents norm noRange s -interpret (Cmd_search_about_toplevel norm s) =+interpret (Cmd_search_about_toplevel norm s) = do atTopLevel $ searchAbout norm noRange s interpret (Cmd_solveAll norm) = solveInstantiatedGoals norm Nothing@@ -538,22 +571,6 @@ state <- get display_info $ Info_InferredType state time expr -interpret (Cmd_compute_toplevel cmode s) = do- (time, expr) <- parseAndDoAtToplevel action (B.computeWrapInput cmode s)- state <- get- display_info $ Info_NormalForm state cmode time expr- where- action = allowNonTerminatingReductions- . (if B.computeIgnoreAbstract cmode then ignoreAbstractMode else inConcreteMode)- . B.evalInCurrent cmode--- interpret (Cmd_compute_toplevel cmode s) =--- parseAndDoAtToplevel action Info_NormalForm $ computeWrapInput cmode s--- where--- action = allowNonTerminatingReductions--- . (if computeIgnoreAbstract cmode then ignoreAbstractMode else inConcreteMode)--- . (B.showComputed cmode <=< B.evalInCurrent)-- interpret (ShowImplicitArgs showImpl) = do opts <- lift commandLineOptions setCommandLineOpts $@@ -575,7 +592,7 @@ over (lensPragmaOptions . lensOptShowIrrelevant . lensCollapseDefault) not opts interpret (Cmd_load_highlighting_info source) = do- l <- asksTC envHighlightingLevel+ l <- viewTC eHighlightingLevel when (l /= None) $ do -- Make sure that the include directories have -- been set.@@ -595,7 +612,7 @@ Just mi -> if hashText (Imp.srcText src) == iSourceHash (miInterface mi) then do- modFile <- useTC stModuleToSource+ modFile <- useSession lensModuleToSource method <- viewTC eHighlightingMethod return $ Just (iHighlighting $ miInterface mi, method, modFile) else@@ -606,7 +623,7 @@ mapM_ putResponse resp interpret (Cmd_tokenHighlighting source remove) = do- info <- do l <- asksTC envHighlightingLevel+ info <- do l <- viewTC eHighlightingLevel if l == None then return Nothing else do@@ -623,7 +640,8 @@ Nothing -> return () interpret (Cmd_highlight ii rng s) = do- l <- asksTC envHighlightingLevel+ rng <- syncInteractionRange ii rng+ l <- viewTC eHighlightingLevel when (l /= None) $ do scope <- getOldInteractionScope ii removeOldInteractionScope ii@@ -647,10 +665,16 @@ (mapLeft (const err) <$> freshTCM m) `catchError` \ _ -> return (Left err) -- freshTCM to avoid scope checking creating new interaction points -interpret (Cmd_give force ii rng s) = give_gen force ii rng s Give-interpret (Cmd_refine ii rng s) = give_gen WithoutForce ii rng s Refine+interpret (Cmd_give force ii rng s) = do+ rng <- syncInteractionRange ii rng+ give_gen force ii rng s Give +interpret (Cmd_refine ii rng s) = do+ rng <- syncInteractionRange ii rng+ give_gen WithoutForce ii rng s Refine+ interpret (Cmd_intro pmLambda ii rng _) = do+ rng <- syncInteractionRange ii rng ss <- lift $ B.introTactic pmLambda ii liftCommandMT (withInteractionId ii) $ case ss of [] -> do@@ -664,21 +688,25 @@ in (if null s' then Cmd_intro pmLambda else Cmd_refine) ii r s' interpret (Cmd_autoOne norm ii rng str) = do+ rng <- syncInteractionRange ii rng iscope <- getInteractionScope ii (time, result) <- maybeTimed $ Mimer.mimer norm ii rng str case result of MimerNoResult -> display_info $ Info_Auto "No solution found" MimerExpr str -> do- insertOldInteractionScope ii iscope- _ <- lift $ B.parseExprIn ii rng str >>= B.give WithForce ii (Just rng)- putResponse $ Resp_GiveAction ii $ Give_String str- modifyTheInteractionPoints (List.delete ii)- maybe (return ()) (display_info . Info_Time) time+ res <- parseExprFromAuto ii rng str \ e -> do+ insertOldInteractionScope ii iscope+ _ <- liftTCM $ B.give WithForce ii e+ putResponse $ Resp_GiveAction ii $ Give_String str+ modifyTheInteractionPoints (List.delete ii)+ whenJust time (display_info . Info_Time)+ case res of+ Left msg -> display_info $ Info_Auto msg+ Right () -> return () MimerList sols -> do display_info $ Info_Auto $ unlines $ [ "Solutions:" ] ++ [ " " ++ show i ++ ". " ++ s | (i, s) <- sols ]- MimerClauses{} -> __IMPOSSIBLE__ -- Mimer can't do case splitting yet interpret (Cmd_autoAll norm) = do iis <- getInteractionPoints@@ -688,43 +716,48 @@ unless (null iis) $ do let time = 1000 `div` length iis st <- getTC- solved <- fmap concat $ forM iis $ \ ii -> do+ (msgs, solveds) <- partitionEithers <$> forM iis \ ii -> do rng <- getInteractionRange ii res <- Mimer.mimer norm ii rng ("-t " ++ show time ++ "ms") case res of- MimerNoResult -> pure []- MimerExpr str -> do+ MimerNoResult -> pure $ Right []+ MimerExpr str -> parseExprFromAuto ii rng str \ e -> do iscope <- getOldScope ii insertOldInteractionScope ii iscope- _ <- liftTCM $ B.parseExprIn ii rng str >>= B.give WithoutForce ii (Just rng)+ _ <- liftTCM $ B.give WithoutForce ii e putResponse $ Resp_GiveAction ii $ Give_String str pure [ii]- MimerList{} -> pure [] -- Don't list solutions in autoAll- MimerClauses{} -> __IMPOSSIBLE__ -- Mimer can't do case splitting yet- modifyTheInteractionPoints (List.\\ solved)+ MimerList{} -> pure $ Right [] -- Don't list solutions in autoAll+ unlessNull (concat solveds) \ solved -> modifyTheInteractionPoints (List.\\ solved)+ unlessNull (concat msgs) (display_info . Info_Auto) -interpret (Cmd_context norm ii _ _) =+interpret (Cmd_context norm ii _ _) = do display_info . Info_Context ii =<< liftLocalState (B.getResponseContext norm ii) interpret (Cmd_helper_function norm ii rng s) = do+ rng <- syncInteractionRange ii rng -- Create type of application of new helper function that would solve the goal.- helperType <- liftLocalState $ withInteractionId ii $ inTopContext $ B.metaHelperType norm ii rng s+ helperType <- liftLocalState $ B.metaHelperType norm ii rng s display_info $ Info_GoalSpecific ii (Goal_HelperFunction helperType) interpret (Cmd_infer norm ii rng s) = do+ rng <- syncInteractionRange ii rng expr <- liftLocalState $ withInteractionId ii $ B.typeInMeta ii norm =<< B.parseExprIn ii rng s display_info $ Info_GoalSpecific ii (Goal_InferredType expr) -interpret (Cmd_goal_type norm ii _ _) =+interpret (Cmd_goal_type norm ii _ _) = do display_info $ Info_GoalSpecific ii (Goal_CurrentGoal norm) -interpret (Cmd_elaborate_give norm ii rng s) =+interpret (Cmd_elaborate_give norm ii rng s) = do+ rng <- syncInteractionRange ii rng give_gen WithoutForce ii rng s $ ElaborateGive norm -interpret (Cmd_goal_type_context norm ii rng s) =+interpret (Cmd_goal_type_context norm ii rng s) = do+ rng <- syncInteractionRange ii rng cmd_goal_type_context_and GoalOnly norm ii rng s interpret (Cmd_goal_type_context_infer norm ii rng s) = do+ rng <- syncInteractionRange ii rng -- In case of the empty expression to type, don't fail with -- a stupid parse error, but just fall back to -- Cmd_goal_type_context.@@ -738,6 +771,7 @@ cmd_goal_type_context_and aux norm ii rng s interpret (Cmd_goal_type_context_check norm ii rng s) = do+ rng <- syncInteractionRange ii rng expr <- liftLocalState $ withInteractionId ii $ do expr <- B.parseExprIn ii rng s goal <- B.typeOfMeta AsIs ii@@ -747,16 +781,18 @@ reify =<< B.normalForm norm term cmd_goal_type_context_and (GoalAndElaboration expr) norm ii rng s -interpret (Cmd_show_module_contents norm ii rng s) =+interpret (Cmd_show_module_contents norm ii rng s) = do+ rng <- syncInteractionRange ii rng liftCommandMT (withInteractionId ii) $ showModuleContents norm rng s -interpret (Cmd_why_in_scope_toplevel s) =+interpret (Cmd_why_in_scope_toplevel s) = do atTopLevel $ whyInScope s -interpret (Cmd_why_in_scope ii _range s) =+interpret (Cmd_why_in_scope ii _range s) = do liftCommandMT (withInteractionId ii) $ whyInScope s interpret (Cmd_make_case ii rng s) = do+ rng <- syncInteractionRange ii rng (f, casectxt, cs) <- lift $ makeCase ii rng s liftCommandMT (withInteractionId ii) $ do tel <- lift $ lookupSection (qnameModule f) -- don't shadow the names in this telescope@@ -779,11 +815,16 @@ ] putResponse $ Resp_MakeCase ii (makeCaseVariant casectxt) pcs' +interpret (Cmd_compute_toplevel cmode s) = do+ (time, expr) <- parseAndDoAtToplevel (B.computeInCurrent cmode) (B.computeWrapInput cmode s)+ state <- get+ display_info $ Info_NormalForm state cmode time expr interpret (Cmd_compute cmode ii rng s) = do+ rng <- syncInteractionRange ii rng expr <- liftLocalState $ do e <- B.parseExprIn ii rng $ B.computeWrapInput cmode s- withInteractionId ii $ applyWhen (B.computeIgnoreAbstract cmode) ignoreAbstractMode $ B.evalInCurrent cmode e+ withInteractionId ii $ B.computeInCurrent cmode e display_info $ Info_GoalSpecific ii (Goal_NormalForm cmode expr) interpret Cmd_show_version = display_info Info_Version@@ -791,7 +832,37 @@ interpret Cmd_abort = return () interpret Cmd_exit = return () +-- | Try to parse an expression generated by Auto and feed it to the continuation if successful.+-- If unsuccessful, just report the solution via 'Info_Auto'.+parseExprFromAuto :: InteractionId -> Range -> String -> (A.Expr -> CommandM a) -> CommandM (Either String a)+parseExprFromAuto ii rng str ret = do+ liftTCM (runPMIO $ parseRangeString exprWhereParser rng str) >>= \case+ -- Since the String comes from the Agda printer, we can ignore parse warnings.+ -- Also, no @where@ clause will be attached to the expression.+ (Right (C.ExprWhere ce _wh, _attrs), _warns) -> do+ e <- withInteractionId ii $ liftTCM $ concreteToAbstract_ ce+ Right <$> ret e+ (Left err, _warns) -> return $ Left $ unlines+ [ unwords [ prettyShow ii, ":=", str, " (fails to parse)" ]+ , prettyShow $ killRange err+ -- The range makes no sense since the string came from within Agda.+ ] +-- | If given range is empty, get the range of the interaction point.+-- Otherwise, set the range of the interaction point to the given range.+--+-- The idea is that the interaction frontend may have a more recent range for an interaction point+-- (for example, if the user has edited the file since the last command was sent).+--+-- There may be frontends that do not send ranges (like the interaction test suite),+-- so in that case get the range from the interaction point.+syncInteractionRange :: (MonadInteractionPoints m, MonadDebug m, MonadError TCErr m)+ => InteractionId -> Range -> m Range+syncInteractionRange ii r+ | null r = getInteractionRange ii+ | otherwise = r <$ setInteractionRange r ii++ decorate :: Doc -> String decorate = renderStyle (style { mode = OneLineMode }) @@ -817,7 +888,7 @@ solveInstantiatedGoals :: Rewrite -> Maybe InteractionId -> CommandM () solveInstantiatedGoals norm mii = do -- Andreas, 2016-10-23 issue #2280: throw away meta elims.- out <- lift $ localTC (\ e -> e { envPrintMetasBare = True }) $ do+ out <- lift $ localTC (set ePrintMetasBare True) $ do sip <- B.getSolvedInteractionPoints False norm -- only solve metas which have a proper instantiation, i.e., not another meta let sip' = maybe id (\ ii -> filter ((ii ==) . fst3)) mii sip@@ -874,7 +945,7 @@ fp <- liftIO $ absolute file sf <- liftTCM $ srcFromPath fp src <- lift $ Imp.parseSource sf- -- Andreas, 2024-08-03, see test/interaction/FileNotFound:+ -- Andreas, 2024-08-03, see test/Interaction/FileNotFound: -- Run 'getModificationTime' after 'parseSource', -- otherwise the user gets a weird error for non-existing files. -- (We assume that parsing is fast in comparison to type-checking,@@ -888,7 +959,7 @@ -- All options are reset when a file is reloaded, including the -- choice of whether or not to display implicit arguments. opts0 <- gets optionsOnReload- backends <- useTC stBackends+ backends <- useSession lensBackends let (z, warns) = runOptM $ parseBackendOptions backends argv opts0 mapM_ (lift . warning . OptionWarning) warns case z of@@ -926,7 +997,7 @@ withCurrentFile m = do mfile <- gets $ fmap currentFilePath . theCurrentFile i <- traverse idFromFile mfile- localTC (\ e -> e { envCurrentPath = i }) m+ localTC (set eCurrentPath i) m atTopLevel :: CommandM a -> CommandM a atTopLevel cmd = liftCommandMT B.atTopLevel cmd@@ -954,10 +1025,16 @@ -> CommandM () give_gen force ii rng s0 giveRefine = do let s = trim s0- reportSLn "interaction.give" 20 $ "give_gen " ++ s+ reportSDoc "interaction.give" 20 $ TCP.text ("give_gen " ++ s) TCP.<+> TCP.pretty rng+ -- Issue #8858: the disambiguated names recorded while checking the+ -- given expression have ranges inside the old goal.+ -- They are only valid for the immediate highlighting below,+ -- afterwards they are stale and would pollute later highlighting+ -- (e.g. by @Cmd_highlight@). Thus, we restore the old map at the end.+ disambiguatedNames <- useTC stDisambiguatedNames -- Andreas, 2015-02-26 if string is empty do nothing rather -- than giving a parse error.- unless (null s) $ do+ flip finally (setTCLens stDisambiguatedNames disambiguatedNames) $ unless (null s) $ do let give_ref = case giveRefine of Give -> B.give@@ -975,7 +1052,7 @@ mis <- getInteractionPoints reportSLn "interaction.give" 30 $ "interaction points before = " ++ show mis given <- lift $ B.parseExprIn ii rng s- ae <- lift $ give_ref force ii Nothing given+ ae <- lift $ give_ref force ii given mis' <- getInteractionPoints reportSLn "interaction.give" 30 $ "interaction points after = " ++ show mis' return (ae, given, mis' List.\\ mis)@@ -983,12 +1060,14 @@ insertOldInteractionScope ii scope -- sort the new interaction points and put them into the state -- in replacement of the old interaction point+ reportSDoc "interaction.give" 30 $ TCP.hsep $ ("new interaction points:" :) $+ map (\ i -> TCP.prettyTCM =<< do (i,) <$> getInteractionRange i) iis iis' <- sortInteractionPoints iis modifyTheInteractionPoints $ replace ii iis' -- print abstract expr- ce <- abstractToConcreteScope scope ae+ ce <- abstractToConcreteScope scope ae reportS "interaction.give" 30- [ "ce = " ++ show ce+ [ "ce = " ++ prettyShow ce , "scopePrecedence = " ++ show (scope ^. scopePrecedence) ] @@ -1013,7 +1092,7 @@ -- the highlighting is moved together with the text when the hole goes away. -- To make it work for refine we'd have to adjust the ranges. when literally $ do- l <- asksTC envHighlightingLevel+ l <- viewTC eHighlightingLevel when (l /= None) $ lift $ do printHighlightingInfo KeepHighlighting =<< generateTokenInfoFromString rng s@@ -1034,9 +1113,9 @@ highlightExpr :: A.Expr -> TCM () highlightExpr e =- localTC (\st -> st { envImportPath = []- , envHighlightingLevel = NonInteractive- , envHighlightingMethod = Direct }) $+ localTC ( set eImportStack []+ . set eHighlightingLevel NonInteractive+ . set eHighlightingMethod Direct) $ generateAndPrintSyntaxInfo decl Full True where dummy = mkName_ (NameId 0 noModuleNameHash) ("dummy" :: String)@@ -1048,10 +1127,7 @@ sortInteractionPoints :: (MonadInteractionPoints m, MonadError TCErr m, MonadDebug m) => [InteractionId] -> m [InteractionId]-sortInteractionPoints is =- map fst . List.sortBy (compare `on` snd) <$> do- forM is $ \ i -> do- (i,) <$> getInteractionRange i+sortInteractionPoints = sortOnM getInteractionRange -- | Displays the current goal, the given document, and the current -- context.@@ -1136,7 +1212,7 @@ displayStatus = putResponse . Resp_Status =<< status --- | @display_info@ does what @'display_info'' False@ does, but+-- | @display_info@ does what @'displayInfo' False@ does, but -- additionally displays some status information (see 'status' and -- 'displayStatus'). @@ -1178,14 +1254,13 @@ :: Maybe (HighlightingInfo, HighlightingMethod, ModuleToSource) -> IO [Response] tellToUpdateHighlighting Nothing = return [] tellToUpdateHighlighting (Just (info, method, modFile)) =- return [Resp_HighlightingInfo info KeepHighlighting method modFile]+ return [Resp_HighlightingInfo info KeepHighlighting method modFile Nothing] -- | Tells the Emacs mode to go to the first error position (if any). tellEmacsToJumpToError :: Range -> [Response] tellEmacsToJumpToError r = case rStart r of- Nothing -> []- Just (Pn { srcFile = Strict.Nothing }) -> []- Just (Pn { srcFile = Strict.Just f, posPos = p }) ->- [ Resp_JumpToError (filePath (rangeFilePath f)) p ]+ Nothing -> []+ Just (Pn' Strict.Nothing _ _) -> []+ Just (Pn' (Strict.Just f) p _) -> [Resp_JumpToError (filePath (rangeFilePath f)) p]
src/full/Agda/Interaction/JSON.hs view
@@ -16,9 +16,7 @@ import qualified Data.Aeson import Data.Aeson.Types ( Pair )-#if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.Key as Key-#endif import Data.Text (Text) import Data.Word (Word32)@@ -28,21 +26,18 @@ -- import qualified Agda.Syntax.Concrete as C -- import qualified Agda.Syntax.Internal as I-import Agda.TypeChecking.Monad+import Agda.TypeChecking.Monad hiding ((.=)) import Agda.Syntax.Common.Pretty++import Agda.Utils.DocTree qualified as DocTree import qualified Agda.Utils.FileName as File import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Interaction.Highlighting.Common (toAtoms)+import qualified Data.Aeson.KeyMap as KeyMap -#if MIN_VERSION_aeson(2,0,0) toKey :: Text -> Key toKey = Key.fromText-#else-type Key = Text -toKey :: Text -> Key-toKey = id-#endif- --------------------------------------------------------------------------- -- * The EncodeTCM class @@ -129,7 +124,22 @@ instance EncodeTCM Word32 instance EncodeTCM Value instance EncodeTCM Doc+instance EncodeTCM DocTree +instance ToJSON DocTree where+ toJSON = toJSON . DocTree.treeToTextNoAnn+ -- toJSON = toJsonDocTree -- TODO: communicate annotations to JSON client++-- UNUSED code taken from+-- https://github.com/plt-amy/agda/blob/9fd50b883f14a05792ed79a0b693fbecb2165bf5/src/full/Agda/LSP/Output.hs#L29-L35+toJsonDocTree :: DocTree -> Value+toJsonDocTree = \case+ DocTree.Node tt ds -> Object $ KeyMap.fromList+ [ ("style", toJSON (toAtoms tt))+ , ("children", toJSONList ds)+ ]+ DocTree.Text t -> toJSON t+ instance ToJSON Doc where toJSON = toJSON . render @@ -139,9 +149,3 @@ instance ToJSON File.AbsolutePath where toJSON (File.AbsolutePath path) = toJSON path--#if !(MIN_VERSION_aeson(1,5,3))-instance ToJSON a => ToJSON (Strict.Maybe a) where- toJSON (Strict.Just a) = toJSON a- toJSON Strict.Nothing = Null-#endif
src/full/Agda/Interaction/JSONTop.hs view
@@ -26,13 +26,15 @@ import Agda.Syntax.Abstract.Pretty ( prettyATop ) import Agda.Syntax.Common+import qualified Agda.Syntax.Abstract as A 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 )+ ( telToList, Dom'(..), Dom, MetaId(..), ProblemId(..), Blocker(..), alwaysUnblock,+ domIsFinite, domInfo ) import Agda.Syntax.Position- ( Range, rangeIntervals, Interval'(..), Position'(..), noRange )+ ( Range, rangeIntervals, Interval'(..), Position'(..), noRange, posLine, posCol ) import Agda.Syntax.Scope.Base ( WhyInScopeData(..) ) @@ -176,98 +178,101 @@ instance EncodeTCM ComputeMode where instance ToJSON ComputeMode where toJSON = encodeShow -encodeOCCmp :: (a -> TCM Value)- -> Comparison -> a -> a -> T.Text- -> TCM Value-encodeOCCmp f c i j k = kind k- [ "comparison" @= encodeShow c- , "constraintObjs" #= traverse f [i, j]- ]+instance EncodeTCM C.Expr where+instance ToJSON C.Expr where toJSON = encodePretty - -- Goals-encodeOC :: (a -> TCM Value)- -> (b -> TCM Value)- -> OutputConstraint b a+instance EncodeTCM A.Expr where+ encodeTCM e = encodeShow <$> prettyATop e++encodeOCCmp :: EncodeTCM a => Comparison+ -> a -> a -> T.Text -> TCM Value-encodeOC f encPrettyTCM = \case- OfType i a -> kind "OfType"- [ "constraintObj" #= f i- , "type" #= encPrettyTCM a- ]- CmpInType c a i j -> kind "CmpInType"+encodeOCCmp c i j k = kind k [ "comparison" @= encodeShow c- , "type" #= encPrettyTCM a- , "constraintObjs" #= traverse f [i, j]- ]- CmpElim ps a is js -> kind "CmpElim"- [ "polarities" @= map encodeShow ps- , "type" #= encPrettyTCM a- , "constraintObjs" #= traverse (traverse f) [is, js]- ]- JustType a -> kind "JustType"- [ "constraintObj" #= f a- ]- JustSort a -> kind "JustSort"- [ "constraintObj" #= f a- ]- CmpTypes c i j -> encodeOCCmp f c i j "CmpTypes"- CmpLevels c i j -> encodeOCCmp f c i j "CmpLevels"- CmpTeles c i j -> encodeOCCmp f c i j "CmpTeles"- CmpSorts c i j -> encodeOCCmp f c i j "CmpSorts"- Assign i a -> kind "Assign"- [ "constraintObj" #= f i- , "value" #= encPrettyTCM a- ]- TypedAssign i v t -> kind "TypedAssign"- [ "constraintObj" #= f i- , "value" #= encPrettyTCM v- , "type" #= encPrettyTCM t- ]- PostponedCheckArgs i es t0 t1 -> kind "PostponedCheckArgs"- [ "constraintObj" #= f i- , "ofType" #= encPrettyTCM t0- , "arguments" #= forM es encPrettyTCM- , "type" #= encPrettyTCM t1- ]- IsEmptyType a -> kind "IsEmptyType"- [ "type" #= encPrettyTCM a- ]- SizeLtSat a -> kind "SizeLtSat"- [ "type" #= encPrettyTCM a- ]- FindInstanceOF i t cs -> kind "FindInstanceOF"- [ "constraintObj" #= f i- , "candidates" #= forM cs encodeKVPairs- , "type" #= encPrettyTCM t- ]- where encodeKVPairs (_, v, t) = obj -- TODO: encode kind- [ "value" #= encPrettyTCM v- , "type" #= encPrettyTCM t- ]- ResolveInstanceOF q -> kind "ResolveInstanceOF"- [ "name" @= encodePretty q- ]- PTSInstance a b -> kind "PTSInstance"- [ "constraintObjs" #= traverse f [a, b]- ]- PostponedCheckFunDef name a err -> kind "PostponedCheckFunDef"- [ "name" @= encodePretty name- , "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- ]- UsableAtMod mod t -> kind "UsableAtMod"- [ "mod" @= encodePretty mod- , "term" #= f t+ , "constraintObjs" #= traverse encodeTCM [i, j] ] +-- Goals+instance (EncodeTCM a, EncodeTCM b) => EncodeTCM (OutputConstraint b a) where+ encodeTCM = \case+ OfType i a -> kind "OfType"+ [ "constraintObj" #= encodeTCM i+ , "type" #= encodeTCM a+ ]+ CmpInType c a i j -> kind "CmpInType"+ [ "comparison" @= encodeShow c+ , "type" #= encodeTCM a+ , "constraintObjs" #= traverse encodeTCM [i, j]+ ]+ CmpElim ps a is js -> kind "CmpElim"+ [ "polarities" @= map encodeShow ps+ , "type" #= encodeTCM a+ , "constraintObjs" #= traverse (traverse encodeTCM) [is, js]+ ]+ JustType a -> kind "JustType"+ [ "constraintObj" #= encodeTCM a+ ]+ JustSort a -> kind "JustSort"+ [ "constraintObj" #= encodeTCM a+ ]+ CmpTypes c i j -> encodeOCCmp c i j "CmpTypes"+ CmpLevels c i j -> encodeOCCmp c i j "CmpLevels"+ CmpTeles c i j -> encodeOCCmp c i j "CmpTeles"+ CmpSorts c i j -> encodeOCCmp c i j "CmpSorts"+ Assign i a -> kind "Assign"+ [ "constraintObj" #= encodeTCM i+ , "value" #= encodeTCM a+ ]+ TypedAssign i v t -> kind "TypedAssign"+ [ "constraintObj" #= encodeTCM i+ , "value" #= encodeTCM v+ , "type" #= encodeTCM t+ ]+ PostponedCheckArgs i es t0 t1 -> kind "PostponedCheckArgs"+ [ "constraintObj" #= encodeTCM i+ , "ofType" #= encodeTCM t0+ , "arguments" #= forM es encodeTCM+ , "type" #= encodeTCM t1+ ]+ IsEmptyType a -> kind "IsEmptyType"+ [ "type" #= encodeTCM a+ ]+ SizeLtSat a -> kind "SizeLtSat"+ [ "type" #= encodeTCM a+ ]+ FindInstanceOF i t cs -> kind "FindInstanceOF"+ [ "constraintObj" #= encodeTCM i+ , "candidates" #= forM cs encodeKVPairs+ , "type" #= encodeTCM t+ ]+ where encodeKVPairs (_, v, t) = obj -- TODO: encode kind+ [ "value" #= encodeTCM v+ , "type" #= encodeTCM t+ ]+ ResolveInstanceOF q -> kind "ResolveInstanceOF"+ [ "name" @= encodePretty q+ ]+ PTSInstance a b -> kind "PTSInstance"+ [ "constraintObjs" #= traverse encodeTCM [a, b]+ ]+ PostponedCheckFunDef name a err -> kind "PostponedCheckFunDef"+ [ "name" @= encodePretty name+ , "type" #= encodeTCM a+ , "error" #= encodeTCM err+ ]+ DataSort q s -> kind "DataSort"+ [ "name" @= encodePretty q+ , "sort" #= encodeTCM s+ ]+ CheckLock t lk -> kind "CheckLock"+ [ "head" #= encodeTCM t+ , "lock" #= encodeTCM lk+ ]+ UsableAtMod mod t -> kind "UsableAtMod"+ [ "mod" @= encodePretty mod+ , "term" #= encodeTCM t+ ]+ encodeNamedPretty :: PrettyTCM a => (Name, a) -> TCM Value encodeNamedPretty (name, a) = obj [ "name" @= encodePretty name@@ -279,7 +284,7 @@ [ "range" @= range , "problems" @= problems , "unblocker" @= unblock- , "constraint" #= encodeOC (pure . encodePretty) (pure . encodePretty) oc+ , "constraint" #= encodeTCM oc ] instance EncodeTCM Blocker where@@ -306,8 +311,8 @@ ws <- filterTCWarnings (tcWarnings wes) es <- filterTCWarnings (nonFatalErrors wes) kind "AllGoalsWarnings"- [ "visibleGoals" #= forM vis (\i -> withInteractionId (B.outputFormId $ OutputForm noRange [] alwaysUnblock i) $ encodeOC encodeTCM encodePrettyTCM i)- , "invisibleGoals" #= forM invis (encodeOC encodeTCM encodePrettyTCM)+ [ "visibleGoals" #= forM vis (\i -> withInteractionId (B.outputFormId $ OutputForm noRange [] alwaysUnblock i) $ encodeTCM i)+ , "invisibleGoals" #= forM invis encodeTCM , "warnings" #= encodeTCM ws , "errors" #= encodeTCM es ]@@ -353,12 +358,12 @@ [ "commandState" @= commandState , "computeMode" @= computeMode , "time" @= time- , "expr" #= encodePrettyTCM expr+ , "expr" #= (encodeShow <$> prettyNormalForm commandState computeMode expr) ] encodeTCM (Info_InferredType commandState time expr) = kind "InferredType" [ "commandState" @= commandState , "time" @= time- , "expr" #= encodePrettyTCM expr+ , "expr" #= (encodeShow <$> prettyInferredType commandState expr) ] encodeTCM (Info_Context ii ctx) = kind "Context" [ "interactionPoint" @= ii@@ -374,8 +379,10 @@ instance EncodeTCM GoalTypeAux where encodeTCM GoalOnly = kind "GoalOnly" []- encodeTCM (GoalAndHave expr _) = kind "GoalAndHave"- [ "expr" #= encodePrettyTCM expr ]+ encodeTCM (GoalAndHave expr boundary) = kind "GoalAndHave"+ [ "expr" #= encodePrettyTCM expr+ , "boundary" @= map encodePretty boundary+ ] encodeTCM (GoalAndElaboration expr) = kind "GoalAndElaboration" [ "term" #= encodePrettyTCM expr ] @@ -416,7 +423,7 @@ encodeTCM err = kind "Error" [ "warnings" @= ([] :: [String]) , "error" #= obj- [ "message" #= showInfoError err+ [ "message" #= showInfoError err ] ] @@ -431,8 +438,8 @@ ] instance EncodeTCM Response where- encodeTCM (Resp_HighlightingInfo info remove method modFile) =- liftIO $ jsonifyHighlightingInfo info remove method modFile+ encodeTCM (Resp_HighlightingInfo info remove method modFile file) =+ liftIO $ jsonifyHighlightingInfo info remove method modFile file encodeTCM (Resp_DisplayInfo info) = kind "DisplayInfo" [ "info" @= info ]@@ -474,7 +481,8 @@ , "expression" .= P.prettyShow expr ] encodeTCM (Resp_Mimer ii str) = kind "Mimer"- [ "solution" @= str+ [ "interactionPoint" @= ii+ , "solution" @= str ] -- | Convert Response to an JSON value for interactive editor frontends.
src/full/Agda/Interaction/Library.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedLists #-} {-# OPTIONS_GHC -Wunused-imports #-} @@ -11,10 +12,10 @@ -- -- -- Get the libraries (and immediate paths) relevant for @projectRoot@. -- -- This involves locating and processing the @.agda-lib@ file for the project.--- (libNames, includePaths) <- getDefaultLibraries projectRoot True+-- (project, libNames, includePaths) <- getDefaultLibraries projectRoot True -- -- -- Get include paths of depended-on libraries.--- resolvedPaths <- libraryIncludePaths Nothing libs libNames+-- resolvedPaths <- libraryIncludePaths Nothing project libs libNames -- -- let allPaths = includePaths ++ resolvedPaths -- @@@ -51,7 +52,7 @@ import Control.Monad.Writer ( Writer, runWriterT, tell ) import Control.Monad.IO.Class ( MonadIO(..) ) -import Data.Bifunctor ( second )+import Data.Bifunctor ( first, second ) import Data.Either import Data.Function (on) import qualified Data.List as List@@ -60,6 +61,7 @@ import Data.Set ( Set ) import qualified Data.Set as Set import qualified Data.Text as T+import Data.Tree ( Tree(Node) ) import System.Directory import System.FilePath@@ -68,6 +70,8 @@ import Agda.Interaction.Library.Base import Agda.Interaction.Library.Parse +import Agda.Syntax.Common.Pretty ( prettyShow )+ import Agda.TypeChecking.Monad.Base.Types ( IsBuiltinModule(..) ) import Agda.Utils.Environment@@ -83,7 +87,7 @@ import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Singleton-import Agda.Utils.Tuple ( mapSndM )+import Agda.Utils.Tuple ( secondM ) import Agda.Setup ( getDataFileName, getAgdaAppDir ) import Agda.Version@@ -115,7 +119,7 @@ (return $ AbsolutePath $ T.pack $ libdir </> "prim") (error $ "The lib directory " ++ libdir ++ " does not exist") --- | The @~/.agda/libraries@ file lists the libraries Agda should know about.+-- | The @$AGDA_DIR/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@.@@ -126,12 +130,18 @@ defaultLibraryFiles :: List1 FilePath defaultLibraryFiles = ("libraries-" ++ version) :| "libraries" : [] --- | The @defaultsFile@ contains a list of library names relevant for each Agda project.+-- | The @$AGDA_DIR/defaults@ file lists the library names relevant for all+-- Agda projects. ---defaultsFile :: FilePath-defaultsFile = "defaults"+-- Agda also honors version-specific @defaults@ files, e.g. @defaults-2.6.0@.+--+-- @defaultsFiles@ gives a list of all @defaults@ Agda should process+-- by default. The first file in this list that exists is actually used.+--+defaultsFiles :: List1 FilePath+defaultsFiles = ("defaults-" ++ version) :| "defaults" : [] --- | The @~/.agda/executables@ file lists the executables Agda should know about.+-- | The @$AGDA_DIR/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@.@@ -153,11 +163,14 @@ -- | The very magical, auto-imported modules. +agdaPrimitive :: FilePath+agdaPrimitive = "Agda" </> "Primitive.agda"++agdaPrimitiveCubical :: FilePath+agdaPrimitiveCubical = "Agda" </> "Primitive" </> "Cubical.agda"+ primitiveModules :: Set FilePath-primitiveModules = Set.fromList- [ "Agda" </> "Primitive.agda"- , "Agda" </> "Primitive" </> "Cubical.agda"- ]+primitiveModules = Set.fromList [agdaPrimitive, agdaPrimitiveCubical] -- | These builtins may use postulates, and are still considered @--safe@. @@ -177,6 +190,11 @@ , "Cubical" </> "Sub.agda" , "Equality" </> "Erase.agda" , "Equality.agda"+ , "Erased" </> "Box-cong.agda"+ , "Erased" </> "Erased.agda"+ , "Erased" </> "Funext.agda"+ , "Erased" </> "Propext.agda"+ , "Erased" </> "Quotient.agda" , "Float.agda" , "Float" </> "Properties.agda" , "FromNat.agda"@@ -224,8 +242,9 @@ f <- relativizeAbsolutePath fp primLibDir guard $ f `Set.member` builtinModules if f `Set.member` builtinModulesWithUnsafePostulates then return IsBuiltinModule- else if f `Set.member` primitiveModules then return IsPrimitiveModule- else return IsBuiltinModuleWithSafePostulates+ else if f == agdaPrimitive then pure IsAgdaPrimitive+ else if f == agdaPrimitiveCubical then pure IsAgdaPrimitiveCubical+ else pure IsBuiltinModuleWithSafePostulates ------------------------------------------------------------------------ -- * Get the libraries for the current project@@ -248,7 +267,19 @@ filterM (\file -> and2M (pure $ takeExtension file == ".agda-lib") (doesFileExist (root </> file)))- case libFiles of+#if defined(wasm32_HOST_ARCH)+ -- During tests, wasmtime sometimes reports duplicate entries in a directory.+ -- This extra step workarounds the quirky behavior; see comments in PR #8205.+ let libFiles' = case libFiles of+ [] -> []+ [file] -> [file]+ (f:files)+ | all (== f) files -> [f] -- All entries are duplicates of the same file+ | otherwise -> libFiles+#else+ let libFiles' = libFiles+#endif+ case libFiles' of [] -> liftIO (upPath root) >>= \case Just up -> do conf <- over lensConfigAbove (+ 1) <$> findProjectConfig up@@ -311,17 +342,21 @@ -- If none are found, use default dependencies (according to @defaults@ file) -- and current directory (project root). --+-- Also returns the @.agda-lib@ file of the project, if any.+-- getDefaultLibraries :: FilePath -- ^ Project root. -> Bool -- ^ Use @defaults@ if no @.agda-lib@ file exists for this project?- -> LibM ([LibName], [FilePath]) -- ^ The returned @LibName@s are all non-empty strings.+ -> LibM (Maybe AgdaLibFile, [LibName], [FilePath])+ -- ^ The returned @LibName@s are all non-empty strings. getDefaultLibraries root optDefaultLibs = do libs <- getAgdaLibFile root if null libs- then (,[]) <$> if optDefaultLibs then mkLibM [] $ (libNameForCurrentDir :) <$> readDefaultsFile else return []+ then (Nothing,,[]) <$> if optDefaultLibs then mkLibM [] $ (libNameForCurrentDir :) <$> readDefaultsFile else return [] else return $ libsAndPaths libs where- libsAndPaths ls = ( concatMap _libDepends ls+ libsAndPaths ls = ( listToMaybe ls+ , concatMap _libDepends ls , nubOn id (concatMap _libIncludes ls) ) @@ -332,10 +367,13 @@ readDefaultsFile :: LibErrorIO [LibName] readDefaultsFile = do agdaDir <- liftIO getAgdaAppDir- let file = agdaDir </> defaultsFile- ifNotM (liftIO $ doesFileExist file) (return []) $ {-else-} do- ls <- liftIO $ map snd . stripCommentLines <$> UTF8.readFile file- return $ map parseLibName $ concatMap splitCommas ls+ let defaults = List1.map (agdaDir </>) defaultsFiles -- NB: very short list+ files <- liftIO $ filterM doesFileExist (List1.toList defaults)+ case files of+ [] -> return []+ file : _ -> do+ ls <- liftIO $ map snd . stripCommentLines <$> UTF8.readFile file+ return $ map parseLibName $ concatMap splitCommas ls `catchIO` \ e -> do raiseErrors' [ ReadError e "Failed to read defaults file." ] return []@@ -437,10 +475,9 @@ getExecutablesFile = do agdaDir <- getAgdaAppDir let defaults = List1.map (agdaDir </>) defaultExecutableFiles -- NB: very short list- files <- filterM doesFileExist (List1.toList defaults)- case files of- file : _ -> return $ ExecutablesFile file True- [] -> return $ ExecutablesFile (List1.last defaults) False -- doesn't exist, but that's ok+ findM doesFileExist defaults >>= \case+ Just file -> return $ ExecutablesFile file True+ Nothing -> return $ ExecutablesFile (List1.last defaults) False -- doesn't exist, but that's ok -- | Return the trusted executables Agda knows about. --@@ -452,7 +489,7 @@ file <- liftIO getExecutablesFile if not (efExists file) then return Map.empty else do es <- liftIO $ stripCommentLines <$> UTF8.readFile (efPath file)- lines <- liftIO $ mapM (mapSndM expandEnvironmentVariables) es+ lines <- liftIO $ mapM (secondM expandEnvironmentVariables) es parseExecutablesFile file lines `catchIO` \ e -> do raiseErrors' [ ReadError e "Failed to read trusted executables." ]@@ -492,18 +529,26 @@ ------------------------------------------------------------------------ -- | Get all include pathes for a list of libraries to use.+--+-- Warns if a library is depended on in different versions+-- (see 'libraryVersionConflicts'). libraryIncludePaths- :: Maybe FilePath -- ^ @libraries@ file (error reporting only).- -> [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 $ do+ :: Maybe FilePath -- ^ @libraries@ file (error reporting only).+ -> Maybe AgdaLibFile -- ^ The project the libraries are used by, if any (warnings only).+ -> [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 root libs xs0 = mkLibM libs $ do efile <- liftIO $ runExceptT $ getLibrariesFile overrideLibFile case efile of Left theOverrideLibFile -> do raiseErrors' [ LibrariesFileNotFound theOverrideLibFile ] return []- Right file -> embedWriter $ (dot ++) . incs <$> find file [] xs+ Right file -> do+ (ls, resolved) <- embedWriter $ find file Map.empty xs+ ws <- liftIO $ libraryVersionConflicts root xs $ Map.mapMaybe id resolved+ List1.unlessNull ws warnings'+ return $ dot ++ incs ls where (dots, xs) = List.partition (== libNameForCurrentDir) xs0 incs = nubOn id . concatMap _libIncludes@@ -512,12 +557,13 @@ -- Due to library dependencies, the work list may grow temporarily. find :: LibrariesFile -- Only for error reporting.- -> [LibName] -- Already resolved libraries.+ -> Map LibName (Maybe AgdaLibFile)+ -- Already processed libraries and what they resolved to. -> [LibName] -- Work list: libraries left to be resolved.- -> Writer LibErrWarns [AgdaLibFile]- find _ _ [] = pure []+ -> Writer LibErrWarns ([AgdaLibFile], Map LibName (Maybe AgdaLibFile))+ find _ visited [] = pure ([], visited) find file visited (x : xs)- | x `elem` visited = find file visited xs+ | x `Map.member` visited = find file visited xs | otherwise = do -- May or may not find the library ml <- case findLib x libs of@@ -526,7 +572,126 @@ l1 : l2 : ls -> Nothing <$ raiseErrors' [AmbiguousLib x $ List2 l1 l2 ls] -- If it is found, add its dependencies to work list let xs' = foldMap _libDepends ml ++ xs- mcons ml <$> find file (x : visited) xs'+ first (mcons ml) <$> find file (Map.insert x ml visited) xs'++-- | Detect libraries that are depended on in different versions (issue #8875).+--+-- For each such library, we return a 'LibraryVersionConflict' warning+-- containing the dependency tree pruned to the paths leading to the conflicting versions.+--+libraryVersionConflicts+ :: Maybe AgdaLibFile -- ^ The project, if any.+ -> [LibName] -- ^ The libraries the project depends on.+ -> Map LibName AgdaLibFile -- ^ What the (transitively) depended-on libraries resolved to.+ -> IO [LibWarning']+libraryVersionConflicts root roots resolved = do+ -- We identify libraries by the canonical path of their @.agda-lib@ file.+ -- Also, the canonical paths are absolute, so the Emacs mode can make them clickable.+ let canon l = do+ f <- canonicalizePath (_libFile l) `catchIO` \ (_ :: E.IOException) -> pure (_libFile l)+ pure l{ _libFile = f }+ root <- traverse canon root+ resolved <- traverse canon resolved+ pure $ libraryVersionConflicts' root roots resolved++-- | Pure part of 'libraryVersionConflicts'.+libraryVersionConflicts'+ :: Maybe AgdaLibFile -- ^ The project, if any.+ -> [LibName] -- ^ The libraries the project depends on.+ -> Map LibName AgdaLibFile -- ^ What the (transitively) depended-on libraries resolved to.+ -> [LibWarning']+libraryVersionConflicts' root roots resolved =+ [ conflict b fs | (b, fs) <- Map.toList groups, Set.size fs >= 2 ]+ where+ -- The distinct library files, grouped by the base name of their library.+ groups :: Map T.Text (Set FilePath)+ groups = Map.fromListWith Set.union+ [ (b, Set.singleton $ _libFile l)+ | l <- maybeToList root ++ Map.elems resolved+ , let b = libNameBase $ _libName l+ , not $ T.null b+ ]++ -- The dependencies of a library.+ deps :: LibName -> [LibName]+ deps x = nubOn id $ foldMap _libDepends $ Map.lookup x resolved++ label :: LibName -> T.Text+ label = T.pack . prettyShow++ rootLabel :: T.Text+ rootLabel = case root of+ Just l | not $ T.null $ libNameBase $ _libName l -> label $ _libName l+ _ -> libDepRootLabel++ -- The name a library resolved to, if different from the requested name.+ resolvedAs :: LibName -> Maybe T.Text+ resolvedAs x = case _libName <$> Map.lookup x resolved of+ Just y | y /= x -> Just $ label y+ _ -> Nothing++ conflict :: T.Text -> Set FilePath -> LibWarning'+ conflict b fs = LibraryVersionConflict b tree files+ where+ -- The libraries resolving to a conflicting version or depending on such.+ relevant :: Set LibName+ relevant = saturate $ Map.keysSet $ Map.filter ((`Set.member` fs) . _libFile) resolved++ saturate :: Set LibName -> Set LibName+ saturate s+ | Set.size s' == Set.size s = s+ | otherwise = saturate s'+ where+ s' = Set.union s $ Map.keysSet $+ Map.filterWithKey (\ x _ -> any (`Set.member` s) $ deps x) resolved++ relevantOnly :: [LibName] -> [LibName]+ relevantOnly = filter (`Set.member` relevant)++ -- A library resolving to one of the conflicting versions.+ conflicting :: LibName -> Bool+ conflicting x = maybe False ((`Set.member` fs) . _libFile) $ Map.lookup x resolved++ tree :: LibDepTree+ tree = Node (LibDepNode rootLabel Nothing) $ snd $+ expand Set.empty $ relevantOnly $ nubOn id roots++ -- Expand the given siblings from left to right.+ expand :: Set LibName -> [LibName] -> (Set LibName, [LibDepTree])+ expand seen = second catMaybes . List.mapAccumL visit seen++ -- A library that has been visited before is omitted.+ -- So is a library which does not lead to a conflicting version not shown before.+ visit :: Set LibName -> LibName -> (Set LibName, Maybe LibDepTree)+ visit seen x+ | x `Set.member` seen = (seen, Nothing)+ | otherwise = second prune $ expand (Set.insert x seen) $ relevantOnly $ deps x+ where+ prune ts+ | null ts && not (conflicting x) = Nothing+ | otherwise = Just $ Node (LibDepNode (label x) (resolvedAs x)) ts++ -- The files of the libraries mentioned in the tree, in order of first occurrence,+ -- with the position of the first dependency shown in the tree.+ files :: [(T.Text, FilePath, Maybe LibFilePos)]+ files = nubOn (\ (l, f, _) -> (l, f)) $+ [ (rootLabel, _libFile l, firstDepPos l ts) | l <- maybeToList root ] +++ concatMap entries ts+ where Node _ ts = tree++ entries :: LibDepTree -> [(T.Text, FilePath, Maybe LibFilePos)]+ entries (Node n ts) =+ [ (depLabel n, _libFile l, firstDepPos l ts) | l <- maybeToList $ Map.lookup (depLabel n) libOf ] +++ concatMap entries ts++ -- Where the first of the given dependencies is mentioned in the given library file.+ firstDepPos :: AgdaLibFile -> [LibDepTree] -> Maybe LibFilePos+ firstDepPos l = \case+ Node n _ : _ -> Map.lookup (depLabel n) $ Map.mapKeys label $ _libDependsPos l+ [] -> Nothing++ libOf :: Map T.Text AgdaLibFile+ libOf = Map.fromList [ (label x, l) | (x, l) <- Map.toList resolved ] -- | @findLib x libs@ retrieves the matches for @x@ from list @libs@. --
src/full/Agda/Interaction/Library/Base.hs view
@@ -19,9 +19,9 @@ import qualified Data.List as List import Data.Map ( Map ) import qualified Data.Map as Map-import Data.Semigroup ( Semigroup(..) ) import Data.Text ( Text, unpack ) import qualified Data.Text as T+import Data.Tree ( Tree ) import GHC.Generics ( Generic ) @@ -30,6 +30,7 @@ import Agda.Interaction.Options.Warnings import Agda.Syntax.Common.Pretty+import Agda.Syntax.Concrete.Glyph ( treeGlyphs ) import Agda.Syntax.Position import Agda.Utils.IO ( showIOException )@@ -164,6 +165,9 @@ -- located? , _libIncludes :: [FilePath] -- ^ Roots where to look for the modules of the library. , _libDepends :: [LibName] -- ^ Dependencies.+ , _libDependsPos :: Map LibName LibFilePos+ -- ^ Where the dependencies are mentioned+ -- in the @.agda-lib@ file (first mention). , _libPragmas :: OptionsPragma -- ^ Default pragma options for all files in the library. }@@ -176,6 +180,7 @@ , _libAbove = 0 , _libIncludes = [] , _libDepends = []+ , _libDependsPos = Map.empty , _libPragmas = mempty } @@ -218,7 +223,20 @@ -- ** Position information type LineNumber = Int+type ColumnNumber = Int +-- | A stretch of a line in a file.+data LibFilePos = LibFilePos+ { lfpLine :: !LineNumber+ , lfpStartCol :: !ColumnNumber -- ^ Starting column (1-based).+ , lfpEndCol :: !ColumnNumber -- ^ Ending column (exclusive).+ }+ deriving (Show, Generic)++-- | Print as @line.col-endcol@, the format used for ranges in Agda files.+instance Pretty LibFilePos where+ pretty (LibFilePos l c e) = hcat [ pretty l, ".", pretty c, "-", pretty e ]+ -- | Information about which @.agda-lib@ file we are reading -- and from where in the @libraries@ file it came from. @@ -237,10 +255,40 @@ -- | Library Warnings. data LibWarning' = UnknownField String+ | LibraryVersionConflict+ -- ^ A library is depended on in different versions.+ Text+ -- ^ The library name without version.+ LibDepTree+ -- ^ The dependency tree, pruned to the paths leading to the conflicting versions.+ [(Text, FilePath, Maybe LibFilePos)]+ -- ^ The @.agda-lib@ files of the libraries mentioned in the tree,+ -- keyed by their 'depLabel',+ -- with the position of the first dependency shown in the tree (if any). deriving (Show, Generic) +-- | A dependency tree of libraries, used to report the provenance+-- of a 'LibraryVersionConflict'.+type LibDepTree = Tree LibDepNode++-- | A node in a 'LibDepTree'.+data LibDepNode = LibDepNode+ { depLabel :: Text+ -- ^ The library name as written in the @depend@ field+ -- (or the name of the project at the root).+ , depResolvedAs :: Maybe Text+ -- ^ The name of the library the label resolved to, if different from the label.+ }+ deriving (Show, Generic)++-- | Label of the root of a 'LibDepTree' if the project has no name.+libDepRootLabel :: Text+libDepRootLabel = "<root>"+ libraryWarningName :: LibWarning -> WarningName-libraryWarningName (LibWarning c (UnknownField{})) = LibUnknownField_+libraryWarningName (LibWarning c w) = case w of+ UnknownField{} -> LibUnknownField_+ LibraryVersionConflict{} -> LibraryVersionConflict_ -- * Errors @@ -532,8 +580,30 @@ Just (LibPositionInfo _ _ file) -> hcat [ text file, ":"] <+> pretty w instance Pretty LibWarning' where- pretty (UnknownField s) = text $ "Unknown field '" ++ s ++ "'"+ pretty = \case+ UnknownField s -> text $ "Unknown field '" ++ s ++ "'"+ LibraryVersionConflict lib tree files -> vcat $ concat+ [ [ hcat [ "Different versions of the library '", pretty lib, "' depended on:" ] ]+ , [ prettyLibDepTree tree ]+ , [ "Library files:" ]+ -- Andreas, 2026-10-24, issue #8875+ -- We print positions as "file:line.col-endcol"+ -- so that the Emacs mode makes them clickable.+ -- Without a dependency position, we point to the beginning of the file.+ , [ hcat [ brackets (pretty l), ":" ] <+> hcat [ text f, ":", maybe "1.1" pretty mpos ]+ | (l, f, mpos) <- files+ ]+ ] +-- | Render a 'LibDepTree', one line per node.+prettyLibDepTree :: LibDepTree -> Doc+prettyLibDepTree = prettyTree treeGlyphs++instance Pretty LibDepNode where+ pretty (LibDepNode l mr) = case mr of+ Nothing -> brackets (pretty l)+ Just r -> pretty r <+> "as" <+> brackets (pretty l)+ ------------------------------------------------------------------------ -- Hashable instances ------------------------------------------------------------------------@@ -563,8 +633,10 @@ instance NFData LibName instance NFData LibCache instance NFData LibPositionInfo+instance NFData LibFilePos instance NFData LibWarning instance NFData LibWarning'+instance NFData LibDepNode instance NFData LibError instance NFData LibError' instance NFData LibErrors
src/full/Agda/Interaction/Library/Parse.hs view
@@ -34,6 +34,8 @@ import Control.Monad.Writer import Data.Char import qualified Data.List as List+import Data.Map (Map)+import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as T import System.FilePath@@ -69,17 +71,25 @@ type GenericFile = [GenericEntry] data GenericEntry = GenericEntry- { geHeader :: String -- ^ E.g. field name. @trim@med.- , _geContent :: [String] -- ^ E.g. field content. @trim@med.+ { geHeader :: String -- ^ E.g. field name. @trim@med.+ , _geContent :: [ContentLine] -- ^ E.g. field content. @trim@med. } +-- | A (part of a) line of field content.+data ContentLine = ContentLine+ { clLine :: LineNumber+ , clColumn :: ColumnNumber -- ^ Column (1-based) where 'clText' starts.+ , clText :: String -- ^ @trim@med.+ }+ deriving (Show)+ -- | Library file field format format [sic!]. data Field = forall a. Field { fName :: String -- ^ Name of the field. , fOptional :: Bool -- ^ Is it optional?- , fParse :: Range -> [String] -> P a+ , fParse :: Range -> [ContentLine] -> P a -- ^ Content parser for this field. -- -- The range points to the start of the file.@@ -88,19 +98,29 @@ } optionalField ::- String -> (Range -> [String] -> P a) -> Lens' AgdaLibFile a -> Field+ String -> (Range -> [ContentLine] -> P a) -> Lens' AgdaLibFile a -> Field optionalField str p l = Field str True p (set l) -- | @.agda-lib@ file format with parsers and setters. agdaLibFields :: [Field] agdaLibFields = -- Andreas, 2017-08-23, issue #2708, field "name" is optional.- [ optionalField "name" (\_ -> parseName) libName- , optionalField "include" (\_ -> pure . concatMap parsePaths) libIncludes- , optionalField "depend" (\_ -> pure . map parseLibName . concatMap splitCommas) libDepends- , optionalField "flags" (\r -> pure . foldMap (parseFlags r)) libPragmas+ [ optionalField "name" (\_ -> parseName . map clText) libName+ , optionalField "include" (\_ -> pure . concatMap (parsePaths . clText)) libIncludes+ , Field "depend" True (\_ -> pure . parseDepends)+ (\ (ds, pos) l -> l{ _libDepends = ds, _libDependsPos = pos })+ , optionalField "flags" (\r -> pure . foldMap (parseFlags r . clText)) libPragmas ] where+ -- Remember where the dependencies are mentioned (issue #8875).+ parseDepends :: [ContentLine] -> ([LibName], Map LibName LibFilePos)+ parseDepends cls = (map fst ds, Map.fromListWith (\ _new old -> old) ds)+ where+ ds = [ (parseLibName w, LibFilePos l c (c + length w))+ | ContentLine l c0 s <- cls+ , (c, w) <- splitCommasPos c0 s+ ]+ parseName :: [String] -> P LibName parseName [s] | [name] <- words s = pure $ parseLibName name parseName ls = throwError $ BadLibraryName $ unwords ls@@ -167,21 +187,13 @@ foldM upd emptyLibFile fs where -- The range points to the start of the file.- r = Range- (Strict.Just $ mkRangeFile file Nothing)- (singleton (posToInterval () p p))- where- p = Pn { srcFile = ()- , posPos = 1- , posLine = 1- , posCol = 1- }-+ r :: Range+ r = beginningOfFile file upd :: AgdaLibFile -> GenericEntry -> P AgdaLibFile upd l (GenericEntry h cs) = do mf <- findField h fields case mf of- Just Field{..} -> do+ Just Field{ fParse, fSet } -> do x <- fParse r cs return $ fSet x l Nothing -> return l@@ -221,9 +233,8 @@ = Header LineNumber String -- ^ Header line, like a field name, e.g. "include :". Cannot be indented. -- @String@ is 'trim'med.- | Content LineNumber String+ | Content ContentLine -- ^ Other line. Must be indented.- -- @String@ is 'trim'med. deriving (Show) -- | Parse line into 'Header' and 'Content' components.@@ -244,19 +255,19 @@ -- -- @ -- [ Header 1 "name"--- , Content 1 "Main"+-- , Content (ContentLine 1 7 "Main") -- , Header 2 "depend"--- , Content 3 "standard-library"+-- , Content (ContentLine 3 3 "standard-library") -- , Header 4 "include"--- , Content 4 "."--- , Content 5 "src more-src"+-- , Content (ContentLine 4 10 ".")+-- , Content (ContentLine 5 3 "src more-src") -- ] -- @ parseLine :: LineNumber -> String -> P [GenericLine] parseLine _ "" = pure [] parseLine l s@(c:_) -- Indented lines are 'Content'.- | isSpace c = pure [Content l $ ltrim s]+ | isSpace c = pure [content $ ltrim s] -- Non-indented lines are 'Header'. | otherwise = case break (== ':') s of@@ -264,10 +275,13 @@ -- Anything after the colon that is not whitespace is 'Content'. (h, ':' : r) -> case words h of- [h] -> pure $ Header l h : [Content l r' | let r' = ltrim r, not (null r')]+ [h] -> pure $ Header l h : [content r' | let r' = ltrim r, not (null r')] [] -> throwError $ MissingFieldName l hs -> throwError $ BadFieldName l h _ -> throwError $ MissingColonForField l (ltrim s)+ where+ -- @r@ is a suffix of @s@.+ content r = Content $ ContentLine l (length s - length r + 1) r -- | Collect 'Header' and subsequent 'Content's into 'GenericEntry'. --@@ -275,8 +289,8 @@ -- groupLines :: [GenericLine] -> P GenericFile groupLines [] = pure []-groupLines (Content l c : _) = throwError $ ContentWithoutField l-groupLines (Header _ h : ls) = (GenericEntry h [ c | Content _ c <- cs ] :) <$> groupLines ls1+groupLines (Content c : _) = throwError $ ContentWithoutField $ clLine c+groupLines (Header _ h : ls) = (GenericEntry h [ c | Content c <- cs ] :) <$> groupLines ls1 where (cs, ls1) = span isContent ls isContent Content{} = True@@ -288,7 +302,17 @@ -- | Break a comma-separated string. Result strings are @trim@med. splitCommas :: String -> [String]-splitCommas = words . map (\c -> if c == ',' then ' ' else c)+splitCommas = map snd . splitCommasPos 1++-- | Break a comma-separated string starting at the given column.+-- Result strings are @trim@med and come with their starting column.+splitCommasPos :: ColumnNumber -> String -> [(ColumnNumber, String)]+splitCommasPos c0 = go . zip [c0..]+ where+ go ps = case dropWhile (isSep . snd) ps of+ [] -> []+ ps'@((c, _) : _) -> let (w, rest) = break (isSep . snd) ps' in (c, map snd w) : go rest+ isSep c = c == ',' || isSpace c -- | ...and trailing, but not leading, whitespace. stripComments :: String -> String
src/full/Agda/Interaction/MakeCase.hs view
@@ -6,7 +6,6 @@ import Prelude hiding ((!!), null) -import Data.Either import qualified Data.List as List import Data.Maybe import Data.Monoid@@ -14,22 +13,22 @@ import Agda.Syntax.Common import Agda.Syntax.Info import Agda.Syntax.Position-import Agda.Syntax.Concrete (NameInScope(..)) import qualified Agda.Syntax.Concrete as C import qualified Agda.Syntax.Concrete.Pattern as C import qualified Agda.Syntax.Abstract as A import qualified Agda.Syntax.Abstract.Pattern as A import qualified Agda.Syntax.Common.Pretty as P+import Agda.Syntax.Common.Pretty ( prettyShow ) import Agda.Syntax.Internal import Agda.Syntax.Internal.Pattern import Agda.Syntax.Parser.Helpers ( mkValidName )-import Agda.Syntax.Scope.Base ( ResolvedName(..), BindingSource(..), KindOfName(..), exceptKindsOfNames )+import Agda.Syntax.Scope.Base ( ResolvedName(..), BindingSource(..), exceptKindsOfNames ) import Agda.Syntax.Scope.Monad ( resolveName' ) import Agda.Syntax.Translation.InternalToAbstract import Agda.TypeChecking.Monad import Agda.TypeChecking.Coverage-import Agda.TypeChecking.Coverage.Match ( SplitPatVar(..) , SplitPattern , applySplitPSubst , fromSplitPatterns )+import Agda.TypeChecking.Coverage.SplitPattern ( SplitPatVar(..) , SplitPattern , applySplitPSubst , fromSplitPatterns ) import Agda.TypeChecking.Empty ( isEmptyTel ) import Agda.TypeChecking.Pretty import Agda.TypeChecking.Rules.Def (checkClauseLHS)@@ -41,16 +40,33 @@ import qualified Agda.Utils.BiMap as BiMap import Agda.Utils.Function import Agda.Utils.Functor-import Agda.Utils.Lens (set) import Agda.Utils.List import Agda.Utils.Monad import Agda.Utils.Null+import Agda.Utils.Three import Agda.Utils.WithDefault (lensKeepDefault) import Agda.Utils.Impossible type CaseContext = Maybe ExtLamInfo +-- | For the names the user enters for case-splitting, there can be different actions+-- depending on what the name resolved to.+data SplitAction+ = RevealDotPattern Name+ -- ^ De Bruijn index of a pattern variable bound to a value, turn into dot pattern.+ | RevealHiddenVariable Int+ -- ^ De Bruijn index of a hidden argument, make this argument visible.+ | SplitOnVariable Int+ -- ^ De Bruijn index of an unconstrained pattern variable, split on it.+ deriving (Show)++splitActionToEither3 :: SplitAction -> Either3 Name Int Int+splitActionToEither3 = \case+ RevealDotPattern i -> In1 i+ RevealHiddenVariable i -> In2 i+ SplitOnVariable i -> In3 i+ -- | Parse variables (visible or hidden), returning their de Bruijn indices. -- Used in 'makeCase'. @@ -61,8 +77,8 @@ -> InteractionId -- ^ The hole of this function we are working on. -> Range -- ^ The range of this hole. -> [String] -- ^ The words the user entered in this hole (variable names).- -> TCM [(Int,NameInScope)] -- ^ The computed de Bruijn indices of the variables to split on,- -- with information about whether each variable is in scope.+ -> TCM [SplitAction]+ -- ^ The computed de Bruijn indices of the variables and the inferred action. parseVariables f cxt asb ii rng ss = do -- We parse the variables in two steps:@@ -140,9 +156,10 @@ -- has been refined to a module parameter we do allow splitting -- on it, since the instantiation could as well have been the -- other way around (see #2183).- (Just (Var i []), PatternBound _) -> return (i, C.InScope)+ (Just (Var i []), PatternBound _) -> return (SplitOnVariable i) -- Case 1b: the variable has been refined.- (Just v , PatternBound _) -> failInstantiatedVar s v+ -- Andreas, 2025-10-12, issue #7941: We can turn it into an explicit dot pattern.+ (Just v , PatternBound _) -> return (RevealDotPattern name) -- failInstantiatedVar s v -- Case 1c: the variable is bound locally (e.g. a record let) (Nothing , PatternBound _) -> failCaseLet s -- Case 1d: module parameter@@ -162,10 +179,11 @@ -- clause context. If it is not a parameter, we can make it -- visible. Just (x, Var i []) | isParam i -> failHiddenModuleBound s- | otherwise -> return (i, C.NotInScope)+ | otherwise -> return (RevealHiddenVariable i) -- Case 2b: there is a variable with that concrete name, but it -- has been refined.- Just (x, v) -> failInstantiatedVar s v+ -- Andreas, 2025-10-12, issue #7941: We can turn it into an explicit dot pattern.+ Just (x, v) -> return (RevealDotPattern x) -- failInstantiatedVar s v -- Case 2c: there is no variable with that name. Since it was in -- scope for the interaction meta, the only possibility is that -- it is a hidden lambda-bound variable.@@ -190,10 +208,10 @@ failWithBound s = interactionError $ CaseSplitError $ P.text $ "Cannot split on variable " ++ s ++ ", because it is an equality proof bound by a with-abstraction"- failInstantiatedVar s v = interactionError . CaseSplitError =<< sep- [ text $ "Cannot split on variable " ++ s ++ ", because it is bound to"- , prettyTCM v- ]+ -- failInstantiatedVar s v = interactionError . CaseSplitError =<< sep+ -- [ text $ "Cannot split on variable " ++ s ++ ", because it is bound to"+ -- , prettyTCM v+ -- ] failCaseLet s = interactionError $ CaseSplitError $ P.text $ "Cannot split on variable " ++ s ++ ", because let-declarations may not be defined by pattern-matching"@@ -225,7 +243,7 @@ ] __IMPOSSIBLE__ -recheckAbstractClause :: Type -> Maybe Substitution -> A.SpineClause -> TCM (Clause, Context, [AsBinding])+recheckAbstractClause :: Type -> IsWithFunction 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@@ -234,7 +252,7 @@ , clauseBody = Nothing -- We don't need the body for make case , clauseType = Just (lhsBodyType lhs) , clauseCatchall = empty- , clauseRecursive = Nothing+ , clauseRecursive = MaybeRecursive , clauseUnreachable = Nothing , clauseEllipsis = lhsEllipsis $ A.spLhsInfo $ A.clauseLHS acl , clauseWhereModule = A.whereModule $ A.clauseWhereDecls acl@@ -250,7 +268,7 @@ makeCase hole rng s = withInteractionId hole $ locallyTC eMakeCase (const True) $ do -- Jesper, 2018-12-10: print unsolved metas in dot patterns as _- localTC (\ e -> e { envPrintMetasBare = True }) $ do+ localTC (set ePrintMetasBare True) do -- Get function clause which contains the interaction point. InteractionPoint { ipMeta = mm, ipClause = ipCl} <- lookupInteractionPoint hole@@ -271,7 +289,35 @@ -- Andreas, 2019-08-08, issue #3966 -- Kill the ranges of the existing clauses to prevent wrong error -- location to be set by the coverage checker (via isCovered)- -- for test/interaction/Issue191+ -- for test/Interaction/Issue191++ -- See below, CLEAN UP OF THE GENERATED CLAUSES+ let+ filterOutExistingClauses :: [(SplitClause,a)] -> TCM [(SplitClause,a)]+ filterOutExistingClauses scs = do+ -- 1. filter out the generated clauses that are already covered+ -- we consider a generated clause already covered if it is covered by:+ -- a. a pre-existing clause defined before the one we splitted (prevClauses)+ -- b. a pre-existing clause defined after the one we splitted (follClauses)+ -- under the condition that it did not cover the one we splitted but was+ -- covered by it (i.e. it was considered unreachable).+ -- The key idea here is:+ -- f m zero = ? ---- split on m ---> f (suc m) zero = ?+ -- f zero zero = ? f zero zero = ?+ -- f _ _ = ? f _ _ = ?+ -- because [f zero zero] is already defined.+ -- However we ignore [f _ _]: [f m zero] was already a refinement of it,+ -- hinting that we considered it more important than the catchall.+ reportSDoc "interaction.case.filter" 20 $ vcat+ [ "prevClauses:"+ , nest 2 $ vcat $ map prettyTCM prevClauses+ ]+ let sclause = clauseToSplitClause clause+ fcs <- filterM (\ cl -> (isCovered f [clause] (clauseToSplitClause cl)) `and2M`+ (not <$> isCovered f [cl] sclause))+ follClauses+ filterM (not <.> isCovered f (prevClauses ++ fcs) . fst) scs+ let perm = fromMaybe __IMPOSSIBLE__ $ clausePerm clause tel = clauseTel clause ps = namedClausePats clause@@ -340,7 +386,7 @@ -- if any of them is shown by the printer imp <- optShowImplicit <$> pragmaOptions return $ imp || any visible (telToList piTel)- scs <- if newPats then return [sc] else postProjInExtLam $ do+ scs <- if newPats then pure [sc] else postProjInExtLam $ do res <- splitResult f sc case res of @@ -358,7 +404,7 @@ typeError $ SplitError err -- Otherwise, we make these user-written let xs = map (dbPatVarIndex . namedArg) trailingPatVars- return [makePatternVarsVisible xs sc]+ return [makePatternVarsVisible [] xs sc] Right cov -> ifNotM (optCopatterns <$> pragmaOptions) failNoCop $ {-else-} do -- Andreas, 2016-05-03: do not introduce function arguments after projection.@@ -371,22 +417,31 @@ -- When result splitting yields no clauses, replace rhs by @record{}@. if null scs then return [ A.spineToLhs $ absCl{ A.clauseRHS = makeRHSEmptyRecord rhs } ]- else mapM (makeAbstractClause f rhs ell) scs+ else do+ scs <- map fst <$> filterOutExistingClauses (map (, ()) scs)+ mapM (makeAbstractClause f rhs ell) scs else do -- split on variables xs <- parseVariables f clauseCxt clauseAsBindings hole rng vars reportSLn "interaction.case" 30 $ "parsedVariables: " ++ show (zip xs vars) -- Variables that are not in scope yet are brought into scope (@toShow@) -- The other variables are split on (@toSplit@).- let (toShow, toSplit) = partitionEithers $ for (zip xs vars) $ \ ((x,nis), s) ->- if (nis == C.NotInScope) then Left x else Right x- let sc = makePatternVarsVisible toShow $ clauseToSplitClause clause+ let (toDotP, toShow, toSplit) = mapEither3 splitActionToEither3 xs+ let sc0 = clauseToSplitClause clause+ let sc = makePatternVarsVisible toDotP toShow sc0+ reportSLn "interaction.case" 30 $ "toDot = " ++ prettyShow toDotP+ reportSLn "interaction.case" 30 $ "splitclause before makePatternVarsVisible: " ++ prettyShow sc0+ reportSLn "interaction.case" 30 $ "splitclause after: " ++ prettyShow sc+ reportSLn "interaction.case" 60 $ "splitclause before makePatternVarsVisible: " ++ show (killRange $ scPats sc0)+ reportSLn "interaction.case" 60 $ "splitclause after: " ++ show (killRange $ scPats sc) scs <- split f toSplit sc reportSLn "interaction.case" 70 $ "makeCase: survived the splitting" -- If any of the split variables is hidden by the ellipsis, we -- should force the expansion of the ellipsis.- let splitNames = map (\i -> ctxEntryName $ clauseCxt !! i) toSplit+ let splitNames =+ map (ctxEntryName . fromMaybe __IMPOSSIBLE__ . (`cxLookup` clauseCxt))+ toSplit shouldExpandEllipsis <- return (not $ null toShow) `or2M` anyEllipsisVar f absCl splitNames let ell' | shouldExpandEllipsis = NoEllipsis | otherwise = ell@@ -405,11 +460,7 @@ -- because [f zero zero] is already defined. -- However we ignore [f _ _]: [f m zero] was already a refinement of it, -- hinting that we considered it more important than the catchall.- let sclause = clauseToSplitClause clause- fcs <- filterM (\ cl -> (isCovered f [clause] (clauseToSplitClause cl)) `and2M`- (not <$> isCovered f [cl] sclause))- follClauses- scs <- filterM (not <.> isCovered f (prevClauses ++ fcs) . fst) scs+ scs <- filterOutExistingClauses scs reportSLn "interaction.case" 70 $ "makeCase: survived filtering out already covered clauses" -- 2. filter out trivially impossible clauses not asked for by the user cs <- catMaybes <$> do@@ -468,9 +519,8 @@ -- | Make the given pattern variables visible by marking their origin as -- 'CaseSplit' and pattern origin as 'PatOSplit' in the 'SplitClause'.-makePatternVarsVisible :: [Nat] -> SplitClause -> SplitClause-makePatternVarsVisible [] sc = sc-makePatternVarsVisible is sc@SClause{ scPats = ps } =+makePatternVarsVisible :: [Name] -> [Nat] -> SplitClause -> SplitClause+makePatternVarsVisible xs is sc@SClause{ scPats = ps } = sc{ scPats = mapNamedArgPattern mkVis ps } where mkVis :: NamedArg SplitPattern -> NamedArg SplitPattern@@ -480,6 +530,8 @@ -- if visible ai then __IMPOSSIBLE__ else -- or passing the parsed name along and comparing it with @x@ Arg (setOrigin CaseSplit ai) $ Named n $ VarP (PatternInfo PatOSplit []) $ SplitPatVar x i ls+ mkVis (Arg ai (Named n (DotP (PatternInfo (PatOVar x) _) v)))+ | x `elem` xs = Arg ai (Named n (DotP (PatternInfo PatOSplit []) v)) mkVis np = np -- | If a copattern split yields no clauses, we must be at an empty record type.@@ -495,30 +547,57 @@ makeAbsurdClause :: QName -> ExpandedEllipsis -> SplitClause -> TCM A.Clause makeAbsurdClause f ell (SClause tel sps _ _ t) = do- let ps = fromSplitPatterns sps- reportSDoc "interaction.case" 10 $ vcat- [ "Interaction.MakeCase.makeAbsurdClause: split clause:"- , nest 2 $ vcat- [ "context =" <+> do (inTopContext . prettyTCM) =<< getContextTelescope- , "tel =" <+> do inTopContext $ prettyTCM tel- , "ps =" <+> do inTopContext $ addContext tel $ prettyTCMPatternList ps -- P.sep <$> prettyTCMPatterns ps- , "ell =" <+> text (show ell)- ]- ]- withCurrentModule (qnameModule f) $- inTopContext $ reify $ QNamed f $ Clause+ showImp <- showImplicitArguments+ let+ ps = fromSplitPatterns sps+ ps' = applyWhen showImp filterOutGeneralizedVarPatterns ps+ -- Internal clause+ cl = Clause { clauseLHSRange = noRange , clauseFullRange = noRange , clauseTel = tel- , namedClausePats = ps+ , namedClausePats = ps' , clauseBody = Nothing , clauseType = argFromDom <$> t , clauseCatchall = empty- , clauseRecursive = Nothing+ , clauseRecursive = MaybeRecursive , clauseUnreachable = Nothing , clauseEllipsis = ell , clauseWhereModule = Nothing }+ reportSDoc "interaction.case" 10 $ vcat+ [ "Interaction.MakeCase.makeAbsurdClause: split clause:"+ , nest 2 $ vcat+ [ "context =" <+> do (inTopContext . prettyTCM) =<< getContextTelescope+ , "tel =" <+> do inTopContext $ prettyTCM tel+ , "ps =" <+> do inTopContext $ addContext tel $ prettyTCMPatternList ps -- P.sep <$> prettyTCMPatterns ps+ , "ps' =" <+> do inTopContext $ addContext tel $ prettyTCMPatternList ps'+ , "ell =" <+> text (show ell)+ ]+ ]+ reportSDoc "interaction.case" 10 $+ nest 2 $ vcat+ [ "ps (raw)=" <+> text (show ps)+ ]+ withCurrentModule (qnameModule f) $+ inTopContext $ reify $ QNamed f cl++-- | Drop hidden patterns introduced by generalization with an unparsable name.+-- If we drop one, we need to make the next non-dropped hidden pattern named.+filterOutGeneralizedVarPatterns :: [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]+filterOutGeneralizedVarPatterns = go False+ where+ go b [] = []+ go b (p : ps)+ | maybe False (isGeneralizedVarName . prettyShow) (getNameOf p) = go True ps+ | otherwise = applyWhen (b && getHiding p == Hidden) makeNamedArgUserWritten p : go False ps++makeNamedArgUserWritten :: NamedArg a -> NamedArg a+makeNamedArgUserWritten (Arg info (Named n a)) = Arg info (Named (setOrigin UserWritten <$> n) a)++-- | Unparseable variable names are those that contain a '.'.+isGeneralizedVarName :: PatVarName -> Bool+isGeneralizedVarName = elem '.' -- | Make a clause with a question mark as rhs.
src/full/Agda/Interaction/Monad.hs view
@@ -13,11 +13,7 @@ import Control.Monad.Except (MonadError (..)) import Control.Monad.Trans (MonadIO, lift, liftIO) import qualified System.Console.Haskeline as Haskeline---- MonadException is replaced by MonadCatch in haskeline 0.8-#if MIN_VERSION_haskeline(0,8,0) import qualified Control.Monad.Catch as Haskeline (catch)-#endif import Agda.TypeChecking.Monad ( HasOptions@@ -27,7 +23,7 @@ , MonadTCState , ReadTCState , TCErr- , TCM, TCMT(..)+ , type TCM, pattern TCM, TCMT, unTCM , mapTCMT )
+ src/full/Agda/Interaction/Options/Arguments.hs view
@@ -0,0 +1,102 @@+-- | Definitions and tools for arguments of command-line options.++module Agda.Interaction.Options.Arguments where++import Data.Map (Map)+import Data.Map qualified as Map++import Agda.Interaction.Options.Help (allHelpTopics)+import Agda.Interaction.Options.ProfileOptions (validProfileOptionStrings)+import Agda.Interaction.Options.Warnings (warningNameToString, warningSets)+import Agda.Setup.EmacsMode qualified as EmacsMode (setupFlag, compileFlag, locateFlag)++-- * Names of the arguments of options that have a finite enumeration.++-- | Print the possible values of an argument of the given type.+optionValues :: Map String [String]+optionValues = Map.fromList $+ ( colorArg , colorValues ) :+ ( emacsModeArg , emacsModeValues ) :+ ( helpArg , helpValues ) :+ ( profileArg , profileValues ) :+ ( traceImportsArg , traceImportsValues ) :+ ( warningArg , warningValues ) :+ ( erasedMatchesArg, erasedMatchesValues) :+ []++-- ** @--color@++-- | Argument to @--color@.+colorArg :: String+colorArg = "COLOR_MODE"++-- | Possible values for @--color@.+colorValues :: [String]+colorValues = [ "always", "auto", "never" ]++-- ** @--emacs-mode@++-- | Argument to @--emacs-mode@.+emacsModeArg :: String+emacsModeArg = "EMACS_MODE_COMMAND"++-- | Possible values for @--emacs-mode@.+emacsModeValues :: [String]+emacsModeValues = [EmacsMode.setupFlag, EmacsMode.compileFlag, EmacsMode.locateFlag]++-- ** @--erased-matches@++-- | The argument to @--erased-matches@.++erasedMatchesArg :: String+erasedMatchesArg = "MATCH_KINDS"++-- | Possible values for @--erased-matches@.++erasedMatchesValues :: [String]+erasedMatchesValues =+ ["none", "empty", "non-dependent", "restricted", "unrestricted"]++-- ** @--help@++-- | Argument to @--help@.+helpArg :: String+helpArg = "HELP_TOPIC"++-- | Possible values for @--help@.+helpValues :: [String]+helpValues = map fst allHelpTopics++-- ** @--profile@++-- | Argument to @--profile@.+profileArg :: String+profileArg = "TO_PROFILE"++-- | Possible values for @--profile@.+profileValues :: [String]+profileValues = validProfileOptionStrings++-- ** @--trace-imports@++-- | Argument to @--trace-imports@.+traceImportsArg :: String+traceImportsArg = "IMPORT_TRACING_LEVEL"++-- | Possible values for @--trace-imports@.+traceImportsValues :: [String]+traceImportsValues = [ show n | n <- [0..3] ]++-- ** @--warning@++-- | Argument to @--warning@.+warningArg :: String+warningArg = "WARNING"++-- | Possible values for @--warning@.+warningValues :: [String]+warningValues = concat $+ map fst warningSets :+ map (\ w -> [w, "no" ++ w]) ws+ where+ ws = "error" : map warningNameToString [minBound..maxBound]
src/full/Agda/Interaction/Options/Base.hs view
@@ -2,1872 +2,2224 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE PartialTypeSignatures #-} -{-# OPTIONS_GHC -Wno-partial-type-signatures #-}-{-# OPTIONS_GHC -Wno-missing-signatures #-}--module Agda.Interaction.Options.Base- ( CommandLineOptions(..)- , PragmaOptions(..)- , OptionError- , OptionWarning(..), optionWarningName- , Flag, OptM, runOptM, OptDescr(..), ArgDescr(..)- , Verbosity, VerboseKey, VerboseLevel- , ConfluenceCheck(..)- , DiagnosticsColours(..)- , EmacsModeCommand(..)- , PrintAgdaVersion(..)- , UnicodeOrAscii(..)- , WarningMode(..)- , checkOpts- , parsePragmaOptions- , parsePluginOptions- , parseVerboseKey- , stripRTS- , defaultOptions- , defaultInteractionOptions- , defaultCutOff- , defaultPragmaOptions- , standardOptions_- , unsafePragmaOptions- , recheckBecausePragmaOptionsChanged- , InfectiveCoinfective(..)- , InfectiveCoinfectiveOption(..)- , infectiveCoinfectiveOptions- , ImpliedPragmaOption(..)- , impliedPragmaOptions- , safeFlag- , mapFlag- , usage- -- Reused by PandocAgda- , inputFlag- , standardOptions, deadStandardOptions- , getOptSimple- -- * Lenses for 'PragmaOptions'- , lensOptShowImplicit- , lensOptShowIrrelevant- , lensOptUseUnicode- , lensOptVerbose- , lensOptProfiling- , lensOptProp- , lensOptLevelUniverse- , lensOptTwoLevel- , lensOptAllowUnsolved- , lensOptAllowIncompleteMatch- , lensOptPositivityCheck- , lensOptTerminationCheck- , lensOptTerminationDepth- , lensOptUniverseCheck, lensOptNoUniverseCheck- , lensOptOmegaInOmega- , lensOptCumulativity- , lensOptSizedTypes- , lensOptGuardedness- , lensOptInjectiveTypeConstructors- , lensOptUniversePolymorphism- , lensOptIrrelevantProjections- , lensOptExperimentalIrrelevance- , lensOptExperimentalLazyInstances- , lensOptWithoutK- , lensOptCubicalCompatible- , lensOptCopatterns- , lensOptPatternMatching- , lensOptExactSplit- , lensOptHiddenArgumentPuns- , lensOptEta- , lensOptForcing- , lensOptProjectionLike- , lensOptErasure- , lensOptErasedMatches- , lensOptEraseRecordParameters- , lensOptRewriting- , lensOptCubical- , lensOptGuarded- , lensOptFirstOrder- , lensOptRequireUniqueMetaSolutions- , lensOptPostfixProjections- , lensOptKeepPatternVariables- , lensOptInferAbsurdClauses- , lensOptInstanceSearchDepth- , lensOptBacktrackingInstances- , lensOptQualifiedInstances- , lensOptInversionMaxDepth- , lensOptSafe- , lensOptDoubleCheck- , lensOptSyntacticEquality- , lensOptWarningMode- , lensOptCompileMain- , lensOptCaching- , lensOptCountClusters- , lensOptAutoInline- , lensOptPrintPatternSynonyms- , lensOptFastReduce- , lensOptCallByName- , lensOptConfluenceCheck- , lensOptCohesion- , lensOptFlatSplit- , lensOptPolarity- , lensOptImportSorts- , lensOptLoadPrimitives- , lensOptAllowExec- , lensOptSaveMetas- , lensOptShowIdentitySubstitutions- , lensOptKeepCoveringClauses- -- * Boolean accessors to 'PragmaOptions' collapsing default- , optShowImplicit- , optShowGeneralized- , optShowIrrelevant- , optProp- , optLevelUniverse- , optTwoLevel- , optAllowUnsolved- , optAllowIncompleteMatch- , optPositivityCheck- , optTerminationCheck- , optUniverseCheck- , optOmegaInOmega- , optCumulativity- , optSizedTypes- , optGuardedness- , optInjectiveTypeConstructors- , optUniversePolymorphism- , optIrrelevantProjections- , optExperimentalIrrelevance- , optWithoutK- , optCubicalCompatible- , optCopatterns- , optPatternMatching- , optHiddenArgumentPuns- , optEta- , optForcing- , optProjectionLike- , optErasure- , optErasedMatches- , optEraseRecordParameters- , optRewriting- , optGuarded- , optFirstOrder- , optRequireUniqueMetaSolutions- , optPostfixProjections- , optKeepPatternVariables- , optInferAbsurdClauses- , optBacktrackingInstances- , optQualifiedInstances- , optSafe- , optDoubleCheck- , optCompileNoMain- , optCaching- , optCountClusters- , optAutoInline- , optPrintPatternSynonyms- , optFastReduce- , optCallByName- , optCohesion- , optFlatSplit- , optPolarity- , optImportSorts- , optLoadPrimitives- , optAllowExec- , optSaveMetas- , optShowIdentitySubstitutions- , optKeepCoveringClauses- , optLargeIndices- , optForcedArgumentRecursion- -- * Non-boolean accessors to 'PragmaOptions'- , optConfluenceCheck- , optCubical- , optInstanceSearchDepth- , optInversionMaxDepth- , optProfiling- , optSyntacticEquality- , optTerminationDepth- , optUseUnicode- , optVerbose- , optWarningMode- ) where--import Prelude hiding ( null, not, (&&), (||) )--import Control.DeepSeq-import Control.Monad ( (>=>), when, unless, void )-import Control.Monad.Except ( ExceptT, MonadError(throwError), runExceptT )-import Control.Monad.Writer ( Writer, runWriter, MonadWriter(..) )--import Data.Function ( (&) )-import Data.List ( intercalate )-import Data.Maybe-import Data.Map ( Map )-import qualified Data.Map as Map-import Data.Set ( Set )-import qualified Data.Set as Set-import qualified Data.Text as T--import GHC.Generics (Generic)--import Agda.Utils.GetOpt ( getOpt', usageInfo, ArgOrder(ReturnInOrder)- , OptDescr(..), ArgDescr(..)- )-import qualified System.IO.Unsafe as UNSAFE (unsafePerformIO)--import Text.EditDistance-import Text.Read ( readMaybe )--import Agda.Termination.CutOff ( CutOff(..), defaultCutOff )--import Agda.Interaction.Library ( ExeName, LibName, OptionsPragma(..), parseLibName )-import Agda.Interaction.Options.Help- ( Help(HelpFor, GeneralHelp)- , string2HelpTopic- , allHelpTopics- , helpTopicUsage- )-import Agda.Interaction.Options.Types-import Agda.Interaction.Options.Warnings--import Agda.Syntax.Concrete.Glyph ( unsafeSetUnicodeOrAscii, UnicodeOrAscii(..) )-import Agda.Syntax.Common (Cubical(..))-import Agda.Syntax.Common.Pretty-import Agda.Syntax.TopLevelModuleName (TopLevelModuleName)--import qualified Agda.Setup.EmacsMode as EmacsMode--import Agda.Utils.Boolean-import Agda.Utils.FileName ( AbsolutePath )-import Agda.Utils.Function ( applyWhen, applyUnless )-import Agda.Utils.Functor ( (<&>) )-import Agda.Utils.Lens ( Lens', (^.), over, set )-import Agda.Utils.List ( headWithDefault, initLast1 )-import Agda.Utils.List1 ( List1, String1, pattern (:|), 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.ProfileOptions-import Agda.Utils.String ( unwords1 )-import qualified Agda.Utils.String as String-import Agda.Utils.Trie ( Trie )-import qualified Agda.Utils.Trie as Trie-import Agda.Utils.TypeLits-import Agda.Utils.WithDefault--import Agda.Utils.Impossible--import Agda.Version--parseVerboseKey :: VerboseKey -> [VerboseKeyItem]-parseVerboseKey = List1.wordsBy (`elem` ['.', ':'])--data ImpliedPragmaOption where- ImpliesPragmaOption- :: String -> Bool -> (PragmaOptions -> WithDefault a)- -> String -> Bool -> (PragmaOptions -> WithDefault b)- -> ImpliedPragmaOption- -- ^ The first option having the given value implies the second option having its given value.- -- For instance, `ImpliesPragmaOption "lossy-unification" True _optFirstOrder- -- "require-unique-meta-solutions" False _optRequireUniqueMetaSolutions`- -- encodes the fact that --lossy-unification implies --no-require-unique-meta-solutions.--impliedPragmaOptions :: [ImpliedPragmaOption]-impliedPragmaOptions =- [ ("erase-record-parameters", _optEraseRecordParameters) ==> ("erasure", _optErasure)- , ("erased-matches", _optErasedMatches) ==> ("erasure", _optErasure)- , ("flat-split", _optFlatSplit) ==> ("cohesion", _optCohesion)- , ("no-load-primitives", _optLoadPrimitives) ==> ("no-import-sorts", _optImportSorts)- , ("lossy-unification", _optFirstOrder) ==> ("no-require-unique-meta-solutions", _optRequireUniqueMetaSolutions)- ]- where- yesOrNo ('n':'o':'-':s) = (False, s)- yesOrNo s = (True, s)- (nameA, optA) ==> (nameB, optB) = ImpliesPragmaOption stemA valA optA stemB valB optB- where- (valA, stemA) = yesOrNo nameA- (valB, stemB) = yesOrNo nameB---- collapse defaults-optShowImplicit :: PragmaOptions -> Bool-optShowGeneralized :: PragmaOptions -> Bool-optShowIrrelevant :: PragmaOptions -> Bool-optProp :: PragmaOptions -> Bool-optLevelUniverse :: PragmaOptions -> Bool-optTwoLevel :: PragmaOptions -> Bool-optAllowUnsolved :: PragmaOptions -> Bool-optAllowIncompleteMatch :: PragmaOptions -> Bool-optPositivityCheck :: PragmaOptions -> Bool-optTerminationCheck :: PragmaOptions -> Bool-optUniverseCheck :: PragmaOptions -> Bool-optOmegaInOmega :: PragmaOptions -> Bool-optCumulativity :: PragmaOptions -> Bool-optSizedTypes :: PragmaOptions -> Bool-optGuardedness :: PragmaOptions -> Bool-optInjectiveTypeConstructors :: PragmaOptions -> Bool-optUniversePolymorphism :: PragmaOptions -> Bool-optIrrelevantProjections :: PragmaOptions -> Bool-optExperimentalIrrelevance :: PragmaOptions -> Bool-optWithoutK :: PragmaOptions -> Bool-optCubicalCompatible :: PragmaOptions -> Bool-optCopatterns :: PragmaOptions -> Bool-optPatternMatching :: PragmaOptions -> Bool-optHiddenArgumentPuns :: PragmaOptions -> Bool-optEta :: PragmaOptions -> Bool-optForcing :: PragmaOptions -> Bool-optProjectionLike :: PragmaOptions -> Bool--- | 'optErasure' is implied by 'optEraseRecordParameters'.--- 'optErasure' is also implied by an explicitly given `--erased-matches`.-optErasure :: PragmaOptions -> Bool-optErasedMatches :: PragmaOptions -> Bool-optEraseRecordParameters :: PragmaOptions -> Bool-optRewriting :: PragmaOptions -> Bool-optGuarded :: PragmaOptions -> Bool-optFirstOrder :: PragmaOptions -> Bool-optRequireUniqueMetaSolutions :: PragmaOptions -> Bool-optPostfixProjections :: PragmaOptions -> Bool-optKeepPatternVariables :: PragmaOptions -> Bool-optInferAbsurdClauses :: PragmaOptions -> Bool-optBacktrackingInstances :: PragmaOptions -> Bool-optQualifiedInstances :: PragmaOptions -> Bool-optSafe :: PragmaOptions -> Bool-optDoubleCheck :: PragmaOptions -> Bool-optCompileNoMain :: PragmaOptions -> Bool-optCaching :: PragmaOptions -> Bool-optCountClusters :: PragmaOptions -> Bool-optAutoInline :: PragmaOptions -> Bool-optPrintPatternSynonyms :: PragmaOptions -> Bool-optFastReduce :: PragmaOptions -> Bool-optCallByName :: PragmaOptions -> Bool--- | 'optCohesion' is implied by 'optFlatSplit'.-optCohesion :: PragmaOptions -> Bool-optFlatSplit :: PragmaOptions -> Bool-optPolarity :: PragmaOptions -> Bool--- | 'optImportSorts' requires 'optLoadPrimitives'.-optImportSorts :: PragmaOptions -> Bool-optLoadPrimitives :: PragmaOptions -> Bool-optAllowExec :: PragmaOptions -> Bool-optSaveMetas :: PragmaOptions -> Bool-optShowIdentitySubstitutions :: PragmaOptions -> Bool-optKeepCoveringClauses :: PragmaOptions -> Bool-optLargeIndices :: PragmaOptions -> Bool-optForcedArgumentRecursion :: PragmaOptions -> Bool--optShowImplicit = collapseDefault . _optShowImplicit-optShowGeneralized = collapseDefault . _optShowGeneralized-optShowIrrelevant = collapseDefault . _optShowIrrelevant-optProp = collapseDefault . _optProp-optLevelUniverse = collapseDefault . _optLevelUniverse-optTwoLevel = collapseDefault . _optTwoLevel-optAllowUnsolved = collapseDefault . _optAllowUnsolved-optAllowIncompleteMatch = collapseDefault . _optAllowIncompleteMatch-optPositivityCheck = collapseDefault . _optPositivityCheck-optTerminationCheck = collapseDefault . _optTerminationCheck-optUniverseCheck = collapseDefault . _optUniverseCheck-optOmegaInOmega = collapseDefault . _optOmegaInOmega-optCumulativity = collapseDefault . _optCumulativity-optSizedTypes = collapseDefault . _optSizedTypes-optGuardedness = collapseDefault . _optGuardedness-optInjectiveTypeConstructors = collapseDefault . _optInjectiveTypeConstructors-optUniversePolymorphism = collapseDefault . _optUniversePolymorphism-optIrrelevantProjections = collapseDefault . _optIrrelevantProjections-optExperimentalIrrelevance = collapseDefault . _optExperimentalIrrelevance-optWithoutK = collapseDefault . _optWithoutK-optCubicalCompatible = collapseDefault . _optCubicalCompatible-optCopatterns = collapseDefault . _optCopatterns-optPatternMatching = collapseDefault . _optPatternMatching-optHiddenArgumentPuns = collapseDefault . _optHiddenArgumentPuns-optEta = collapseDefault . _optEta-optForcing = collapseDefault . _optForcing-optProjectionLike = collapseDefault . _optProjectionLike--- --erase-record-parameters implies --erasure-optErasure = collapseDefault . _optErasure || optEraseRecordParameters || (Value True ==) . _optErasedMatches-optErasedMatches = collapseDefault . _optErasedMatches && optErasure-optEraseRecordParameters = collapseDefault . _optEraseRecordParameters-optRewriting = collapseDefault . _optRewriting-optGuarded = collapseDefault . _optGuarded-optFirstOrder = collapseDefault . _optFirstOrder-optRequireUniqueMetaSolutions = collapseDefault . _optRequireUniqueMetaSolutions && not . optFirstOrder--- --lossy-unification implies --no-require-unique-meta-solutions-optPostfixProjections = collapseDefault . _optPostfixProjections-optKeepPatternVariables = collapseDefault . _optKeepPatternVariables-optInferAbsurdClauses = collapseDefault . _optInferAbsurdClauses-optBacktrackingInstances = collapseDefault . _optBacktrackingInstances-optQualifiedInstances = collapseDefault . _optQualifiedInstances-optSafe = collapseDefault . _optSafe-optDoubleCheck = collapseDefault . _optDoubleCheck-optCompileNoMain = not . collapseDefault . _optCompileMain-optCaching = collapseDefault . _optCaching-optCountClusters = collapseDefault . _optCountClusters-optAutoInline = collapseDefault . _optAutoInline-optPrintPatternSynonyms = collapseDefault . _optPrintPatternSynonyms-optFastReduce = collapseDefault . _optFastReduce-optCallByName = collapseDefault . _optCallByName--- --flat-split implies --cohesion-optCohesion = collapseDefault . _optCohesion || optFlatSplit-optFlatSplit = collapseDefault . _optFlatSplit-optPolarity = collapseDefault . _optPolarity--- --no-load-primitives implies --no-import-sorts-optImportSorts = collapseDefault . _optImportSorts && optLoadPrimitives-optLoadPrimitives = collapseDefault . _optLoadPrimitives-optAllowExec = collapseDefault . _optAllowExec-optSaveMetas = collapseDefault . _optSaveMetas-optShowIdentitySubstitutions = collapseDefault . _optShowIdentitySubstitutions-optKeepCoveringClauses = collapseDefault . _optKeepCoveringClauses-optLargeIndices = collapseDefault . _optLargeIndices-optForcedArgumentRecursion = collapseDefault . _optForcedArgumentRecursion---- Collapse defaults (non-Bool)--optUseUnicode :: PragmaOptions -> UnicodeOrAscii-optUseUnicode = collapseDefault . _optUseUnicode---- Extra trivial accessors (keep in alphabetical order)--optConfluenceCheck :: PragmaOptions -> _-optCubical :: PragmaOptions -> _-optInstanceSearchDepth :: PragmaOptions -> _-optInversionMaxDepth :: PragmaOptions -> _-optProfiling :: PragmaOptions -> _-optSyntacticEquality :: PragmaOptions -> _-optTerminationDepth :: PragmaOptions -> _-optVerbose :: PragmaOptions -> _-optWarningMode :: PragmaOptions -> _--optConfluenceCheck = _optConfluenceCheck-optCubical = _optCubical-optInstanceSearchDepth = _optInstanceSearchDepth-optInversionMaxDepth = _optInversionMaxDepth-optProfiling = _optProfiling-optSyntacticEquality = _optSyntacticEquality-optTerminationDepth = _optTerminationDepth-optVerbose = _optVerbose-optWarningMode = _optWarningMode---- Lenses for PragmaOptions--- N.B.: We use PartialTypeSignatures here to not repeat default values (DRY!).--lensOptShowImplicit :: Lens' PragmaOptions _-lensOptShowImplicit f o = f (_optShowImplicit o) <&> \ i -> o{ _optShowImplicit = i }--lensOptShowIrrelevant :: Lens' PragmaOptions _-lensOptShowIrrelevant f o = f (_optShowIrrelevant o) <&> \ i -> o{ _optShowIrrelevant = i }--lensOptUseUnicode :: Lens' PragmaOptions _-lensOptUseUnicode f o = f (_optUseUnicode o) <&> \ i -> o{ _optUseUnicode = i }--lensOptVerbose :: Lens' PragmaOptions _-lensOptVerbose f o = f (_optVerbose o) <&> \ i -> o{ _optVerbose = i }--lensOptProfiling :: Lens' PragmaOptions _-lensOptProfiling f o = f (_optProfiling o) <&> \ i -> o{ _optProfiling = i }--lensOptProp :: Lens' PragmaOptions _-lensOptProp f o = f (_optProp o) <&> \ i -> o{ _optProp = i }--lensOptLevelUniverse :: Lens' PragmaOptions _-lensOptLevelUniverse f o = f (_optLevelUniverse o) <&> \ i -> o{ _optLevelUniverse = i }--lensOptTwoLevel :: Lens' PragmaOptions _-lensOptTwoLevel f o = f (_optTwoLevel o) <&> \ i -> o{ _optTwoLevel = i }--lensOptAllowUnsolved :: Lens' PragmaOptions _-lensOptAllowUnsolved f o = f (_optAllowUnsolved o) <&> \ i -> o{ _optAllowUnsolved = i }--lensOptAllowIncompleteMatch :: Lens' PragmaOptions _-lensOptAllowIncompleteMatch f o = f (_optAllowIncompleteMatch o) <&> \ i -> o{ _optAllowIncompleteMatch = i }--lensOptPositivityCheck :: Lens' PragmaOptions _-lensOptPositivityCheck f o = f (_optPositivityCheck o) <&> \ i -> o{ _optPositivityCheck = i }--lensOptTerminationCheck :: Lens' PragmaOptions _-lensOptTerminationCheck f o = f (_optTerminationCheck o) <&> \ i -> o{ _optTerminationCheck = i }--lensOptTerminationDepth :: Lens' PragmaOptions _-lensOptTerminationDepth f o = f (_optTerminationDepth o) <&> \ i -> o{ _optTerminationDepth = i }--lensOptUniverseCheck :: Lens' PragmaOptions _-lensOptUniverseCheck f o = f (_optUniverseCheck o) <&> \ i -> o{ _optUniverseCheck = i }--lensOptNoUniverseCheck :: Lens' PragmaOptions _-lensOptNoUniverseCheck f o = f (mapValue not $ _optUniverseCheck o) <&> \ i -> o{ _optUniverseCheck = mapValue not i }--lensOptOmegaInOmega :: Lens' PragmaOptions _-lensOptOmegaInOmega f o = f (_optOmegaInOmega o) <&> \ i -> o{ _optOmegaInOmega = i }--lensOptCumulativity :: Lens' PragmaOptions _-lensOptCumulativity f o = f (_optCumulativity o) <&> \ i -> o{ _optCumulativity = i }--lensOptSizedTypes :: Lens' PragmaOptions _-lensOptSizedTypes f o = f (_optSizedTypes o) <&> \ i -> o{ _optSizedTypes = i }--lensOptGuardedness :: Lens' PragmaOptions _-lensOptGuardedness f o = f (_optGuardedness o) <&> \ i -> o{ _optGuardedness = i }--lensOptInjectiveTypeConstructors :: Lens' PragmaOptions _-lensOptInjectiveTypeConstructors f o = f (_optInjectiveTypeConstructors o) <&> \ i -> o{ _optInjectiveTypeConstructors = i }--lensOptUniversePolymorphism :: Lens' PragmaOptions _-lensOptUniversePolymorphism f o = f (_optUniversePolymorphism o) <&> \ i -> o{ _optUniversePolymorphism = i }--lensOptIrrelevantProjections :: Lens' PragmaOptions _-lensOptIrrelevantProjections f o = f (_optIrrelevantProjections o) <&> \ i -> o{ _optIrrelevantProjections = i }--lensOptExperimentalIrrelevance :: Lens' PragmaOptions _-lensOptExperimentalIrrelevance f o = f (_optExperimentalIrrelevance o) <&> \ i -> o{ _optExperimentalIrrelevance = i }--lensOptWithoutK :: Lens' PragmaOptions _-lensOptWithoutK f o = f (_optWithoutK o) <&> \ i -> o{ _optWithoutK = i }--lensOptCubicalCompatible :: Lens' PragmaOptions _-lensOptCubicalCompatible f o = f (_optCubicalCompatible o) <&> \ i -> o{ _optCubicalCompatible = i }--lensOptCopatterns :: Lens' PragmaOptions _-lensOptCopatterns f o = f (_optCopatterns o) <&> \ i -> o{ _optCopatterns = i }--lensOptPatternMatching :: Lens' PragmaOptions _-lensOptPatternMatching f o = f (_optPatternMatching o) <&> \ i -> o{ _optPatternMatching = i }--lensOptExactSplit :: Lens' PragmaOptions _-lensOptExactSplit f o = f (_optExactSplit o) <&> \ i -> o{ _optExactSplit = i }--lensOptHiddenArgumentPuns :: Lens' PragmaOptions _-lensOptHiddenArgumentPuns f o = f (_optHiddenArgumentPuns o) <&> \ i -> o{ _optHiddenArgumentPuns = i }--lensOptEta :: Lens' PragmaOptions _-lensOptEta f o = f (_optEta o) <&> \ i -> o{ _optEta = i }--lensOptForcing :: Lens' PragmaOptions _-lensOptForcing f o = f (_optForcing o) <&> \ i -> o{ _optForcing = i }--lensOptProjectionLike :: Lens' PragmaOptions _-lensOptProjectionLike f o = f (_optProjectionLike o) <&> \ i -> o{ _optProjectionLike = i }--lensOptErasure :: Lens' PragmaOptions _-lensOptErasure f o = f (_optErasure o) <&> \ i -> o{ _optErasure = i }--lensOptErasedMatches :: Lens' PragmaOptions _-lensOptErasedMatches f o = f (_optErasedMatches o) <&> \ i -> o{ _optErasedMatches = i }--lensOptEraseRecordParameters :: Lens' PragmaOptions _-lensOptEraseRecordParameters f o = f (_optEraseRecordParameters o) <&> \ i -> o{ _optEraseRecordParameters = i }--lensOptRewriting :: Lens' PragmaOptions _-lensOptRewriting f o = f (_optRewriting o) <&> \ i -> o{ _optRewriting = i }--lensOptCubical :: Lens' PragmaOptions _-lensOptCubical f o = f (_optCubical o) <&> \ i -> o{ _optCubical = i }--lensOptGuarded :: Lens' PragmaOptions _-lensOptGuarded f o = f (_optGuarded o) <&> \ i -> o{ _optGuarded = i }--lensOptFirstOrder :: Lens' PragmaOptions _-lensOptFirstOrder f o = f (_optFirstOrder o) <&> \ i -> o{ _optFirstOrder = i }--lensOptRequireUniqueMetaSolutions :: Lens' PragmaOptions _-lensOptRequireUniqueMetaSolutions f o = f (_optRequireUniqueMetaSolutions o) <&> \ i -> o{ _optRequireUniqueMetaSolutions = i }--lensOptPostfixProjections :: Lens' PragmaOptions _-lensOptPostfixProjections f o = f (_optPostfixProjections o) <&> \ i -> o{ _optPostfixProjections = i }--lensOptKeepPatternVariables :: Lens' PragmaOptions _-lensOptKeepPatternVariables f o = f (_optKeepPatternVariables o) <&> \ i -> o{ _optKeepPatternVariables = i }--lensOptInferAbsurdClauses :: Lens' PragmaOptions _-lensOptInferAbsurdClauses f o = f (_optInferAbsurdClauses o) <&> \ i -> o{ _optInferAbsurdClauses = i }--lensOptInstanceSearchDepth :: Lens' PragmaOptions _-lensOptInstanceSearchDepth f o = f (_optInstanceSearchDepth o) <&> \ i -> o{ _optInstanceSearchDepth = i }--lensOptBacktrackingInstances :: Lens' PragmaOptions _-lensOptBacktrackingInstances f o = f (_optBacktrackingInstances o) <&> \ i -> o{ _optBacktrackingInstances = i }--lensOptQualifiedInstances :: Lens' PragmaOptions _-lensOptQualifiedInstances f o = f (_optQualifiedInstances o) <&> \ i -> o{ _optQualifiedInstances = i }--lensOptInversionMaxDepth :: Lens' PragmaOptions _-lensOptInversionMaxDepth f o = f (_optInversionMaxDepth o) <&> \ i -> o{ _optInversionMaxDepth = i }--lensOptSafe :: Lens' PragmaOptions _-lensOptSafe f o = f (_optSafe o) <&> \ i -> o{ _optSafe = i }--lensOptDoubleCheck :: Lens' PragmaOptions _-lensOptDoubleCheck f o = f (_optDoubleCheck o) <&> \ i -> o{ _optDoubleCheck = i }--lensOptSyntacticEquality :: Lens' PragmaOptions _-lensOptSyntacticEquality f o = f (_optSyntacticEquality o) <&> \ i -> o{ _optSyntacticEquality = i }--lensOptWarningMode :: Lens' PragmaOptions _-lensOptWarningMode f o = f (_optWarningMode o) <&> \ i -> o{ _optWarningMode = i }--lensOptCompileMain :: Lens' PragmaOptions _-lensOptCompileMain f o = f (_optCompileMain o) <&> \ i -> o{ _optCompileMain = i }--lensOptCaching :: Lens' PragmaOptions _-lensOptCaching f o = f (_optCaching o) <&> \ i -> o{ _optCaching = i }--lensOptCountClusters :: Lens' PragmaOptions _-lensOptCountClusters f o = f (_optCountClusters o) <&> \ i -> o{ _optCountClusters = i }--lensOptAutoInline :: Lens' PragmaOptions _-lensOptAutoInline f o = f (_optAutoInline o) <&> \ i -> o{ _optAutoInline = i }--lensOptPrintPatternSynonyms :: Lens' PragmaOptions _-lensOptPrintPatternSynonyms f o = f (_optPrintPatternSynonyms o) <&> \ i -> o{ _optPrintPatternSynonyms = i }--lensOptFastReduce :: Lens' PragmaOptions _-lensOptFastReduce f o = f (_optFastReduce o) <&> \ i -> o{ _optFastReduce = i }--lensOptCallByName :: Lens' PragmaOptions _-lensOptCallByName f o = f (_optCallByName o) <&> \ i -> o{ _optCallByName = i }--lensOptConfluenceCheck :: Lens' PragmaOptions _-lensOptConfluenceCheck f o = f (_optConfluenceCheck o) <&> \ i -> o{ _optConfluenceCheck = i }--lensOptCohesion :: Lens' PragmaOptions _-lensOptCohesion f o = f (_optCohesion o) <&> \ i -> o{ _optCohesion = i }--lensOptFlatSplit :: Lens' PragmaOptions _-lensOptFlatSplit f o = f (_optFlatSplit o) <&> \ i -> o{ _optFlatSplit = i }--lensOptPolarity :: Lens' PragmaOptions _-lensOptPolarity f o = f (_optPolarity o) <&> \ i -> o{ _optPolarity = i}--lensOptImportSorts :: Lens' PragmaOptions _-lensOptImportSorts f o = f (_optImportSorts o) <&> \ i -> o{ _optImportSorts = i }--lensOptLoadPrimitives :: Lens' PragmaOptions _-lensOptLoadPrimitives f o = f (_optLoadPrimitives o) <&> \ i -> o{ _optLoadPrimitives = i }--lensOptAllowExec :: Lens' PragmaOptions _-lensOptAllowExec f o = f (_optAllowExec o) <&> \ i -> o{ _optAllowExec = i }--lensOptSaveMetas :: Lens' PragmaOptions _-lensOptSaveMetas f o = f (_optSaveMetas o) <&> \ i -> o{ _optSaveMetas = i }--lensOptShowIdentitySubstitutions :: Lens' PragmaOptions _-lensOptShowIdentitySubstitutions f o = f (_optShowIdentitySubstitutions o) <&> \ i -> o{ _optShowIdentitySubstitutions = i }--lensOptKeepCoveringClauses :: Lens' PragmaOptions _-lensOptKeepCoveringClauses f o = f (_optKeepCoveringClauses o) <&> \ i -> o{ _optKeepCoveringClauses = i }--lensOptLargeIndices :: Lens' PragmaOptions _-lensOptLargeIndices f o = f (_optLargeIndices o) <&> \ i -> o{ _optLargeIndices = i }--lensOptForcedArgumentRecursion :: Lens' PragmaOptions _-lensOptForcedArgumentRecursion f o = f (_optForcedArgumentRecursion o) <&> \ i -> o{ _optForcedArgumentRecursion = i }--lensOptExperimentalLazyInstances :: Lens' PragmaOptions _-lensOptExperimentalLazyInstances f o = f (_optExperimentalLazyInstances o) <&> \ i -> o{ _optExperimentalLazyInstances = i }----- | Map a function over the long options. Also removes the short options.--- Will be used to add the plugin name to the plugin options.-mapFlag :: (String -> String) -> OptDescr a -> OptDescr a-mapFlag f (Option _ long arg descr) = Option [] (map f long) arg descr--defaultInteractionOptions :: PragmaOptions-defaultInteractionOptions = defaultPragmaOptions--defaultOptions :: CommandLineOptions-defaultOptions = Options- { optProgramName = "agda"- , optInputFile = Nothing- , optIncludePaths = []- , optAbsoluteIncludePaths = []- , optLibraries = []- , optOverrideLibrariesFile = Nothing- , optDefaultLibs = True- , optUseLibs = True- , optTraceImports = 1- , optTrustedExecutables = Map.empty- , optPrintAgdaDataDir = False- , optPrintAgdaAppDir = False- , optPrintVersion = Nothing- , optPrintHelp = Nothing- , optBuildLibrary = False- , optSetup = False- , optEmacsMode = Set.empty- , optInteractive = False- , optGHCiInteraction = False- , optJSONInteraction = False- , optExitOnError = False- , optCompileDir = Nothing- , optGenerateVimFile = False- , optIgnoreInterfaces = False- , optIgnoreAllInterfaces = False- , optPragmaOptions = defaultPragmaOptions- , optOnlyScopeChecking = False- , optTransliterate = False- , optDiagnosticsColour = AutoColour- }--defaultPragmaOptions :: PragmaOptions-defaultPragmaOptions = PragmaOptions- { _optShowImplicit = Default- , _optShowGeneralized = Default- , _optShowIrrelevant = Default- , _optUseUnicode = Default -- UnicodeOk- , _optVerbose = Strict.Nothing- , _optProfiling = noProfileOptions- , _optProp = Default- , _optLevelUniverse = Default- , _optTwoLevel = Default- , _optAllowUnsolved = Default- , _optAllowIncompleteMatch = Default- , _optPositivityCheck = Default- , _optTerminationCheck = Default- , _optTerminationDepth = defaultCutOff- , _optUniverseCheck = Default- , _optOmegaInOmega = Default- , _optCumulativity = Default- , _optSizedTypes = Default- , _optGuardedness = Default- , _optInjectiveTypeConstructors = Default- , _optUniversePolymorphism = Default- , _optIrrelevantProjections = Default- , _optExperimentalIrrelevance = Default- , _optWithoutK = Default- , _optCubicalCompatible = Default- , _optCopatterns = Default- , _optPatternMatching = Default- , _optExactSplit = Default- , _optHiddenArgumentPuns = Default- , _optEta = Default- , _optForcing = Default- , _optProjectionLike = Default- , _optErasure = Default- , _optErasedMatches = Default- , _optEraseRecordParameters = Default- , _optRewriting = Default- , _optCubical = Nothing- , _optGuarded = Default- , _optFirstOrder = Default- , _optRequireUniqueMetaSolutions = Default- , _optPostfixProjections = Default- , _optKeepPatternVariables = Default- , _optInferAbsurdClauses = Default- , _optInstanceSearchDepth = 500- , _optBacktrackingInstances = Default- , _optQualifiedInstances = Default- , _optInversionMaxDepth = 50- , _optSafe = Default- , _optDoubleCheck = Default- , _optSyntacticEquality = Strict.Nothing- , _optWarningMode = defaultWarningMode- , _optCompileMain = Default- , _optCaching = Default- , _optCountClusters = Default- , _optAutoInline = Default- , _optPrintPatternSynonyms = Default- , _optFastReduce = Default- , _optCallByName = Default- , _optConfluenceCheck = Nothing- , _optCohesion = Default- , _optFlatSplit = Default- , _optPolarity = Default- , _optImportSorts = Default- , _optLoadPrimitives = Default- , _optAllowExec = Default- , _optSaveMetas = Default- , _optShowIdentitySubstitutions = Default- , _optKeepCoveringClauses = Default- , _optForcedArgumentRecursion = Default- , _optLargeIndices = Default- , _optExperimentalLazyInstances = Default- }---- | 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)--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 }- -- ^ Name of option changed in a newer version of Agda.- | WarningProblem WarningModeError- -- ^ A problem with setting or unsetting a warning.- deriving (Show, Generic)--instance NFData OptionWarning--instance Pretty OptionWarning where- pretty = \case- OptionRenamed old new -> hsep- [ "Option", option old, "is deprecated, please use", option new, "instead" ]- WarningProblem err -> pretty (prettyWarningModeError err) <+> "See --help=warning."- where- option = text . ("--" ++)--optionWarningName :: OptionWarning -> WarningName-optionWarningName = \case- OptionRenamed{} -> OptionRenamed_- WarningProblem{} -> WarningProblem_---- | Checks that the given options are consistent.--- Also makes adjustments (e.g. when one option implies another).--checkOpts :: MonadError OptionError m => CommandLineOptions -> m CommandLineOptions-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`.- --- -- Additionally, note that some options checking is performed in `Agda.Main`- -- in which the top-level frontend and backend interactors are selected.- --- -- Those checks are not represented here, because:- -- - They are used solely for selecting the initial executon mode; they- -- don't need to be checked on a per-module etc basis.- -- - I hope/expect that the presence of those specific flags will be eventually- -- abstracted out (like the Backends' internal flags), so that they are invisible- -- to the rest of the type-checking system.- when (optGenerateVimFile opts && optOnlyScopeChecking opts) $- throwError $ "The --only-scope-checking flag cannot be combined with --vim."-- lensPragmaOptions checkPragmaOptions opts---- | Check for pragma option consistency and make adjustments.--checkPragmaOptions :: MonadError OptionError m => PragmaOptions -> m PragmaOptions-checkPragmaOptions opts = do-- -- Check for errors in pragma options.-- when ((optEraseRecordParameters `butNot` optErasure) opts) $- throwError- "The option --erase-record-parameters requires the use of --erasure"--#ifndef COUNT_CLUSTERS- when (optCountClusters opts) $- throwError- "Cluster counting has not been enabled in this build of Agda."-#endif-- -- Perform corrections in pragma options.-- return $ opts-- -- -WTerminationIssue iff --termination-check- & conformWarningToOption TerminationIssue_ optTerminationCheck-- -- -WNotStrictlyPositive iff --positivity-check- . conformWarningToOption NotStrictlyPositive_ optPositivityCheck-- -- unsolvedWarnings iff --no-allow-unsolved-metas- . conformWarningsToOption unsolvedWarnings (not . optAllowUnsolved)-- -- incompleteMatchWarnings iff --no-allow-incomplete-matches- . conformWarningsToOption incompleteMatchWarnings (not . optAllowIncompleteMatch)---- | Activate warning when and only when option is on.-conformWarningToOption ::- WarningName- -- ^ Warning to toggle.- -> (PragmaOptions -> Bool)- -- ^ Which flag to conform to?- -> PragmaOptions- -- ^ Options to modify.- -> PragmaOptions- -- ^ Modified options.-conformWarningToOption = conformWarningsToOption . Set.singleton---- | Activate warnings when option is on and deactivate them when option is off.-conformWarningsToOption ::- Set WarningName- -- ^ Warnings to toggle.- -> (PragmaOptions -> Bool)- -- ^ Which flag to conform to?- -> PragmaOptions- -- ^ Options to modify.- -> PragmaOptions- -- ^ Modified options.-conformWarningsToOption ws f opts =- over (lensOptWarningMode . warningSet) (if f opts then (`Set.union` ws) else (Set.\\ ws)) opts---- | Check for unsafe pragmas. Gives a list of used unsafe flags.--unsafePragmaOptions :: PragmaOptions -> [String]-unsafePragmaOptions opts =- [ "--allow-unsolved-metas" | optAllowUnsolved opts ] ++- [ "--allow-incomplete-matches" | optAllowIncompleteMatch opts ] ++- [ "--no-positivity-check" | not (optPositivityCheck opts) ] ++- [ "--no-termination-check" | not (optTerminationCheck opts) ] ++- [ "--type-in-type" | not (optUniverseCheck opts) ] ++- [ "--omega-in-omega" | optOmegaInOmega opts ] ++- [ "--sized-types" | optSizedTypes opts ] ++- [ "--injective-type-constructors" | optInjectiveTypeConstructors opts ] ++- [ "--irrelevant-projections" | optIrrelevantProjections opts ] ++- [ "--experimental-irrelevance" | optExperimentalIrrelevance opts ] ++- [ "--rewriting" | optRewriting opts ] ++- [ "--cubical-compatible and --with-K" | optCubicalCompatible opts, not (optWithoutK opts) ] ++- [ "--without-K and --flat-split" | optWithoutK opts, optFlatSplit opts ] ++- [ "--cumulativity" | optCumulativity opts ] ++- [ "--allow-exec" | optAllowExec opts ] ++- [ "--no-load-primitives" | not $ optLoadPrimitives opts ] ++- [ "--without-K and --large-indices" | optWithoutK opts, optLargeIndices opts ] ++- [ "--large-indices and --forced-argument-recursion"- | optLargeIndices opts, optForcedArgumentRecursion opts ] ++- []---- | This function returns 'True' if the file should be rechecked.--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.- -- It does not matter what we replace them with, so we take the null value.- blankOut opts = opts- { _optShowImplicit = empty- , _optShowIrrelevant = empty- , _optVerbose = empty- , _optProfiling = empty- , _optPostfixProjections = empty- , _optCompileMain = empty- , _optCaching = empty- , _optCountClusters = empty- , _optPrintPatternSynonyms = empty- , _optShowIdentitySubstitutions = empty- , _optKeepPatternVariables = empty- }---- | 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.--infectiveCoinfectiveOptions :: [InfectiveCoinfectiveOption]-infectiveCoinfectiveOptions =- [ coinfectiveOption optSafe "--safe"- , coinfectiveOption optWithoutK "--without-K"- , cubicalCompatible- , coinfectiveOption (not . optUniversePolymorphism)- "--no-universe-polymorphism"- , coinfectiveOption (not . optCumulativity) "--no-cumulativity"- , coinfectiveOption optLevelUniverse "--level-universe"- , infectiveOption (isJust . optCubical) "--cubical/--erased-cubical"- , infectiveOption optGuarded "--guarded"- , infectiveOption optProp "--prop"- , infectiveOption optTwoLevel "--two-level"- , infectiveOption optRewriting "--rewriting"- , infectiveOption optSizedTypes "--sized-types"- , infectiveOption optGuardedness "--guardedness"- , infectiveOption optFlatSplit "--flat-split"- , infectiveOption optPolarity "--polarity"- , infectiveOption optCohesion "--cohesion"- , infectiveOption optErasure "--erasure"- , infectiveOption optErasedMatches "--erased-matches"- ]- where- cubicalCompatible =- (coinfectiveOption 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 optCubicalCompatible current- then optCubicalCompatible imported- ||- not (optWithoutK imported)- &&- not (optWithoutK current)- &&- not (optSafe current)- else True- }--inputFlag :: FilePath -> Flag CommandLineOptions-inputFlag f o =- case optInputFile o of- Nothing -> return $ o { optInputFile = Just f }- Just _ -> throwError "only one input file allowed"--printAgdaDataDirFlag :: Flag CommandLineOptions-printAgdaDataDirFlag o = return $ o { optPrintAgdaDataDir = True }--printAgdaAppDirFlag :: Flag CommandLineOptions-printAgdaAppDirFlag o = return $ o { optPrintAgdaAppDir = True }--setupFlag :: Flag CommandLineOptions-setupFlag o = return $ o { optSetup = True }--versionFlag :: Flag CommandLineOptions-versionFlag o = return $ o { optPrintVersion = Just PrintAgdaVersion }--numericVersionFlag :: Flag CommandLineOptions-numericVersionFlag o = return $ o { optPrintVersion = Just PrintAgdaNumericVersion }--helpFlag :: Maybe String -> Flag CommandLineOptions-helpFlag Nothing o = return $ o { optPrintHelp = Just GeneralHelp }-helpFlag (Just str) o = case string2HelpTopic str of- Just hpt -> return $ o { optPrintHelp = Just (HelpFor hpt) }- Nothing -> throwError $ concat- [ "unknown help topic ", str, " (", printHelpTopics "topic", ")" ]---- | Helper to explain @--help@.-printHelpTopics :: String -> String-printHelpTopics mvar = concat- [ "available"- , ifNull mvar "" {-else-} \ topic -> " " ++ String.pluralS allHelpTopics topic- , ": "- , intercalate ", " $ map fst allHelpTopics- ]--emacsModeFlag :: String -> Flag CommandLineOptions-emacsModeFlag s o- | s == EmacsMode.setupFlag = add EmacsModeSetup- | s == EmacsMode.compileFlag = add EmacsModeCompile- | s == EmacsMode.locateFlag = add EmacsModeLocate- | otherwise = throwError $ concat- [ "unknown emacs-mode command "- , s- , " ("- , printEmacsModeCommands "commands"- , ")"- ]- where- add m = return o{ optEmacsMode = Set.insert m $ optEmacsMode o }--printEmacsModeCommands :: String -> String-printEmacsModeCommands mvar = concat- [ "available"- , ifNull mvar "" {-else-} \ cmd -> " " ++ cmd- , ": "- , intercalate ", " emacsModeCommands- ]--emacsModeCommands :: [String]-emacsModeCommands = [EmacsMode.setupFlag, EmacsMode.compileFlag, EmacsMode.locateFlag]--safeFlag :: Flag PragmaOptions-safeFlag o = do- return $ o { _optSafe = Value True- , _optSizedTypes = setDefault False (_optSizedTypes o)- }--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--ignoreInterfacesFlag :: Flag CommandLineOptions-ignoreInterfacesFlag o = return $ o { optIgnoreInterfaces = True }--ignoreAllInterfacesFlag :: Flag CommandLineOptions-ignoreAllInterfacesFlag o = return $ o { optIgnoreAllInterfaces = True }--traceImportsFlag :: Maybe String -> Flag CommandLineOptions-traceImportsFlag arg o = do- mode <- case arg of- Nothing -> return 2- Just str -> case reads str :: [(Integer, String)] of- [(n, "")] -> return n- _ -> throwError $ "unknown printing option " ++ str ++ ". Please specify a number."- return $ o { optTraceImports = mode }--diagnosticsColour :: Maybe String -> Flag CommandLineOptions-diagnosticsColour arg o = case arg of- Just "auto" -> pure o { optDiagnosticsColour = AutoColour }- Just "always" -> pure o { optDiagnosticsColour = AlwaysColour }- Just "never" -> pure o { optDiagnosticsColour = NeverColour }- Just str -> throwError $ "unknown colour option " ++ str ++ ". Please specify one of auto, always, or never."- Nothing -> pure o { optDiagnosticsColour = AutoColour }---- | Side effect for setting '_optUseUnicode'.----unicodeOrAsciiEffect :: UnicodeOrAscii -> Flag PragmaOptions-unicodeOrAsciiEffect a o = return $ UNSAFE.unsafePerformIO $ do- unsafeSetUnicodeOrAscii a- return o--ghciInteractionFlag :: Flag CommandLineOptions-ghciInteractionFlag o = return $ o { optGHCiInteraction = True }--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 }--withKFlag :: Flag PragmaOptions-withKFlag =- -- with-K is the opposite of --without-K, so collapse default when disabling --without-K- lensOptWithoutK (lensCollapseDefault $ const $ pure False)- >=>- -- with-K only restores any unsetting of --erased-matches, so keep its default- lensOptErasedMatches (lensKeepDefault $ const $ pure True)---withoutKFlag :: Flag PragmaOptions-withoutKFlag o = return $ o- { _optWithoutK = Value True- , _optFlatSplit = setDefault False $ _optFlatSplit o- , _optErasedMatches = setDefault False $ _optErasedMatches o- }--cubicalCompatibleFlag :: Flag PragmaOptions-cubicalCompatibleFlag o =- return $ o- { _optCubicalCompatible = Value True- , _optWithoutK = setDefault True $ _optWithoutK o- , _optFlatSplit = setDefault False $ _optFlatSplit o- , _optErasedMatches = setDefault False $ _optErasedMatches o- }--cubicalFlag- :: Cubical -- ^ Which variant of Cubical Agda?- -> Flag PragmaOptions-cubicalFlag variant o =- return $ o- { _optCubical = Just variant- , _optCubicalCompatible = setDefault True $ _optCubicalCompatible o- , _optWithoutK = setDefault True $ _optWithoutK o- , _optTwoLevel = setDefault True $ _optTwoLevel o- , _optFlatSplit = setDefault False $ _optFlatSplit o- , _optErasedMatches = setDefault False $ _optErasedMatches o- }--instanceDepthFlag :: String -> Flag PragmaOptions-instanceDepthFlag s o = do- d <- integerArgument "--instance-search-depth" s- return $ o { _optInstanceSearchDepth = d }--inversionMaxDepthFlag :: String -> Flag PragmaOptions-inversionMaxDepthFlag s o = do- d <- integerArgument "--inversion-max-depth" s- return $ o { _optInversionMaxDepth = d }--interactiveFlag :: Flag CommandLineOptions-interactiveFlag o = return $ o { optInteractive = True }--compileDirFlag :: FilePath -> Flag CommandLineOptions-compileDirFlag f o = return $ o { optCompileDir = Just f }--includeFlag :: FilePath -> Flag CommandLineOptions-includeFlag d o = return $ o { optIncludePaths = d : optIncludePaths o }--libraryFlag :: String -> Flag CommandLineOptions-libraryFlag s o = return $ o { optLibraries = optLibraries o ++ [parseLibName s] }--overrideLibrariesFileFlag :: String -> Flag CommandLineOptions-overrideLibrariesFileFlag s o =- return $ o- { optOverrideLibrariesFile = Just s- , optUseLibs = True- }--noDefaultLibsFlag :: Flag CommandLineOptions-noDefaultLibsFlag o = return $ o { optDefaultLibs = False }--noLibsFlag :: Flag CommandLineOptions-noLibsFlag o = return $ o { optUseLibs = False }--verboseFlag :: String -> Flag PragmaOptions-verboseFlag s o =- do (k,n) <- parseVerbose s- 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 ([VerboseKeyItem], VerboseLevel)- parseVerbose s = case parseVerboseKey s of- [] -> usage- s0:ss0 -> do- let (ss, s) = initLast1 s0 ss0- -- 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) }- Left err -> o <$ tell1 (WarningProblem err)--terminationDepthFlag :: String -> Flag PragmaOptions-terminationDepthFlag s o =- do k <- maybe usage return $ readMaybe s- when (k < 1) $ usage -- or: turn termination checking off for 0- return $ o { _optTerminationDepth = CutOff $ k-1 }- where usage = throwError "argument to termination-depth should be >= 1"--confluenceCheckFlag :: ConfluenceCheck -> Flag PragmaOptions-confluenceCheckFlag f o = return $ o { _optConfluenceCheck = Just f }--noConfluenceCheckFlag :: Flag PragmaOptions-noConfluenceCheckFlag o = return $ o { _optConfluenceCheck = Nothing }--exactSplitFlag :: Bool -> Flag PragmaOptions-exactSplitFlag b o = do- return $ conformWarningsToOption exactSplitWarnings (const b)- $ o { _optExactSplit = Value b }---integerArgument :: String -> String -> OptM Int-integerArgument flag s = maybe usage return $ readMaybe s- where- usage = throwError $ "option '" ++ flag ++ "' requires an integer argument"--standardOptions :: [OptDescr (Flag CommandLineOptions)]-standardOptions =- [ Option ['V'] ["version"] (NoArg versionFlag)- ("print version information")-- , Option [] ["numeric-version"] (NoArg numericVersionFlag)- ("print version number")-- , Option ['?'] ["help"] (OptArg helpFlag "TOPIC")- ("print help; " ++ printHelpTopics "TOPIC")-- , Option [] ["emacs-mode"] (ReqArg emacsModeFlag "COMMAND") $ concat- [ "administer the Emacs Agda mode; "- , printEmacsModeCommands "COMMANDs"- , "; confer --help=emacs-mode"- ]-- , Option [] ["print-agda-dir"] (NoArg printAgdaDataDirFlag)- ("print the Agda data directory")-- , Option [] ["print-agda-app-dir"] (NoArg printAgdaAppDirFlag)- ("print $AGDA_DIR")-- , Option [] ["print-agda-data-dir"] (NoArg printAgdaDataDirFlag)- ("print the Agda data directory")-- , Option [] ["build-library"] (NoArg \ o -> return o{ optBuildLibrary = True })- "build all modules included by the @.agda-lib@ file in the current directory"-- , Option [] ["setup"] (NoArg setupFlag)- ("setup the Agda data directory")-- , Option ['I'] ["interactive"] (NoArg interactiveFlag)- "start in interactive mode"- , Option [] ["interaction"] (NoArg ghciInteractionFlag)- "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)")-- , Option [] ["trace-imports"] (OptArg traceImportsFlag "LEVEL")- ("print information about accessed modules during type-checking (where LEVEL=0|1|2|3, default: 2)")-- , Option [] ["vim"] (NoArg vimFlag)- "generate Vim highlighting files"- , Option [] ["ignore-interfaces"] (NoArg ignoreInterfacesFlag)- "ignore interface files (re-type check everything)"- , Option ['i'] ["include-path"] (ReqArg includeFlag "DIR")- "look for imports in DIR"- , Option ['l'] ["library"] (ReqArg libraryFlag "LIB")- "use library LIB"- , Option [] ["library-file"] (ReqArg overrideLibrariesFileFlag "FILE")- "use FILE instead of the standard libraries file"- , Option [] ["no-libraries"] (NoArg noLibsFlag)- "don't use any library files"- , Option [] ["no-default-libraries"] (NoArg noDefaultLibsFlag)- "don't use default libraries"- , Option [] ["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"- , Option [] ["colour", "color"] (OptArg diagnosticsColour "always|auto|never")- ("whether or not to colour diagnostics output. The default is auto.")- ] ++ map (fmap lensPragmaOptions) pragmaOptions---- | Command line options of previous versions of Agda.--- Should not be listed in the usage info, put parsed by GetOpt for good error messaging.-deadStandardOptions :: [OptDescr (Flag CommandLineOptions)]-deadStandardOptions =- [ removedOption "sharing" msgSharing- , removedOption "no-sharing" msgSharing- , removedOption "local-interfaces" "(in 2.8.0)"- , Option [] ["ignore-all-interfaces"] (NoArg ignoreAllInterfacesFlag) -- not deprecated! Just hidden- "ignore all interface files (re-type check everything, including builtin files)"- -- https://github.com/agda/agda/issues/3522#issuecomment-461010898- -- The option is "developer only", so it is hidden.- -- However, it is documented in the user manual.- ] ++ map (fmap lensPragmaOptions) deadPragmaOptions- where- msgSharing = "(in favor of the Agda abstract machine)"---- | Construct a flag of type @WithDefault _@----pragmaFlag :: (IsBool a, KnownBool b)- => String- -- ^ Long option name. Prepended with @no-@ for negative version.- -> Lens' PragmaOptions (WithDefault' a b)- -- ^ Field to switch.- -> String- -- ^ Explanation for positive option.- -> String- -- ^ Additional info for positive option (not repeated for negative option).- -> Maybe String- -- ^ Explanation for negative option.- -> [OptDescr (Flag PragmaOptions)]-pragmaFlag long field = pragmaFlag' long field (const return)---- | Construct a flag of type @WithDefault _@----pragmaFlag' :: (IsBool a, KnownBool b)- => String- -- ^ Long option name. Prepended with @no-@ for negative version.- -> Lens' PragmaOptions (WithDefault' a b)- -- ^ Field to switch.- -> (a -> Flag PragmaOptions)- -- ^ Given the new value, perform additional effect (can override field setting).- -> String- -- ^ Explanation for positive option.- -> String- -- ^ Additional info for positive option (not repeated for negative option).- -> Maybe String- -- ^ Explanation for negative option.- -> [OptDescr (Flag PragmaOptions)]- -- ^ Pair of option descriptors (positive, negative)-pragmaFlag' long field = pragmaFlagBool' long (field . lensCollapseDefault)---- | Construct a flag of type 'IsBool'.----pragmaFlagBool :: (IsBool a)- => String- -- ^ Long option name. Prepended with @no-@ for negative version.- -> Lens' PragmaOptions a- -- ^ Field to switch.- -> String- -- ^ Explanation for positive option.- -> String- -- ^ Additional info for positive option (not repeated for negative option).- -> Maybe String- -- ^ Explanation for negative option.- -> [OptDescr (Flag PragmaOptions)]-pragmaFlagBool long field = pragmaFlagBool' long field (const return)---- | Construct a flag of type 'IsBool' with extra effect.----pragmaFlagBool' :: IsBool a- => String- -- ^ Long option name. Prepended with @no-@ for negative version.- -> Lens' PragmaOptions a- -- ^ Field to switch.- -> (a -> Flag PragmaOptions)- -- ^ Given the new value, perform additional effect (can override field setting).- -> String- -- ^ Explanation for positive option.- -> String- -- ^ Additional info for positive option (not repeated for negative option).- -> Maybe String- -- ^ Explanation for negative option.- -> [OptDescr (Flag PragmaOptions)]- -- ^ Pair of option descriptors (positive, negative)-pragmaFlagBool' long field effect pos info neg =- [ Option [] [no b long] (flag b) (def b $ expl b) | b <- [True,False] ]- where- b0 = defaultPragmaOptions ^. field- no b = applyUnless b ("no-" ++)- flag b = NoArg $ effect a . set field a- where a = fromBool b- def b = applyWhen (fromBool b == b0) (++ " (default)")- expl b = if b then unwords1 [pos, info] else fromMaybe ("do not " ++ pos) neg---pragmaOptions :: [OptDescr (Flag PragmaOptions)]-pragmaOptions = concat- [ pragmaFlag "show-implicit" lensOptShowImplicit- "show implicit arguments when printing" ""- Nothing- , pragmaFlag "show-irrelevant" lensOptShowIrrelevant- "show irrelevant arguments when printing" ""- Nothing- , pragmaFlag "show-identity-substitutions" lensOptShowIdentitySubstitutions- "show all arguments of metavariables when printing terms" ""- Nothing- , pragmaFlag' "unicode" lensOptUseUnicode unicodeOrAsciiEffect- "use unicode characters when printing terms" ""- Nothing- , [ Option ['v'] ["verbose"] (ReqArg verboseFlag "N")- "set verbosity level to N. Only has an effect if Agda was built with the \"debug\" flag."- , Option [] ["profile"] (ReqArg profileFlag "TYPE")- ("turn on profiling for TYPE (where TYPE=" ++ intercalate "|" validProfileOptionStrings ++ ")")- ]- , pragmaFlag "allow-unsolved-metas" lensOptAllowUnsolved- "succeed and create interface file regardless of unsolved meta variables" ""- Nothing- , pragmaFlag "allow-incomplete-matches" lensOptAllowIncompleteMatch- "succeed and create interface file regardless of incomplete pattern matches" ""- Nothing- , pragmaFlag "positivity-check" lensOptPositivityCheck- "warn about not strictly positive data types" ""- Nothing- , pragmaFlag "termination-check" lensOptTerminationCheck- "warn about possibly nonterminating code" ""- Nothing- , [ Option [] ["termination-depth"] (ReqArg terminationDepthFlag "N")- "allow termination checker to count decrease/increase upto N (default N=1)"- ]- , pragmaFlag "type-in-type" lensOptNoUniverseCheck- "ignore universe levels" "(this makes Agda inconsistent)"- Nothing- , pragmaFlag "omega-in-omega" lensOptOmegaInOmega- "enable typing rule Setω : Setω" "(this makes Agda inconsistent)"- Nothing- , pragmaFlag "cumulativity" lensOptCumulativity- "enable subtyping of universes" "(e.g. Set =< Set₁)"- $ Just "disable subtyping of universes"- , pragmaFlag "prop" lensOptProp- "enable the use of the Prop universe" ""- $ Just "disable the use of the Prop universe"- , pragmaFlag "level-universe" lensOptLevelUniverse- "place type Level in a dedicated LevelUniv universe" ""- Nothing- , pragmaFlag "two-level" lensOptTwoLevel- "enable the use of SSet* universes" ""- Nothing- , pragmaFlag "sized-types" lensOptSizedTypes- "enable sized types" "(inconsistent with --guardedness)"- $ Just "disable sized types"- , pragmaFlag "cohesion" lensOptCohesion- "enable the cohesion modalities" "(in particular @flat)"- Nothing- , pragmaFlag "flat-split" lensOptFlatSplit- "allow splitting on `(@flat x : A)' arguments" "(implies --cohesion)"- Nothing- , pragmaFlag "polarity" lensOptPolarity- "enable the polarity modalities (@++, @mixed, etc.) and their integration in the positivity checker" ""- Nothing- , pragmaFlag "guardedness" lensOptGuardedness- "enable constructor-based guarded corecursion" "(inconsistent with --sized-types)"- $ Just "disable constructor-based guarded corecursion"- , pragmaFlag "injective-type-constructors" lensOptInjectiveTypeConstructors- "enable injective type constructors" "(makes Agda anti-classical and possibly inconsistent)"- $ Just "disable injective type constructors"- , pragmaFlag "universe-polymorphism" lensOptUniversePolymorphism- "enable universe polymorphism" ""- $ Just "disable universe polymorphism"- , pragmaFlag "irrelevant-projections" lensOptIrrelevantProjections- "enable projection of irrelevant record fields and similar irrelevant definitions" "(inconsistent)"- $ Just "disable projection of irrelevant record fields and similar irrelevant definitions"- , pragmaFlag "experimental-irrelevance" lensOptExperimentalIrrelevance- "enable potentially unsound irrelevance features" "(irrelevant levels, irrelevant data matching)"- Nothing- , [ 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)- "turn on checks to make code compatible with HoTT (e.g. disabling the K rule). Implies --no-flat-split."- ]- , pragmaFlag "copatterns" lensOptCopatterns- "enable definitions by copattern matching" ""- $ Just "disable definitions by copattern matching"- , pragmaFlag "pattern-matching" lensOptPatternMatching- "enable pattern matching" ""- $ Just "disable pattern matching completely"- , [ Option [] ["exact-split"] (NoArg $ exactSplitFlag True)- "require all clauses in a definition to hold as definitional equalities (unless marked CATCHALL)"- , Option [] ["no-exact-split"] (NoArg $ exactSplitFlag False)- "do not require all clauses in a definition to hold as definitional equalities (default)"- ]- , pragmaFlag "hidden-argument-puns" lensOptHiddenArgumentPuns- "interpret the patterns {x} and {{x}} as puns" ""- Nothing- , pragmaFlag "eta-equality" lensOptEta- "default records to eta-equality" ""- $ Just "default records to no-eta-equality"- , pragmaFlag "forcing" lensOptForcing- "enable the forcing analysis for data constructors" "(optimisation)"- $ Just "disable the forcing analysis"- , pragmaFlag "projection-like" lensOptProjectionLike- "enable the analysis whether function signatures liken those of projections" "(optimisation)"- $ Just "disable the projection-like analysis"- , pragmaFlag "erasure" lensOptErasure- "enable erasure" ""- Nothing- , pragmaFlag "erased-matches" lensOptErasedMatches- "allow matching in erased positions for single-constructor types" "(implies --erasure if supplied explicitly)"- Nothing- , pragmaFlag "erase-record-parameters" lensOptEraseRecordParameters- "mark all parameters of record modules as erased" "(implies --erasure)"- Nothing- , pragmaFlag "rewriting" lensOptRewriting- "enable declaration and use of REWRITE rules" ""- $ Just "disable declaration and use of REWRITE rules"- , [ Option [] ["local-confluence-check"] (NoArg $ confluenceCheckFlag LocalConfluenceCheck)- "enable checking of local confluence of REWRITE rules"- , Option [] ["confluence-check"] (NoArg $ confluenceCheckFlag GlobalConfluenceCheck)- "enable global confluence checking of REWRITE rules (more restrictive than --local-confluence-check)"- , 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 --cubical-compatible"- , Option [] ["erased-cubical"] (NoArg $ cubicalFlag CErased)- "enable cubical features (some only in erased settings), implies --cubical-compatible"- ]- , pragmaFlag "guarded" lensOptGuarded- "enable @lock/@tick attributes" ""- $ Just "disable @lock/@tick attributes"- , lossyUnificationOption- , requireUniqueMetaSolutionsOptions- , pragmaFlag "postfix-projections" lensOptPostfixProjections- "prefer postfix projection notation" ""- $ Just "prefer prefix projection notation"- , pragmaFlag "keep-pattern-variables" lensOptKeepPatternVariables- "don't replace variables with dot patterns during case splitting" ""- $ Just "replace variables with dot patterns during case splitting"- , pragmaFlag "infer-absurd-clauses" lensOptInferAbsurdClauses- "eliminate absurd clauses in case splitting and coverage checking" ""- $ Just "do not automatically eliminate absurd clauses in case splitting and coverage checking (can speed up type-checking)"- , [ Option [] ["instance-search-depth"] (ReqArg instanceDepthFlag "N")- "set instance search depth to N (default: 500)"- ]- , backtrackingInstancesOption- , pragmaFlag "qualified-instances" lensOptQualifiedInstances- "use instances with qualified names" ""- Nothing- , [ Option [] ["inversion-max-depth"] (ReqArg inversionMaxDepthFlag "N")- "set maximum depth for pattern match inversion to N (default: 50)"- , Option [] ["safe"] (NoArg safeFlag)- "disable postulates, unsafe OPTION pragmas and primEraseEquality, implies --no-sized-types"- ]- , pragmaFlag "double-check" lensOptDoubleCheck- "enable double-checking of all terms using the internal typechecker" ""- $ Just "disable double-checking of terms"- , [ 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.")- ]- , pragmaFlag "main" lensOptCompileMain- "treat the requested module as the main module of a program when compiling" ""- Nothing- , pragmaFlag "caching" lensOptCaching- "enable caching of typechecking" ""- $ Just "disable caching of typechecking"- , pragmaFlag "count-clusters" lensOptCountClusters- "count extended grapheme clusters when generating LaTeX"- ("(note that this flag " ++-#ifdef COUNT_CLUSTERS- "is not enabled in all builds"-#else- "has not been enabled in this build"-#endif- ++ " of Agda)")- Nothing- , pragmaFlag "auto-inline" lensOptAutoInline- "enable automatic compile-time inlining" ""- $ Just "disable automatic compile-time inlining, only definitions marked INLINE will be inlined"- , pragmaFlag "print-pattern-synonyms" lensOptPrintPatternSynonyms- "keep pattern synonyms when printing terms" ""- $ Just "expand pattern synonyms when printing terms"- , pragmaFlag "fast-reduce" lensOptFastReduce- "enable reduction using the Agda Abstract Machine" ""- $ Just "disable reduction using the Agda Abstract Machine"- , pragmaFlag "call-by-name" lensOptCallByName- "use call-by-name evaluation instead of call-by-need" ""- $ Just "use call-by-need evaluation"-- , pragmaFlag "import-sorts" lensOptImportSorts- "implicitly import Agda.Primitive using (Set; Prop) at the start of each top-level module" ""- $ Just "disable the implicit import of Agda.Primitive using (Set; Prop) at the start of each top-level module"- , pragmaFlag "load-primitives" lensOptLoadPrimitives- "load primitives modules" ""- $ Just "disable loading of primitive modules completely (implies --no-import-sorts)"- , pragmaFlag "allow-exec" lensOptAllowExec- "allow system calls to trusted executables with primExec" ""- Nothing- , pragmaFlag "save-metas" lensOptSaveMetas- "save meta-variables" ""- Nothing- , pragmaFlag "keep-covering-clauses" lensOptKeepCoveringClauses- "do not discard covering clauses" "(required for some external backends)"- $ Just "discard covering clauses"- , pragmaFlag "large-indices" lensOptLargeIndices- "allow constructors with large indices" ""- $ Just "always check that constructor arguments live in universes compatible with that of the datatype"- , pragmaFlag "forced-argument-recursion" lensOptForcedArgumentRecursion- "allow recursion on forced constructor arguments" ""- Nothing- , pragmaFlag "experimental-lazy-instances" lensOptExperimentalLazyInstances- "enable experimental, faster implementation of instance search" ""- Nothing- ]--pragmaOptionDefault :: KnownBool b => (PragmaOptions -> WithDefault b) -> Bool -> String-pragmaOptionDefault f b =- if b == collapseDefault (f defaultPragmaOptions) then " (default)" else ""--lossyUnificationOption :: [OptDescr (Flag PragmaOptions)]-lossyUnificationOption =- pragmaFlag "lossy-unification" lensOptFirstOrder- "enable heuristically unifying `f es = f es'` by unifying `es = es'`"- "even when it could lose solutions"- Nothing--requireUniqueMetaSolutionsOptions :: [OptDescr (Flag PragmaOptions)]-requireUniqueMetaSolutionsOptions =- pragmaFlag "require-unique-meta-solutions" lensOptRequireUniqueMetaSolutions- "require unique solutions to meta variables"- "even when it could lose solutions"- Nothing--backtrackingInstancesOption :: [OptDescr (Flag PragmaOptions)]-backtrackingInstancesOption =- pragmaFlag "backtracking-instance-search" lensOptBacktrackingInstances- "allow backtracking during instance search"- ""- Nothing---- | 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 = 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"- , headWithDefault __IMPOSSIBLE__ lossyUnificationOption- )- , ( "overlapping-instances"- , headWithDefault __IMPOSSIBLE__ backtrackingInstancesOption- )- ]- ]- 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 ()]-standardOptions_ = map void standardOptions---- | Simple interface for Agda.Utils.GetOpt--- Could be moved to Agda.Utils.Options (does not exist yet)-getOptSimple- :: [String] -- ^ command line argument words- -> [OptDescr (Flag opts)] -- ^ options handlers- -> (String -> Flag opts) -- ^ handler of non-options (only one is allowed)- -> Flag opts -- ^ combined opts data structure transformer-getOptSimple argv opts fileArg = \ defaults ->- case getOpt' (ReturnInOrder fileArg) opts argv of- (o, _, [] , [] ) -> foldl (>>=) (return defaults) o- (_, _, unrecognized, errs) -> throwError $ umsg ++ emsg-- where- ucap = "Unrecognized " ++ String.pluralS unrecognized "option" ++ ":"- ecap = String.pluralS errs "Option error" ++ ":"- umsg = if null unrecognized then "" else unlines $- ucap : map suggest unrecognized- emsg = if null errs then "" else unlines $- ecap : errs-- -- Suggest alternatives that are at most 3 typos away-- longopts :: [String]- longopts = map ("--" ++) $ concatMap (\ (Option _ long _ _) -> long) opts-- dist :: String -> String -> Int- dist s t = restrictedDamerauLevenshteinDistance defaultEditCosts s t-- close :: String -> String -> Maybe (Int, String)- close s t = let d = dist s t in if d <= 3 then Just (d, t) else Nothing-- closeopts :: String -> [(Int, String)]- closeopts s = mapMaybe (close s) longopts-- alts :: String -> [List1 String]- alts s = map (fmap snd) $ List1.groupOn fst $ closeopts s-- suggest :: String -> String- suggest s = case alts s of- [] -> s- as : _ -> s ++ " (did you mean " ++ sugs as ++ " ?)"-- sugs :: List1 String -> String- sugs (a :| []) = a- sugs as = "any of " ++ List1.unwords as---- | Parse options from an options pragma.-parsePragmaOptions- :: OptionsPragma- -- ^ Pragma options.- -> CommandLineOptions- -- ^ Command-line options which should be updated.- -> OptM PragmaOptions-parsePragmaOptions argv opts = do- ps <- getOptSimple- (pragmaStrings argv)- (deadPragmaOptions ++ pragmaOptions)- (\s _ -> throwError $ "Bad option in pragma: " ++ s)- (optPragmaOptions opts)- checkPragmaOptions ps---- | Parse options for a plugin.-parsePluginOptions :: [String] -> [OptDescr (Flag opts)] -> Flag opts-parsePluginOptions argv opts =- getOptSimple argv opts- (\s _ -> throwError $- "Internal error: Flag " ++ s ++ " passed to a plugin")---- | The usage info message. The argument is the program name (probably--- agda).-usage :: [OptDescr ()] -> String -> Help -> String-usage options progName GeneralHelp = usageInfo (header progName) options- where- header progName = unlines [ "Agda version " ++ version, ""- , "Usage: " ++ progName ++ " [OPTIONS...] [FILE]" ]--usage options progName (HelpFor topic) = helpTopicUsage topic---- | Removes RTS options from a list of options.--stripRTS :: [String] -> [String]-stripRTS [] = []-stripRTS ("--RTS" : argv) = argv-stripRTS (arg : argv)- | is "+RTS" arg = stripRTS $ drop 1 $ dropWhile (not . is "-RTS") argv- | otherwise = arg : stripRTS argv- where- is x arg = [x] == take 1 (words arg)+{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}++module Agda.Interaction.Options.Base+ ( CommandLineOptions(..)+ , PragmaOptions(..)+ , OptionError+ , OptionWarning(..), optionWarningName+ , Flag, OptM, runOptM, OptDescr(..), ArgDescr(..)+ , Verbosity, VerboseKey, VerboseLevel+ , ConfluenceCheck(..)+ , DiagnosticsColours(..)+ , EmacsModeCommand(..)+ , PrintAgdaVersion(..)+ , UnicodeOrAscii(..)+ , WarningMode(..)+ , checkOpts+ , parsePragmaOptions+ , parsePluginOptions+ , parseVerboseKey+ , stripRTS+ , defaultOptions+ , defaultInteractionOptions+ , defaultCutOff+ , defaultPragmaOptions+ , optionGroups+ , latexPragmaOptions+ , unsafePragmaOptions+ , recheckBecausePragmaOptionsChanged+ , InfectiveCoinfective(..)+ , InfectiveCoinfectiveOption(..)+ , infectiveCoinfectiveOptions+ , ImpliedPragmaOption(..)+ , impliedPragmaOptions+ , safeFlag+ , mapFlag+ -- Reused by PandocAgda+ , inputFlag+ , standardOptions, deadStandardOptions+ , getOptSimple+ -- * Lenses for 'PragmaOptions'+ , lensOptShowImplicit+ , lensOptShowIrrelevant+ , lensOptUseUnicode+ , lensOptVerbose+ , lensOptProfiling+ , lensOptIrrelevance+ , lensOptProp+ , lensOptLevelUniverse+ , lensOptTwoLevel+ , lensOptAllowUnsolved+ , lensOptAllowIncompleteMatch+ , lensOptPositivityCheck+ , lensOptTerminationCheck+ , lensOptTerminationDepth+ , lensOptUniverseCheck, lensOptNoUniverseCheck+ , lensOptOmegaInOmega+ , lensOptCumulativity+ , lensOptSizedTypes+ , lensOptGuardedness+ , lensOptInjectiveTypeConstructors+ , lensOptUniversePolymorphism+ , lensOptIrrelevantProjections+ , lensOptExperimentalIrrelevance+ , lensOptExperimentalLazyInstances+ , lensOptWithoutK+ , lensOptCubicalCompatible+ , lensOptCopatterns+ , lensOptPatternMatching+ , lensOptExactSplit+ , lensOptHiddenArgumentPuns+ , lensOptEta+ , lensOptForcing+ , lensOptProjectionLike+ , lensOptErasure+ , lensOptErasedMatches+ , lensOptEraseRecordParameters+ , lensOptRewriting+ , lensOptLocalRewriting+ , lensOptCubical+ , lensOptGuarded+ , lensOptFirstOrder+ , lensOptRequireUniqueMetaSolutions+ , lensOptPostfixProjections+ , lensOptKeepPatternVariables+ , lensOptInferAbsurdClauses+ , lensOptInstanceSearchDepth+ , lensOptBacktrackingInstances+ , lensOptQualifiedInstances+ , lensOptInversionMaxDepth+ , lensOptSafe+ , lensOptDoubleCheck+ , lensOptSyntacticEquality+ , lensOptWarningMode+ , lensOptCompileMain+ , lensOptCaching+ , lensOptCountClusters+ , lensOptAutoInline+ , lensOptPrintPatternSynonyms+ , lensOptFastReduce+ , lensOptCallByName+ , lensOptConfluenceCheck+ , lensOptCohesion+ , lensOptFlatSplit+ , lensOptPolarity+ , lensOptOccurrence+ , lensOptImportSorts+ , lensOptLoadPrimitives+ , lensOptAllowExec+ , lensOptSaveMetas+ , lensOptShowIdentitySubstitutions+ , lensOptKeepCoveringClauses+ -- * Boolean accessors to 'PragmaOptions' collapsing default+ , optShowImplicit+ , optShowGeneralized+ , optShowIrrelevant+ , optIrrelevance+ , optProp+ , optLevelUniverse+ , optTwoLevel+ , optAllowUnsolved+ , optAllowIncompleteMatch+ , optPositivityCheck+ , optTerminationCheck+ , optUniverseCheck+ , optOmegaInOmega+ , optCumulativity+ , optSizedTypes+ , optGuardedness+ , optInjectiveTypeConstructors+ , optUniversePolymorphism+ , optIrrelevantProjections+ , optExperimentalIrrelevance+ , optWithoutK+ , optCubicalCompatible+ , optCopatterns+ , optPatternMatching+ , optHiddenArgumentPuns+ , optEta+ , optForcing+ , optProjectionLike+ , optErasure+ , optEraseRecordParameters+ , optRewriting+ , optLocalRewriting+ , optGuarded+ , optFirstOrder+ , optRequireUniqueMetaSolutions+ , optPostfixProjections+ , optKeepPatternVariables+ , optInferAbsurdClauses+ , optBacktrackingInstances+ , optQualifiedInstances+ , optSafe+ , optDoubleCheck+ , optCompileNoMain+ , optCaching+ , optCountClusters+ , optAutoInline+ , optPrintPatternSynonyms+ , optFastReduce+ , optCallByName+ , optCohesion+ , optFlatSplit+ , optPolarity+ , optOccurrence+ , optFunext+ , optPropext+ , optQuotients+ , optImportSorts+ , optLoadPrimitives+ , optAllowExec+ , optSaveMetas+ , optShowIdentitySubstitutions+ , optKeepCoveringClauses+ , optLargeIndices+ , optForcedArgumentRecursion+ , optQuoteMetas+ -- * Non-boolean accessors to 'PragmaOptions'+ , optConfluenceCheck+ , optCubical+ , optErasedMatches+ , optInstanceSearchDepth+ , optInversionMaxDepth+ , optProfiling+ , optSyntacticEquality+ , optTerminationDepth+ , optUseUnicode+ , optVerbose+ , optWarningMode+ ) where++import Prelude hiding ( null, not, (&&), (||) )++import Control.DeepSeq+import Control.Monad ( when, void )+import Control.Monad.Except ( ExceptT, MonadError(throwError), runExceptT )+import Control.Monad.Writer ( Writer, runWriter, MonadWriter(..) )++import Data.Bifunctor ( second )+import Data.Function ( (&) )+import Data.List ( intercalate )+import Data.Maybe+import Data.Set ( Set )+import qualified Data.Set as Set++import GHC.Generics (Generic)++import Agda.Utils.GetOpt ( getOpt', ArgOrder(ReturnInOrder)+ , OptDescr(..), ArgDescr(..)+ )+import qualified System.IO.Unsafe as UNSAFE (unsafePerformIO)++import Text.EditDistance+import Text.Read ( readMaybe )++import Agda.Termination.CutOff ( CutOff(..), defaultCutOff )++import Agda.Interaction.Library ( OptionsPragma(..), parseLibName )+import Agda.Interaction.Options.Arguments+import Agda.Interaction.Options.Default+import Agda.Interaction.Options.Help+ ( Help(HelpFor, GeneralHelp)+ , string2HelpTopic+ , allHelpTopics+ )+import Agda.Interaction.Options.Types+import Agda.Interaction.Options.Warnings++import Agda.Syntax.Concrete.Glyph ( unsafeSetUnicodeOrAscii, UnicodeOrAscii(..) )+import qualified Agda.Syntax.Common as C+import Agda.Syntax.Common (AllowedErasedMatches, Cubical(..))+import Agda.Syntax.Common.Pretty+import Agda.Syntax.Position (PrintRange(PrintRange))+import Agda.Syntax.TopLevelModuleName (TopLevelModuleName)++import qualified Agda.Setup.EmacsMode as EmacsMode++import Agda.Utils.Boolean+import Agda.Utils.Function ( applyWhen, applyUnless )+import Agda.Utils.Functor ( (<&>) )+import Agda.Utils.Lens ( Lens', (^.), over, over', set )+import Agda.Utils.List ( chopWhen, headWithDefault, initLast1 )+import Agda.Utils.List1 ( List1, pattern (:|), 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.Interaction.Options.ProfileOptions+import Agda.Utils.String ( unwords1 )+import qualified Agda.Utils.String as String+import qualified Agda.Utils.Trie as Trie+import Agda.Utils.TypeLits+import Agda.Utils.WithDefault++import Agda.Utils.Impossible++parseVerboseKey :: VerboseKey -> [VerboseKeyItem]+parseVerboseKey = List1.wordsBy (`elem` ['.', ':'])++data ImpliedPragmaOption where+ ImpliesPragmaOption+ :: String -> Bool -> (PragmaOptions -> WithDefault a)+ -> String -> Bool -> (PragmaOptions -> WithDefault b)+ -> ImpliedPragmaOption+ -- ^ The first option having the given value implies the second option having its given value.+ -- For instance, `ImpliesPragmaOption "lossy-unification" True _optFirstOrder+ -- "require-unique-meta-solutions" False _optRequireUniqueMetaSolutions`+ -- encodes the fact that --lossy-unification implies --no-require-unique-meta-solutions.++impliedPragmaOptions :: [ImpliedPragmaOption]+impliedPragmaOptions =+ [ ("erase-record-parameters", _optEraseRecordParameters) ==> ("erasure", _optErasure)+ , ("experimental-irrelevance", _optExperimentalIrrelevance) ==> ("irrelevance", _optIrrelevance)+ , ("flat-split", _optFlatSplit) ==> ("cohesion", _optCohesion)+ , ("irrelevant-projections", _optIrrelevantProjections) ==> ("irrelevance", _optIrrelevance)+ , ("no-load-primitives", _optLoadPrimitives) ==> ("no-import-sorts", _optImportSorts)+ , ("lossy-unification", _optFirstOrder) ==> ("no-require-unique-meta-solutions", _optRequireUniqueMetaSolutions)+ , ImpliesPragmaOption+ "erased-matches (with a different argument than \"=none\")" True+ (\opts -> case _optErasedMatches opts of+ C.ErasedMatchesDefault -> Default+ C.ErasedMatchesDefaultOn -> Value True+ C.ErasedMatches allowed -> Value (allowed /= mempty))+ "erasure" True _optErasure+ ]+ where+ yesOrNo ('n':'o':'-':s) = (False, s)+ yesOrNo s = (True, s)+ (nameA, optA) ==> (nameB, optB) = ImpliesPragmaOption stemA valA optA stemB valB optB+ where+ (valA, stemA) = yesOrNo nameA+ (valB, stemB) = yesOrNo nameB++-- collapse defaults+optShowImplicit :: PragmaOptions -> Bool+optShowGeneralized :: PragmaOptions -> Bool+optShowIrrelevant :: PragmaOptions -> Bool+optIrrelevance :: PragmaOptions -> Bool+optProp :: PragmaOptions -> Bool+optLevelUniverse :: PragmaOptions -> Bool+optTwoLevel :: PragmaOptions -> Bool+optAllowUnsolved :: PragmaOptions -> Bool+optAllowIncompleteMatch :: PragmaOptions -> Bool+optPositivityCheck :: PragmaOptions -> Bool+optTerminationCheck :: PragmaOptions -> Bool+optUniverseCheck :: PragmaOptions -> Bool+optOmegaInOmega :: PragmaOptions -> Bool+optCumulativity :: PragmaOptions -> Bool+optSizedTypes :: PragmaOptions -> Bool+optGuardedness :: PragmaOptions -> Bool+optInjectiveTypeConstructors :: PragmaOptions -> Bool+optUniversePolymorphism :: PragmaOptions -> Bool+optIrrelevantProjections :: PragmaOptions -> Bool+optExperimentalIrrelevance :: PragmaOptions -> Bool+optWithoutK :: PragmaOptions -> Bool+optCubicalCompatible :: PragmaOptions -> Bool+optCopatterns :: PragmaOptions -> Bool+optPatternMatching :: PragmaOptions -> Bool+optHiddenArgumentPuns :: PragmaOptions -> Bool+optEta :: PragmaOptions -> Bool+optForcing :: PragmaOptions -> Bool+optProjectionLike :: PragmaOptions -> Bool+-- | 'optErasure' is implied by 'optEraseRecordParameters',+-- 'optFunext' and 'optPropext'. 'optErasure' is also implied by an+-- explicitly given @--erased-matches@ with an argument distinct+-- from @=none@.+optErasure :: PragmaOptions -> Bool+optEraseRecordParameters :: PragmaOptions -> Bool+optRewriting :: PragmaOptions -> Bool+optLocalRewriting :: PragmaOptions -> Bool+optGuarded :: PragmaOptions -> Bool+optFirstOrder :: PragmaOptions -> Bool+optRequireUniqueMetaSolutions :: PragmaOptions -> Bool+optPostfixProjections :: PragmaOptions -> Bool+optKeepPatternVariables :: PragmaOptions -> Bool+optInferAbsurdClauses :: PragmaOptions -> Bool+optBacktrackingInstances :: PragmaOptions -> Bool+optQualifiedInstances :: PragmaOptions -> Bool+optSafe :: PragmaOptions -> Bool+optDoubleCheck :: PragmaOptions -> Bool+optCompileNoMain :: PragmaOptions -> Bool+optCaching :: PragmaOptions -> Bool+optCountClusters :: PragmaOptions -> Bool+optAutoInline :: PragmaOptions -> Bool+optPrintPatternSynonyms :: PragmaOptions -> Bool+optFastReduce :: PragmaOptions -> Bool+optCallByName :: PragmaOptions -> Bool+-- | 'optCohesion' is implied by 'optFlatSplit'.+optCohesion :: PragmaOptions -> Bool+optFlatSplit :: PragmaOptions -> Bool+optPolarity :: PragmaOptions -> Bool+optOccurrence :: PragmaOptions -> Bool+-- | 'optFunext' is implied by 'optQuotients'.+optFunext :: PragmaOptions -> Bool+optPropext :: PragmaOptions -> Bool+optQuotients :: PragmaOptions -> Bool+-- | 'optImportSorts' requires 'optLoadPrimitives'.+optImportSorts :: PragmaOptions -> Bool+optLoadPrimitives :: PragmaOptions -> Bool+optAllowExec :: PragmaOptions -> Bool+optSaveMetas :: PragmaOptions -> Bool+optShowIdentitySubstitutions :: PragmaOptions -> Bool+optKeepCoveringClauses :: PragmaOptions -> Bool+optLargeIndices :: PragmaOptions -> Bool+optForcedArgumentRecursion :: PragmaOptions -> Bool++optShowImplicit = collapseDefault . _optShowImplicit+optShowGeneralized = collapseDefault . _optShowGeneralized+optShowIrrelevant = collapseDefault . _optShowIrrelevant+optIrrelevance = collapseDefault . _optIrrelevance+optProp = collapseDefault . _optProp+optLevelUniverse = collapseDefault . _optLevelUniverse+optTwoLevel = collapseDefault . _optTwoLevel+optAllowUnsolved = collapseDefault . _optAllowUnsolved+optAllowIncompleteMatch = collapseDefault . _optAllowIncompleteMatch+optPositivityCheck = collapseDefault . _optPositivityCheck+optTerminationCheck = collapseDefault . _optTerminationCheck+optUniverseCheck = collapseDefault . _optUniverseCheck+optOmegaInOmega = collapseDefault . _optOmegaInOmega+optCumulativity = collapseDefault . _optCumulativity+optSizedTypes = collapseDefault . _optSizedTypes+optGuardedness = collapseDefault . _optGuardedness+optInjectiveTypeConstructors = collapseDefault . _optInjectiveTypeConstructors+optUniversePolymorphism = collapseDefault . _optUniversePolymorphism+optIrrelevantProjections = collapseDefault . _optIrrelevantProjections+optExperimentalIrrelevance = collapseDefault . _optExperimentalIrrelevance+optWithoutK = collapseDefault . _optWithoutK+optCubicalCompatible = collapseDefault . _optCubicalCompatible+optCopatterns = collapseDefault . _optCopatterns+optPatternMatching = collapseDefault . _optPatternMatching+optHiddenArgumentPuns = collapseDefault . _optHiddenArgumentPuns+optEta = collapseDefault . _optEta+optForcing = collapseDefault . _optForcing+optProjectionLike = collapseDefault . _optProjectionLike+-- --erase-record-parameters implies --erasure+optErasure = collapseDefault . _optErasure ||+ optEraseRecordParameters ||+ optFunext ||+ optPropext ||+ ((/= C.ErasedMatchesDefault) &&+ (/= C.ErasedMatches mempty)) .+ _optErasedMatches+optEraseRecordParameters = collapseDefault . _optEraseRecordParameters+optRewriting = collapseDefault . _optRewriting+optLocalRewriting = collapseDefault . _optLocalRewriting+optGuarded = collapseDefault . _optGuarded+optFirstOrder = collapseDefault . _optFirstOrder+optRequireUniqueMetaSolutions = collapseDefault . _optRequireUniqueMetaSolutions && not . optFirstOrder+-- --lossy-unification implies --no-require-unique-meta-solutions+optPostfixProjections = collapseDefault . _optPostfixProjections+optKeepPatternVariables = collapseDefault . _optKeepPatternVariables+optInferAbsurdClauses = collapseDefault . _optInferAbsurdClauses+optBacktrackingInstances = collapseDefault . _optBacktrackingInstances+optQualifiedInstances = collapseDefault . _optQualifiedInstances+optSafe = collapseDefault . _optSafe+optDoubleCheck = collapseDefault . _optDoubleCheck+optCompileNoMain = not . collapseDefault . _optCompileMain+optCaching = collapseDefault . _optCaching+optCountClusters = collapseDefault . _optCountClusters+optAutoInline = collapseDefault . _optAutoInline+optPrintPatternSynonyms = collapseDefault . _optPrintPatternSynonyms+optFastReduce = collapseDefault . _optFastReduce+optCallByName = collapseDefault . _optCallByName+-- --flat-split implies --cohesion+optCohesion = collapseDefault . _optCohesion || optFlatSplit+optFlatSplit = collapseDefault . _optFlatSplit+optPolarity = collapseDefault . _optPolarity+optOccurrence = collapseDefault . _optOccurrence+optFunext = collapseDefault . _optFunext ||+ optQuotients+optPropext = collapseDefault . _optPropext+optQuotients = collapseDefault . _optQuotients+-- --no-load-primitives implies --no-import-sorts+optImportSorts = collapseDefault . _optImportSorts && optLoadPrimitives+optLoadPrimitives = collapseDefault . _optLoadPrimitives+optAllowExec = collapseDefault . _optAllowExec+optSaveMetas = collapseDefault . _optSaveMetas+optShowIdentitySubstitutions = collapseDefault . _optShowIdentitySubstitutions+optKeepCoveringClauses = collapseDefault . _optKeepCoveringClauses+optLargeIndices = collapseDefault . _optLargeIndices+optForcedArgumentRecursion = collapseDefault . _optForcedArgumentRecursion+optQuoteMetas = collapseDefault . _optQuoteMetas++-- Collapse defaults (non-Bool)++optUseUnicode :: PragmaOptions -> UnicodeOrAscii+optUseUnicode = collapseDefault . _optUseUnicode++optErasedMatches :: PragmaOptions -> AllowedErasedMatches+optErasedMatches opts = case _optErasedMatches opts of+ C.ErasedMatches m ->+ m+ C.ErasedMatchesDefault+ | not (optErasure opts) ->+ allowedErasedMatches None+ | optWithoutK opts ->+ allowedErasedMatches Empty+ | otherwise ->+ allowedErasedMatches Empty <> allowedErasedMatches Unrestricted+ C.ErasedMatchesDefaultOn+ | optWithoutK opts ->+ allowedErasedMatches Empty <> allowedErasedMatches NonDependent+ | otherwise ->+ allowedErasedMatches Empty <> allowedErasedMatches Unrestricted++-- Extra trivial accessors (keep in alphabetical order)++optConfluenceCheck :: PragmaOptions -> _+optCubical :: PragmaOptions -> _+optInstanceSearchDepth :: PragmaOptions -> _+optInversionMaxDepth :: PragmaOptions -> _+optProfiling :: PragmaOptions -> _+optSyntacticEquality :: PragmaOptions -> _+optTerminationDepth :: PragmaOptions -> _+optVerbose :: PragmaOptions -> _+optWarningMode :: PragmaOptions -> _++optConfluenceCheck = _optConfluenceCheck+optCubical = _optCubical+optInstanceSearchDepth = _optInstanceSearchDepth+optInversionMaxDepth = _optInversionMaxDepth+optProfiling = _optProfiling+optSyntacticEquality = _optSyntacticEquality+optTerminationDepth = _optTerminationDepth+optVerbose = _optVerbose+optWarningMode = _optWarningMode++-- Lenses for PragmaOptions+-- N.B.: We use PartialTypeSignatures here to not repeat default values (DRY!).++lensOptShowImplicit :: Lens' PragmaOptions _+lensOptShowImplicit f o = f (_optShowImplicit o) <&> \ i -> o{ _optShowImplicit = i }++lensOptShowIrrelevant :: Lens' PragmaOptions _+lensOptShowIrrelevant f o = f (_optShowIrrelevant o) <&> \ i -> o{ _optShowIrrelevant = i }++lensOptUseUnicode :: Lens' PragmaOptions _+lensOptUseUnicode f o = f (_optUseUnicode o) <&> \ i -> o{ _optUseUnicode = i }++lensOptVerbose :: Lens' PragmaOptions _+lensOptVerbose f o = f (_optVerbose o) <&> \ i -> o{ _optVerbose = i }++lensOptProfiling :: Lens' PragmaOptions _+lensOptProfiling f o = f (_optProfiling o) <&> \ i -> o{ _optProfiling = i }++lensOptIrrelevance :: Lens' PragmaOptions _+lensOptIrrelevance f o = f (_optIrrelevance o) <&> \ i -> o{ _optIrrelevance = i }++lensOptProp :: Lens' PragmaOptions _+lensOptProp f o = f (_optProp o) <&> \ i -> o{ _optProp = i }++lensOptLevelUniverse :: Lens' PragmaOptions _+lensOptLevelUniverse f o = f (_optLevelUniverse o) <&> \ i -> o{ _optLevelUniverse = i }++lensOptTwoLevel :: Lens' PragmaOptions _+lensOptTwoLevel f o = f (_optTwoLevel o) <&> \ i -> o{ _optTwoLevel = i }++lensOptAllowUnsolved :: Lens' PragmaOptions _+lensOptAllowUnsolved f o = f (_optAllowUnsolved o) <&> \ i -> o{ _optAllowUnsolved = i }++lensOptAllowIncompleteMatch :: Lens' PragmaOptions _+lensOptAllowIncompleteMatch f o = f (_optAllowIncompleteMatch o) <&> \ i -> o{ _optAllowIncompleteMatch = i }++lensOptPositivityCheck :: Lens' PragmaOptions _+lensOptPositivityCheck f o = f (_optPositivityCheck o) <&> \ i -> o{ _optPositivityCheck = i }++lensOptTerminationCheck :: Lens' PragmaOptions _+lensOptTerminationCheck f o = f (_optTerminationCheck o) <&> \ i -> o{ _optTerminationCheck = i }++lensOptTerminationDepth :: Lens' PragmaOptions _+lensOptTerminationDepth f o = f (_optTerminationDepth o) <&> \ i -> o{ _optTerminationDepth = i }++lensOptUniverseCheck :: Lens' PragmaOptions _+lensOptUniverseCheck f o = f (_optUniverseCheck o) <&> \ i -> o{ _optUniverseCheck = i }++lensOptNoUniverseCheck :: Lens' PragmaOptions _+lensOptNoUniverseCheck f o = f (not' $ _optUniverseCheck o) <&> \ i -> o{ _optUniverseCheck = not' i }++lensOptOmegaInOmega :: Lens' PragmaOptions _+lensOptOmegaInOmega f o = f (_optOmegaInOmega o) <&> \ i -> o{ _optOmegaInOmega = i }++lensOptCumulativity :: Lens' PragmaOptions _+lensOptCumulativity f o = f (_optCumulativity o) <&> \ i -> o{ _optCumulativity = i }++lensOptSizedTypes :: Lens' PragmaOptions _+lensOptSizedTypes f o = f (_optSizedTypes o) <&> \ i -> o{ _optSizedTypes = i }++lensOptGuardedness :: Lens' PragmaOptions _+lensOptGuardedness f o = f (_optGuardedness o) <&> \ i -> o{ _optGuardedness = i }++lensOptInjectiveTypeConstructors :: Lens' PragmaOptions _+lensOptInjectiveTypeConstructors f o = f (_optInjectiveTypeConstructors o) <&> \ i -> o{ _optInjectiveTypeConstructors = i }++lensOptUniversePolymorphism :: Lens' PragmaOptions _+lensOptUniversePolymorphism f o = f (_optUniversePolymorphism o) <&> \ i -> o{ _optUniversePolymorphism = i }++lensOptIrrelevantProjections :: Lens' PragmaOptions _+lensOptIrrelevantProjections f o = f (_optIrrelevantProjections o) <&> \ i -> o{ _optIrrelevantProjections = i }++lensOptExperimentalIrrelevance :: Lens' PragmaOptions _+lensOptExperimentalIrrelevance f o = f (_optExperimentalIrrelevance o) <&> \ i -> o{ _optExperimentalIrrelevance = i }++lensOptWithoutK :: Lens' PragmaOptions _+lensOptWithoutK f o = f (_optWithoutK o) <&> \ i -> o{ _optWithoutK = i }++lensOptCubicalCompatible :: Lens' PragmaOptions _+lensOptCubicalCompatible f o = f (_optCubicalCompatible o) <&> \ i -> o{ _optCubicalCompatible = i }++lensOptCopatterns :: Lens' PragmaOptions _+lensOptCopatterns f o = f (_optCopatterns o) <&> \ i -> o{ _optCopatterns = i }++lensOptPatternMatching :: Lens' PragmaOptions _+lensOptPatternMatching f o = f (_optPatternMatching o) <&> \ i -> o{ _optPatternMatching = i }++lensOptExactSplit :: Lens' PragmaOptions _+lensOptExactSplit f o = f (_optExactSplit o) <&> \ i -> o{ _optExactSplit = i }++lensOptHiddenArgumentPuns :: Lens' PragmaOptions _+lensOptHiddenArgumentPuns f o = f (_optHiddenArgumentPuns o) <&> \ i -> o{ _optHiddenArgumentPuns = i }++lensOptEta :: Lens' PragmaOptions _+lensOptEta f o = f (_optEta o) <&> \ i -> o{ _optEta = i }++lensOptForcing :: Lens' PragmaOptions _+lensOptForcing f o = f (_optForcing o) <&> \ i -> o{ _optForcing = i }++lensOptProjectionLike :: Lens' PragmaOptions _+lensOptProjectionLike f o = f (_optProjectionLike o) <&> \ i -> o{ _optProjectionLike = i }++lensOptErasure :: Lens' PragmaOptions _+lensOptErasure f o = f (_optErasure o) <&> \ i -> o{ _optErasure = i }++lensOptErasedMatches :: Lens' PragmaOptions _+lensOptErasedMatches f o = f (_optErasedMatches o) <&> \ i -> o{ _optErasedMatches = i }++lensOptEraseRecordParameters :: Lens' PragmaOptions _+lensOptEraseRecordParameters f o = f (_optEraseRecordParameters o) <&> \ i -> o{ _optEraseRecordParameters = i }++lensOptRewriting :: Lens' PragmaOptions _+lensOptRewriting f o = f (_optRewriting o) <&> \ i -> o{ _optRewriting = i }++lensOptLocalRewriting :: Lens' PragmaOptions _+lensOptLocalRewriting f o = f (_optLocalRewriting o) <&> \ i -> o{ _optLocalRewriting = i }++lensOptCubical :: Lens' PragmaOptions _+lensOptCubical f o = f (_optCubical o) <&> \ i -> o{ _optCubical = i }++lensOptGuarded :: Lens' PragmaOptions _+lensOptGuarded f o = f (_optGuarded o) <&> \ i -> o{ _optGuarded = i }++lensOptFirstOrder :: Lens' PragmaOptions _+lensOptFirstOrder f o = f (_optFirstOrder o) <&> \ i -> o{ _optFirstOrder = i }++lensOptRequireUniqueMetaSolutions :: Lens' PragmaOptions _+lensOptRequireUniqueMetaSolutions f o = f (_optRequireUniqueMetaSolutions o) <&> \ i -> o{ _optRequireUniqueMetaSolutions = i }++lensOptPostfixProjections :: Lens' PragmaOptions _+lensOptPostfixProjections f o = f (_optPostfixProjections o) <&> \ i -> o{ _optPostfixProjections = i }++lensOptKeepPatternVariables :: Lens' PragmaOptions _+lensOptKeepPatternVariables f o = f (_optKeepPatternVariables o) <&> \ i -> o{ _optKeepPatternVariables = i }++lensOptInferAbsurdClauses :: Lens' PragmaOptions _+lensOptInferAbsurdClauses f o = f (_optInferAbsurdClauses o) <&> \ i -> o{ _optInferAbsurdClauses = i }++lensOptInstanceSearchDepth :: Lens' PragmaOptions _+lensOptInstanceSearchDepth f o = f (_optInstanceSearchDepth o) <&> \ i -> o{ _optInstanceSearchDepth = i }++lensOptBacktrackingInstances :: Lens' PragmaOptions _+lensOptBacktrackingInstances f o = f (_optBacktrackingInstances o) <&> \ i -> o{ _optBacktrackingInstances = i }++lensOptQualifiedInstances :: Lens' PragmaOptions _+lensOptQualifiedInstances f o = f (_optQualifiedInstances o) <&> \ i -> o{ _optQualifiedInstances = i }++lensOptInversionMaxDepth :: Lens' PragmaOptions _+lensOptInversionMaxDepth f o = f (_optInversionMaxDepth o) <&> \ i -> o{ _optInversionMaxDepth = i }++lensOptSafe :: Lens' PragmaOptions _+lensOptSafe f o = f (_optSafe o) <&> \ i -> o{ _optSafe = i }++lensOptDoubleCheck :: Lens' PragmaOptions _+lensOptDoubleCheck f o = f (_optDoubleCheck o) <&> \ i -> o{ _optDoubleCheck = i }++lensOptSyntacticEquality :: Lens' PragmaOptions _+lensOptSyntacticEquality f o = f (_optSyntacticEquality o) <&> \ i -> o{ _optSyntacticEquality = i }++lensOptWarningMode :: Lens' PragmaOptions _+lensOptWarningMode f o = f (_optWarningMode o) <&> \ i -> o{ _optWarningMode = i }++lensOptCompileMain :: Lens' PragmaOptions _+lensOptCompileMain f o = f (_optCompileMain o) <&> \ i -> o{ _optCompileMain = i }++lensOptCaching :: Lens' PragmaOptions _+lensOptCaching f o = f (_optCaching o) <&> \ i -> o{ _optCaching = i }++lensOptCountClusters :: Lens' PragmaOptions _+lensOptCountClusters f o = f (_optCountClusters o) <&> \ i -> o{ _optCountClusters = i }++lensOptAutoInline :: Lens' PragmaOptions _+lensOptAutoInline f o = f (_optAutoInline o) <&> \ i -> o{ _optAutoInline = i }++lensOptPrintPatternSynonyms :: Lens' PragmaOptions _+lensOptPrintPatternSynonyms f o = f (_optPrintPatternSynonyms o) <&> \ i -> o{ _optPrintPatternSynonyms = i }++lensOptFastReduce :: Lens' PragmaOptions _+lensOptFastReduce f o = f (_optFastReduce o) <&> \ i -> o{ _optFastReduce = i }++lensOptCallByName :: Lens' PragmaOptions _+lensOptCallByName f o = f (_optCallByName o) <&> \ i -> o{ _optCallByName = i }++lensOptConfluenceCheck :: Lens' PragmaOptions _+lensOptConfluenceCheck f o = f (_optConfluenceCheck o) <&> \ i -> o{ _optConfluenceCheck = i }++lensOptCohesion :: Lens' PragmaOptions _+lensOptCohesion f o = f (_optCohesion o) <&> \ i -> o{ _optCohesion = i }++lensOptFlatSplit :: Lens' PragmaOptions _+lensOptFlatSplit f o = f (_optFlatSplit o) <&> \ i -> o{ _optFlatSplit = i }++lensOptPolarity :: Lens' PragmaOptions _+lensOptPolarity f o = f (_optPolarity o) <&> \ i -> o{ _optPolarity = i}++lensOptOccurrence :: Lens' PragmaOptions _+lensOptOccurrence f o =+ f (_optOccurrence o) <&> \ i -> o{ _optOccurrence = i}++lensOptFunext :: Lens' PragmaOptions _+lensOptFunext f o = f (_optFunext o) <&> \ i -> o{ _optFunext = i }++lensOptPropext :: Lens' PragmaOptions _+lensOptPropext f o = f (_optPropext o) <&> \ i -> o{ _optPropext = i }++lensOptQuotients :: Lens' PragmaOptions _+lensOptQuotients f o =+ f (_optQuotients o) <&> \ i -> o{ _optQuotients = i }++lensOptImportSorts :: Lens' PragmaOptions _+lensOptImportSorts f o = f (_optImportSorts o) <&> \ i -> o{ _optImportSorts = i }++lensOptLoadPrimitives :: Lens' PragmaOptions _+lensOptLoadPrimitives f o = f (_optLoadPrimitives o) <&> \ i -> o{ _optLoadPrimitives = i }++lensOptAllowExec :: Lens' PragmaOptions _+lensOptAllowExec f o = f (_optAllowExec o) <&> \ i -> o{ _optAllowExec = i }++lensOptSaveMetas :: Lens' PragmaOptions _+lensOptSaveMetas f o = f (_optSaveMetas o) <&> \ i -> o{ _optSaveMetas = i }++lensOptShowIdentitySubstitutions :: Lens' PragmaOptions _+lensOptShowIdentitySubstitutions f o = f (_optShowIdentitySubstitutions o) <&> \ i -> o{ _optShowIdentitySubstitutions = i }++lensOptKeepCoveringClauses :: Lens' PragmaOptions _+lensOptKeepCoveringClauses f o = f (_optKeepCoveringClauses o) <&> \ i -> o{ _optKeepCoveringClauses = i }++lensOptLargeIndices :: Lens' PragmaOptions _+lensOptLargeIndices f o = f (_optLargeIndices o) <&> \ i -> o{ _optLargeIndices = i }++lensOptForcedArgumentRecursion :: Lens' PragmaOptions _+lensOptForcedArgumentRecursion f o = f (_optForcedArgumentRecursion o) <&> \ i -> o{ _optForcedArgumentRecursion = i }++lensOptExperimentalLazyInstances :: Lens' PragmaOptions _+lensOptExperimentalLazyInstances f o = f (_optExperimentalLazyInstances o) <&> \ i -> o{ _optExperimentalLazyInstances = i }++lensOptQuoteMetas :: Lens' PragmaOptions _+lensOptQuoteMetas f o = f (_optQuoteMetas o) <&> \ i -> o{ _optQuoteMetas = i }++-- | Map a function over the long options. Also removes the short options.+-- Will be used to add the plugin name to the plugin options.+mapFlag :: (String -> String) -> OptDescr a -> OptDescr a+mapFlag f (Option _ long arg descr) = Option [] (map f long) arg descr++defaultInteractionOptions :: PragmaOptions+defaultInteractionOptions = defaultPragmaOptions++-- | 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)++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 }+ -- ^ Name of option changed in a newer version of Agda.+ | WarningProblem WarningModeError+ -- ^ A problem with setting or unsetting a warning.+ | LocalRewritingConfluenceCheck+ -- ^ Confluence checking for local rewrite rules is unimplemented.+ deriving (Show, Generic)++instance NFData OptionWarning++instance Pretty OptionWarning where+ pretty = \case+ OptionRenamed old new -> hsep+ [ "Option", option old, "is deprecated, please use", option new, "instead" ]+ WarningProblem err -> pretty (prettyWarningModeError err) <+> "See --help=warning."+ LocalRewritingConfluenceCheck -> fsep $ pwords "Confluence checking (--confluence-check or --local-confluence-check) is not yet implemented for local rewrite rules (--local-rewriting)"+ where+ option = text . ("--" ++)++optionWarningName :: OptionWarning -> WarningName+optionWarningName = \case+ OptionRenamed{} -> OptionRenamed_+ WarningProblem{} -> WarningProblem_+ LocalRewritingConfluenceCheck -> LocalRewritingConfluenceCheck_++-- | Checks that the given options are consistent.+-- Also makes adjustments (e.g. when one option implies another).++checkOpts :: (MonadError OptionError m, MonadWriter OptionWarnings m)+ => CommandLineOptions -> m CommandLineOptions+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`.+ --+ -- Additionally, note that some options checking is performed in `Agda.Main`+ -- in which the top-level frontend and backend interactors are selected.+ --+ -- Those checks are not represented here, because:+ -- - They are used solely for selecting the initial executon mode; they+ -- don't need to be checked on a per-module etc basis.+ -- - I hope/expect that the presence of those specific flags will be eventually+ -- abstracted out (like the Backends' internal flags), so that they are invisible+ -- to the rest of the type-checking system.+ when (optGenerateVimFile opts && optOnlyScopeChecking opts) $+ throwError $ "The --only-scope-checking flag cannot be combined with --vim."++ lensPragmaOptions checkPragmaOptions opts++-- | Check for pragma option consistency and make adjustments.++checkPragmaOptions :: (MonadError OptionError m, MonadWriter OptionWarnings m)+ => PragmaOptions -> m PragmaOptions+checkPragmaOptions opts = do++ -- Check for errors in pragma options.++ when ((optEraseRecordParameters `butNot` optErasure) opts) $+ throwError+ "The option --erase-record-parameters requires the use of --erasure"++ when (isJust (optConfluenceCheck opts) && optLocalRewriting opts) $+ tell1 LocalRewritingConfluenceCheck++#ifndef COUNT_CLUSTERS+ when (optCountClusters opts) $+ throwError+ "Cluster counting has not been enabled in this build of Agda."+#endif++ -- Perform corrections in pragma options.++ return $ opts++ -- -WTerminationIssue iff --termination-check+ & conformWarningToOption TerminationIssue_ optTerminationCheck++ -- -WNotStrictlyPositive iff --positivity-check+ . conformWarningToOption NotStrictlyPositive_ optPositivityCheck++ -- unsolvedWarnings iff --no-allow-unsolved-metas+ . conformWarningsToOption unsolvedWarnings (not . optAllowUnsolved)++ -- incompleteMatchWarnings iff --no-allow-incomplete-matches+ . conformWarningsToOption incompleteMatchWarnings (not . optAllowIncompleteMatch)++-- | Activate warning when and only when option is on.+conformWarningToOption ::+ WarningName+ -- ^ Warning to toggle.+ -> (PragmaOptions -> Bool)+ -- ^ Which flag to conform to?+ -> PragmaOptions+ -- ^ Options to modify.+ -> PragmaOptions+ -- ^ Modified options.+conformWarningToOption = conformWarningsToOption . Set.singleton++-- | Activate warnings when option is on and deactivate them when option is off.+conformWarningsToOption ::+ Set WarningName+ -- ^ Warnings to toggle.+ -> (PragmaOptions -> Bool)+ -- ^ Which flag to conform to?+ -> PragmaOptions+ -- ^ Options to modify.+ -> PragmaOptions+ -- ^ Modified options.+conformWarningsToOption ws f opts =+ over (lensOptWarningMode . warningSet) (if f opts then (`Set.union` ws) else (Set.\\ ws)) opts++-- | Check for unsafe pragmas. Gives a list of used unsafe flags.++unsafePragmaOptions :: PragmaOptions -> [String]+unsafePragmaOptions opts =+ [ "--allow-unsolved-metas" | optAllowUnsolved opts ] +++ [ "--allow-incomplete-matches" | optAllowIncompleteMatch opts ] +++ [ "--no-positivity-check" | not (optPositivityCheck opts) ] +++ [ "--no-termination-check" | not (optTerminationCheck opts) ] +++ [ "--type-in-type" | not (optUniverseCheck opts) ] +++ [ "--omega-in-omega" | optOmegaInOmega opts ] +++ [ "--sized-types" | optSizedTypes opts ] +++ [ "--injective-type-constructors" | optInjectiveTypeConstructors opts ] +++ [ "--irrelevant-projections" | optIrrelevantProjections opts ] +++ [ "--experimental-irrelevance" | optExperimentalIrrelevance opts ] +++ [ "--rewriting" | optRewriting opts ] +++ [ "--local-rewriting" | optLocalRewriting opts ]+ +++ [ "--cubical=compatible and --with-K" | optCubicalCompatible opts, not (optWithoutK opts) ] +++ [ "--without-K and --flat-split" | optWithoutK opts, optFlatSplit opts ] +++ [ "--without-K and --erased-matches=unrestricted"+ | optWithoutK opts, C.emUnrestricted (optErasedMatches opts)+ ] +++ [ "--cumulativity" | optCumulativity opts ] +++ [ "--allow-exec" | optAllowExec opts ] +++ [ "--no-load-primitives" | not $ optLoadPrimitives opts ] +++ [ "--without-K and --large-indices" | optWithoutK opts, optLargeIndices opts ] +++ [ "--large-indices and --forced-argument-recursion"+ | optLargeIndices opts, optForcedArgumentRecursion opts ] +++ []++-- | This function returns 'True' if the file should be rechecked.++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.+ -- It does not matter what we replace them with, so we take the null value.+ blankOut opts = opts+ { _optShowImplicit = empty+ , _optShowIrrelevant = empty+ , _optVerbose = empty+ , _optProfiling = empty+ , _optPostfixProjections = empty+ , _optCompileMain = empty+ , _optCaching = empty+ , _optCountClusters = empty+ , _optPrintPatternSynonyms = empty+ , _optShowIdentitySubstitutions = empty+ , _optKeepPatternVariables = empty+ }++-- | 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 ::+ PragmaOptions -> PragmaOptions -> 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 for the first two+ -- arguments.+ }++-- | 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 $ PrintRange 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 $ PrintRange m] +++ pwords "not using the" ++ [text s] +++ pwords "flag from a module which does."+ }++-- | Infective and coinfective options.+--+-- Note that @--cubical[=full]@ and @--cubical=erased@ 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.++infectiveCoinfectiveOptions :: [InfectiveCoinfectiveOption]+infectiveCoinfectiveOptions =+ [ coinfectiveOption optSafe "--safe"+ , coinfectiveOption optWithoutK "--without-K"+ , cubicalCompatible+ , coinfectiveOption (not . optUniversePolymorphism)+ "--no-universe-polymorphism"+ , coinfectiveOption (not . optCumulativity) "--no-cumulativity"+ , coinfectiveOption optLevelUniverse "--level-universe"+ , infectiveOption (isJust . optCubical) "--cubical[={full,erased,no-glue}]"+ , cubicalWithoutGlue+ , infectiveOption optGuarded "--guarded"+ , infectiveOption optIrrelevance "--irrelevance"+ , infectiveOption optProp "--prop"+ , infectiveOption optTwoLevel "--two-level"+ , infectiveOption optRewriting "--rewriting"+ , infectiveOption optLocalRewriting "--local-rewriting"+ , infectiveOption optSizedTypes "--sized-types"+ , infectiveOption optGuardedness "--guardedness"+ , infectiveOption optFlatSplit "--flat-split"+ , infectiveOption optPolarity "--polarity"+ , infectiveOption optCohesion "--cohesion"+ , infectiveOption optErasure "--erasure"+ , infectiveOption optFunext "--erased-funext"+ , infectiveOption optPropext "--erased-propext"+ , infectiveOption optQuotients "--erased-quotients"+ , ICOption+ { icOptionActive =+ (C.ErasedMatches mempty /=) . _optErasedMatches+ , icOptionDescription =+ "--erased-matches"+ , icOptionKind =+ Infective+ , icOptionOK = \current imported ->+ optErasedMatches imported <= optErasedMatches current+ , icOptionWarning = \current imported m -> fsep $+ pwords "Importing module" ++ [pretty $ PrintRange m] +++ pwords "using (effectively) the flags" +++ [text $ showEffectiveErasedMatchFlags $+ optErasedMatches imported] +++ pwords "from a module which uses the flags" +++ [text $ showEffectiveErasedMatchFlags $+ optErasedMatches current]+ }+ ]+ where+ cubicalCompatible =+ (coinfectiveOption 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 optCubicalCompatible current+ then optCubicalCompatible imported+ ||+ not (optWithoutK imported)+ &&+ not (optWithoutK current)+ &&+ not (optSafe current)+ else True+ }++ cubicalWithoutGlue =+ let flagName = "--cubical=no-glue" in+ (infectiveOption (\o -> optCubical o == Just CWithoutGlue) flagName)+ { icOptionOK = \current imported ->+ -- If the current module uses Cubical without glue,+ -- then the imported modules cannot use glue.+ case (optCubical current, optCubical imported) of+ (Just CWithoutGlue, Just CFull) -> False+ (Just CWithoutGlue, Just CErased) -> False+ _ -> True+ , icOptionWarning = \_ _ m -> fsep $+ pwords "Importing module" ++ [pretty $ PrintRange m] +++ pwords "which might contain glue to a module with the option" +++ pwords (flagName ++ ".")+ }++inputFlag :: FilePath -> Flag CommandLineOptions+inputFlag f o =+ case optInputFile o of+ Nothing -> return $ o { optInputFile = Just f }+ Just _ -> throwError "only one input file allowed"++printAgdaDataDirFlag :: Flag CommandLineOptions+printAgdaDataDirFlag o = return $ o { optPrintAgdaDataDir = True }++printAgdaAppDirFlag :: Flag CommandLineOptions+printAgdaAppDirFlag o = return $ o { optPrintAgdaAppDir = True }++printOptionsFlag :: Flag CommandLineOptions+printOptionsFlag o = return $ o { optPrintOptions = True }++setupFlag :: Flag CommandLineOptions+setupFlag o = return $ o { optSetup = True }++versionFlag :: Flag CommandLineOptions+versionFlag o = return $ o { optPrintVersion = Just PrintAgdaVersion }++numericVersionFlag :: Flag CommandLineOptions+numericVersionFlag o = return $ o { optPrintVersion = Just PrintAgdaNumericVersion }++helpFlag :: Maybe String -> Flag CommandLineOptions+helpFlag Nothing o = return $ o { optPrintHelp = Just GeneralHelp }+helpFlag (Just str) o = case string2HelpTopic str of+ Just hpt -> return $ o { optPrintHelp = Just (HelpFor hpt) }+ Nothing -> throwError $ concat+ [ "unknown help topic ", str, " (", printHelpTopics "topic", ")" ]++-- | Helper to explain @--help@.+printHelpTopics :: String -> String+printHelpTopics mvar = concat+ [ "available"+ , ifNull mvar "" {-else-} \ topic -> " " ++ String.pluralS allHelpTopics topic+ , ": "+ , intercalate ", " $ map fst allHelpTopics+ ]++emacsModeFlag :: String -> Flag CommandLineOptions+emacsModeFlag s o+ | s == EmacsMode.setupFlag = add EmacsModeSetup+ | s == EmacsMode.compileFlag = add EmacsModeCompile+ | s == EmacsMode.locateFlag = add EmacsModeLocate+ | otherwise = throwError $ concat+ [ "unknown emacs-mode command "+ , s+ , " ("+ , printEmacsModeCommands "commands"+ , ")"+ ]+ where+ add m = return o{ optEmacsMode = Set.insert m $ optEmacsMode o }++printEmacsModeCommands :: String -> String+printEmacsModeCommands mvar = concat+ [ "available"+ , ifNull mvar "" {-else-} \ cmd -> " " ++ cmd+ , ": "+ , intercalate ", " emacsModeValues+ ]++safeFlag :: Flag PragmaOptions+safeFlag o = do+ return $ o { _optSafe = Value True+ , _optSizedTypes = setDefault False (_optSizedTypes o)+ }++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++ignoreInterfacesFlag :: Flag CommandLineOptions+ignoreInterfacesFlag o = return $ o { optIgnoreInterfaces = True }++ignoreAllInterfacesFlag :: Flag CommandLineOptions+ignoreAllInterfacesFlag o = return $ o { optIgnoreAllInterfaces = True }++noWriteInterfacesFlag :: Flag CommandLineOptions+noWriteInterfacesFlag o = return $ o { optWriteInterfaces = False }++traceImportsFlag :: Maybe String -> Flag CommandLineOptions+traceImportsFlag arg o = do+ mode <- case arg of+ Nothing -> return 2+ Just str -> case reads str :: [(Integer, String)] of+ [(n, "")] -> return n+ _ -> throwError $ "unknown printing option " ++ str ++ ". Please specify a number."+ return $ o { optTraceImports = mode }++diagnosticsColour :: Maybe String -> Flag CommandLineOptions+diagnosticsColour arg o = case arg of+ Just "auto" -> pure o { optDiagnosticsColour = AutoColour }+ Just "always" -> pure o { optDiagnosticsColour = AlwaysColour }+ Just "never" -> pure o { optDiagnosticsColour = NeverColour }+ Just str -> throwError $ "unknown colour option " ++ str ++ ". Please specify one of auto, always, or never."+ Nothing -> pure o { optDiagnosticsColour = AutoColour }++parallelismFlag :: Maybe String -> Flag CommandLineOptions+parallelismFlag (Just n) o = case readMaybe n of+ Just 0 -> pure o { optParallelChecking = Parallel Nothing }+ Just 1 -> pure o { optParallelChecking = Sequential }+ Just i -> pure o { optParallelChecking = Parallel (Just i) }+ Nothing -> throwError $ "the parallelism should be a number, and " <> show n <> " isn't."+parallelismFlag Nothing o = pure o { optParallelChecking = Parallel Nothing }+++-- | Side effect for setting '_optUseUnicode'.+--+unicodeOrAsciiEffect :: UnicodeOrAscii -> Flag PragmaOptions+unicodeOrAsciiEffect a o = return $ UNSAFE.unsafePerformIO $ do+ unsafeSetUnicodeOrAscii a+ return o++ghciInteractionFlag :: Flag CommandLineOptions+ghciInteractionFlag o = return $ o { optGHCiInteraction = True }++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 }++mdOnlyAgdaBlocksFlag :: Bool -> Flag CommandLineOptions+mdOnlyAgdaBlocksFlag b o = return $ o { optMdOnlyAgdaBlocks = b }++withKFlag :: Flag PragmaOptions+withKFlag =+ -- with-K is the opposite of --without-K, so collapse default when disabling --without-K+ lensOptWithoutK (lensCollapseDefault $ const $ pure False)+++withoutKFlag :: Flag PragmaOptions+withoutKFlag o = return $ o+ { _optWithoutK = Value True+ , _optFlatSplit = setDefault False $ _optFlatSplit o+ }++-- A unified flag for all cubical variants:+-- [--cubical] defaults to Cubical+-- [--cubical={compatible,no-glue,erased,full}] corresponds to the 4 options.+cubicalFlagOptArg :: Maybe String -> Flag PragmaOptions+cubicalFlagOptArg s = case s of+ Nothing -> cubicalFlag CFull+ Just "full" -> cubicalFlag CFull+ Just "erased" -> cubicalFlag CErased+ Just "no-glue" -> cubicalFlag CWithoutGlue+ Just "compatible" -> cubicalCompatibleFlag+ _ -> return $ throwError+ "Cubical variant can be omitted or one of {compatible, no-glue, erased, full}."++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 =+ return $ o+ { _optCubical = Just variant+ , _optCubicalCompatible = setDefault True $ _optCubicalCompatible o+ , _optWithoutK = setDefault True $ _optWithoutK o+ -- Andreas, 2026-01-20, issue #8326+ -- Do not set optTwoLevel here, but have been implied by optCubical+ -- , _optTwoLevel = setDefault True $ _optTwoLevel o+ , _optFlatSplit = setDefault False $ _optFlatSplit o+ }++instanceDepthFlag :: String -> Flag PragmaOptions+instanceDepthFlag s o = do+ d <- integerArgument "--instance-search-depth" s+ return $ o { _optInstanceSearchDepth = d }++inversionMaxDepthFlag :: String -> Flag PragmaOptions+inversionMaxDepthFlag s o = do+ d <- integerArgument "--inversion-max-depth" s+ return $ o { _optInversionMaxDepth = d }++interactiveFlag :: Flag CommandLineOptions+interactiveFlag o = return $ o { optInteractive = True }++compileDirFlag :: FilePath -> Flag CommandLineOptions+compileDirFlag f o = return $ o { optCompileDir = Just f }++includeFlag :: FilePath -> Flag CommandLineOptions+includeFlag d o = return $ o { optIncludePaths = d : optIncludePaths o }++libraryFlag :: String -> Flag CommandLineOptions+libraryFlag s o = return $ o { optLibraries = optLibraries o ++ [parseLibName s] }++overrideLibrariesFileFlag :: String -> Flag CommandLineOptions+overrideLibrariesFileFlag s o =+ return $ o+ { optOverrideLibrariesFile = Just s+ , optUseLibs = True+ }++noDefaultLibsFlag :: Flag CommandLineOptions+noDefaultLibsFlag o = return $ o { optDefaultLibs = False }++noLibsFlag :: Flag CommandLineOptions+noLibsFlag o = return $ o { optUseLibs = False }++verboseFlag :: String -> Flag PragmaOptions+verboseFlag s o =+ do (k,n) <- parseVerbose s+ 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 ([VerboseKeyItem], VerboseLevel)+ parseVerbose s = case parseVerboseKey s of+ [] -> usage+ s0:ss0 -> do+ let (ss, s) = initLast1 s0 ss0+ -- 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) }+ Left err -> o <$ tell1 (WarningProblem err)++terminationDepthFlag :: String -> Flag PragmaOptions+terminationDepthFlag s o =+ do k <- maybe usage return $ readMaybe s+ when (k < 1) $ usage -- or: turn termination checking off for 0+ return $ o { _optTerminationDepth = CutOff $ k-1 }+ where usage = throwError "argument to termination-depth should be >= 1"++confluenceCheckFlag :: ConfluenceCheck -> Flag PragmaOptions+confluenceCheckFlag f o = return $ o { _optConfluenceCheck = Just f }++noConfluenceCheckFlag :: Flag PragmaOptions+noConfluenceCheckFlag o = return $ o { _optConfluenceCheck = Nothing }++exactSplitFlag :: Bool -> Flag PragmaOptions+exactSplitFlag b o = do+ return $ conformWarningsToOption exactSplitWarnings (const b)+ $ o { _optExactSplit = Value b }+++integerArgument :: String -> String -> OptM Int+integerArgument flag s = maybe usage return $ readMaybe s+ where+ usage = throwError $ "option '" ++ flag ++ "' requires an integer argument"++-- | This list should contain all options defined in this module.+standardOptions :: [OptDescr (Flag CommandLineOptions)]+standardOptions = concat $+ map (fmap lensPragmaOptions) (snd latexPragmaOptions) :+ map snd optionGroups++optionGroups :: [(String, [OptDescr (Flag CommandLineOptions)])]+optionGroups =+ [ informationOptions+ , mainModeOptions+ , projectOptions+ , essentialConfigurationOptions+ , literateOptions+ , diagnosticsOptions+ , emb warningPragmaOptions+ , emb checkerPragmaOptions+ , emb languagePragmaOptions+ , emb universePragmaOptions+ , emb modalityPragmaOptions+ , emb terminationPragmaOptions+ , emb patternMatchingPragmaOptions+ , emb instancePragmaOptions+ , emb rewritingPragmaOptions+ , emb equalityCheckingPragmaOptions+ , emb optimizationPragmaOptions+ , emb printerPragmaOptions+ , emb backendPragmaOptions+ , compilationOptions+ , emb debuggingPragmaOptions+ , emb reflectionPragmaOptions+ ]+ where+ emb = second $ map $ fmap lensPragmaOptions++-- | Options that make Agda print information, setup itself etc.+-- Agda can execute these tasks in addition to a main mode \/ frontend \/ interactor.+informationOptions :: (String, [OptDescr (Flag CommandLineOptions)])+informationOptions = ("Setup and basic information",)+ [ Option ['V'] ["version"] (NoArg versionFlag)+ ("print version information")++ , Option [] ["numeric-version"] (NoArg numericVersionFlag)+ ("print version number")++ , Option ['?'] ["help"] (OptArg helpFlag helpArg)+ ("print help; " ++ printHelpTopics helpArg)++ , Option [] ["emacs-mode"] (ReqArg emacsModeFlag emacsModeArg) $ concat+ [ "administer the Emacs Agda mode; "+ , printEmacsModeCommands (emacsModeArg ++ "s")+ , "; confer --help=emacs-mode"+ ]++ , Option [] ["print-agda-dir"] (NoArg printAgdaDataDirFlag)+ ("print the Agda data directory")++ , Option [] ["print-agda-app-dir"] (NoArg printAgdaAppDirFlag)+ ("print $AGDA_DIR")++ , Option [] ["print-agda-data-dir"] (NoArg printAgdaDataDirFlag)+ ("print the Agda data directory")++ , Option [] ["print-options"] (NoArg printOptionsFlag)+ ("print the full list of Agda's options")++ , Option [] ["setup"] (NoArg setupFlag)+ ("setup the Agda data directory")+ ]++mainModeOptions :: (String, [OptDescr (Flag CommandLineOptions)])+mainModeOptions = ("Main modes of operation",)+ [ Option [] ["build-library"] (NoArg \ o -> return o{ optBuildLibrary = True })+ "build all modules included by the @.agda-lib@ file in the current directory"++ , Option ['I'] ["interactive"] (NoArg interactiveFlag)+ "start in interactive mode"++ , Option [] ["interaction"] (NoArg ghciInteractionFlag)+ "for use with the Emacs mode"+ , Option [] ["interaction-json"] (NoArg jsonInteractionFlag)+ "for use with other editors such as Atom"+ ]++projectOptions :: (String, [OptDescr (Flag CommandLineOptions)])+projectOptions = ("Project configuration",)+ [ Option ['i'] ["include-path"] (ReqArg includeFlag "DIR")+ "look for imports in DIR"+ , Option ['l'] ["library"] (ReqArg libraryFlag "LIB")+ "use library LIB"+ , Option [] ["library-file"] (ReqArg overrideLibrariesFileFlag "FILE")+ "use FILE instead of the standard libraries file"+ , Option [] ["no-libraries"] (NoArg noLibsFlag)+ "don't use any library files"+ , Option [] ["no-default-libraries"] (NoArg noDefaultLibsFlag)+ "don't use default libraries"+ ]++essentialConfigurationOptions :: (String, [OptDescr (Flag CommandLineOptions)])+essentialConfigurationOptions = ("Essential type checker configuration",)+ [ Option [] ["ignore-interfaces"] (NoArg ignoreInterfacesFlag)+ "ignore interface files (re-type check everything)"+ , Option [] ["no-write-interfaces"] (NoArg noWriteInterfacesFlag)+ "don't write interface files to the filesystem"++ , Option [] ["only-scope-checking"] (NoArg onlyScopeCheckingFlag)+ "only scope-check the top-level module, do not type-check it"+ , Option [] ["interaction-exit-on-error"]+ (NoArg interactionExitFlag)+ "exit if a type error is encountered"+ , Option [] ["vim"] (NoArg vimFlag)+ "generate Vim highlighting files"+ , Option ['j'] ["parallel"] (OptArg parallelismFlag "N")+ "use N cores for parallel type-checking. The default is 1, 0 (or no argument) means auto."+ ]++literateOptions :: (String, [OptDescr (Flag CommandLineOptions)])+literateOptions = ("Literate Agda",)+ [ Option [] ["literate-markdown-only-agda-blocks"] (NoArg $ mdOnlyAgdaBlocksFlag True)+ "in literate Markdown/Typst, only treat code blocks marked ```agda as Agda code"+ , Option [] ["no-literate-markdown-only-agda-blocks"] (NoArg $ mdOnlyAgdaBlocksFlag False)+ "treat all code blocks as Agda code (default)"+ ]++diagnosticsOptions :: (String, [OptDescr (Flag CommandLineOptions)])+diagnosticsOptions = ("Diagnostics and output",) $+ [ Option [] ["colour", "color"] (OptArg diagnosticsColour (intercalate "|" colorValues))+ ("whether or not to colour diagnostics output. The default is auto.")++ , Option [] ["trace-imports"] (OptArg traceImportsFlag traceImportsArg)+ (concat+ [ "print information about accessed modules during type-checking (where "+ , traceImportsArg+ , "="+ , intercalate "|" traceImportsValues+ , ", default: 2)"+ ])++ , Option [] ["transliterate"] (NoArg transliterateFlag)+ "transliterate unsupported code points when printing to stdout/stderr"+ ] ++ map (fmap lensPragmaOptions) (snd unicodePragmaOptions)++compilationOptions :: (String, [OptDescr (Flag CommandLineOptions)])+compilationOptions = ("Compilation options",) $+ [ Option [] ["compile-dir"] (ReqArg compileDirFlag "DIR")+ ("directory for compiler output (default: the project root)")+ ] ++ map (fmap lensPragmaOptions) (snd compilationPragmaOptions)++-- | Command line options of previous versions of Agda.+-- Should not be listed in the usage info, put parsed by GetOpt for good error messaging.+deadStandardOptions :: [OptDescr (Flag CommandLineOptions)]+deadStandardOptions =+ [ removedOption "sharing" msgSharing+ , removedOption "no-sharing" msgSharing+ , removedOption "local-interfaces" "(in 2.8.0)"+ , Option [] ["ignore-all-interfaces"] (NoArg ignoreAllInterfacesFlag) -- not deprecated! Just hidden+ "ignore all interface files (re-type check everything, including builtin files)"+ -- https://github.com/agda/agda/issues/3522#issuecomment-461010898+ -- The option is "developer only", so it is hidden.+ -- However, it is documented in the user manual.+ ] ++ map (fmap lensPragmaOptions) deadPragmaOptions+ where+ msgSharing = "(in favor of the Agda abstract machine)"++-- | This list should contain all pragma options except for the 'deadPragmaOptions'.+pragmaOptions :: [OptDescr (Flag PragmaOptions)]+pragmaOptions = concat $ map snd+ [ unicodePragmaOptions+ , warningPragmaOptions+ , checkerPragmaOptions+ , languagePragmaOptions+ , universePragmaOptions+ , modalityPragmaOptions+ , terminationPragmaOptions+ , patternMatchingPragmaOptions+ , instancePragmaOptions+ , rewritingPragmaOptions+ , equalityCheckingPragmaOptions+ , optimizationPragmaOptions+ , printerPragmaOptions+ , latexPragmaOptions+ , backendPragmaOptions+ , compilationPragmaOptions+ , debuggingPragmaOptions+ , reflectionPragmaOptions+ ]++warningPragmaOptions :: (String, [OptDescr (Flag PragmaOptions)])+warningPragmaOptions = ("Warnings",) $ concat+ [ [ Option ['W'] ["warning"] (ReqArg warningModeFlag warningArg)+ ("set warning flags. See --help=warning.")+ ]+ ]++-- | Controlling extra checks (termination etc.).+checkerPragmaOptions :: (String, [OptDescr (Flag PragmaOptions)])+checkerPragmaOptions = ("Consistency checking",) $ concat+ [ pragmaFlag "allow-unsolved-metas" lensOptAllowUnsolved+ "succeed and create interface file regardless of unsolved meta variables" ""+ Nothing+ , pragmaFlag "allow-incomplete-matches" lensOptAllowIncompleteMatch+ "succeed and create interface file regardless of incomplete pattern matches" ""+ Nothing+ , pragmaFlag "positivity-check" lensOptPositivityCheck+ "warn about not strictly positive data types" ""+ Nothing+ , pragmaFlag "termination-check" lensOptTerminationCheck+ "warn about possibly nonterminating code" ""+ Nothing+ , [ Option [] ["termination-depth"] (ReqArg terminationDepthFlag "N")+ ("allow termination checker to count decrease/increase upto N (default N=" +++ show (1 + defaultCutOff) ++ ")")+ ]+ , [ Option [] ["safe"] (NoArg safeFlag)+ "disable postulates, unsafe OPTION pragmas and primEraseEquality, implies --no-sized-types"+ ]+ , pragmaFlag "allow-exec" lensOptAllowExec+ "allow system calls to trusted executables with primExec" ""+ Nothing+ ]++-- | Main flavor of language.+languagePragmaOptions :: (String, [OptDescr (Flag PragmaOptions)])+languagePragmaOptions = ("Language variant",)+ [ Option [] ["without-K"] (NoArg withoutKFlag)+ "turn on checks to make code compatible with HoTT (e.g. disabling the K rule). Implies --no-flat-split."+ , Option [] ["cubical"] (OptArg cubicalFlagOptArg "VARIANT")+ $ "enable cubical features (e.g. overloads lambdas for paths)." +++ "Accepted variants: full, erased, no-glue, compatible (default: full)."+ -- For backwards compatibility only. Use "--cubical=compatible" instead.+ , Option [] ["cubical-compatible"] (NoArg cubicalCompatibleFlag)+ "turn on generation of auxiliary code required for --cubical, implies --without-K"+ -- For backwards compatibility only. Use "--cubical=erased" instead.+ , Option [] ["erased-cubical"] (NoArg $ cubicalFlag CErased)+ "enable cubical features (some only in erased settings), implies --cubical=compatible"+ , Option [] ["with-K"] (NoArg withKFlag)+ "enable the K rule in pattern matching (default)"+ ]++universePragmaOptions :: (String, [OptDescr (Flag PragmaOptions)])+universePragmaOptions = ("Universes",) $ concat+ [ pragmaFlag "type-in-type" lensOptNoUniverseCheck+ "ignore universe levels" "(this makes Agda inconsistent)"+ Nothing+ , pragmaFlag "omega-in-omega" lensOptOmegaInOmega+ "enable typing rule Setω : Setω" "(this makes Agda inconsistent)"+ Nothing+ , pragmaFlag "cumulativity" lensOptCumulativity+ "enable subtyping of universes" "(e.g. Set =< Set₁)"+ $ Just "disable subtyping of universes"+ , pragmaFlag "irrelevance" lensOptIrrelevance+ "enable the use of the irrelevance modality" ""+ $ Just "disable the use of the irrelevance modality"+ , pragmaFlag "prop" lensOptProp+ "enable the use of the Prop universe" ""+ $ Just "disable the use of the Prop universe"+ , pragmaFlag "level-universe" lensOptLevelUniverse+ "place type Level in a dedicated LevelUniv universe" ""+ Nothing+ , pragmaFlag "two-level" lensOptTwoLevel+ "enable the use of SSet* universes" ""+ Nothing+ , pragmaFlag "universe-polymorphism" lensOptUniversePolymorphism+ "enable universe polymorphism" ""+ $ Just "disable universe polymorphism"+ , pragmaFlag "large-indices" lensOptLargeIndices+ "allow constructors with large indices" ""+ $ Just "always check that constructor arguments live in universes compatible with that of the datatype"++ , pragmaFlag "import-sorts" lensOptImportSorts+ "implicitly import Agda.Primitive using (Set; Prop) at the start of each top-level module" ""+ $ Just "disable the implicit import of Agda.Primitive using (Set; Prop) at the start of each top-level module"+ , pragmaFlag "load-primitives" lensOptLoadPrimitives+ "load primitives modules" ""+ $ Just "disable loading of primitive modules completely (implies --no-import-sorts)"+ ]++modalityPragmaOptions :: (String, [OptDescr (Flag PragmaOptions)])+modalityPragmaOptions = ("Modalities",) $ concat+ [ pragmaFlag "erasure" lensOptErasure+ "enable erasure" ""+ Nothing+ , [ Option [] ["erased-matches"]+ (OptArg parseErasedMatchesArg erasedMatchesArg)+ ("allow erased matches of the given (comma-separated) " +++ erasedMatchesArg ++ " (" +++ intercalate ", " erasedMatchesValues ++ ")")+ , Option [] ["no-erased-matches"]+ (NoArg (parseErasedMatchesArg (Just "none")))+ "a synonym for --erased-matches=none"+ ]+ , pragmaFlag "erase-record-parameters" lensOptEraseRecordParameters+ "mark all parameters of record modules as erased" "(implies --erasure)"+ Nothing+ , pragmaFlag "cohesion" lensOptCohesion+ "enable the cohesion modalities" "(in particular @flat)"+ Nothing+ , pragmaFlag "flat-split" lensOptFlatSplit+ "allow splitting on `(@flat x : A)' arguments" "(implies --cohesion)"+ Nothing+ , pragmaFlag "guarded" lensOptGuarded+ "enable @lock/@tick attributes" ""+ $ Just "disable @lock/@tick attributes"+ , pragmaFlag "polarity" lensOptPolarity+ "enable the polarity modalities (@++, @mixed, etc.) and their integration in the positivity checker" ""+ Nothing+ , pragmaFlag "occurrence-analysis" lensOptOccurrence+ "enable automated occurrence analysis for functions"+ "(can be slow)"+ Nothing+ , pragmaFlag "erased-funext" lensOptFunext+ "allow the use of Agda.Builtin.Erased.Funext" ""+ Nothing+ , pragmaFlag "erased-propext" lensOptPropext+ "allow the use of Agda.Builtin.Erased.Propext" ""+ Nothing+ , pragmaFlag "erased-quotients" lensOptQuotients+ "allow the use of Agda.Builtin.Erased.Quotient" ""+ Nothing+ , pragmaFlag "irrelevant-projections" lensOptIrrelevantProjections+ "enable projection of irrelevant record fields and similar irrelevant definitions" "(inconsistent)"+ $ Just "disable projection of irrelevant record fields and similar irrelevant definitions"+ , pragmaFlag "experimental-irrelevance" lensOptExperimentalIrrelevance+ "enable potentially unsound irrelevance features" "(irrelevant levels, irrelevant data matching)"+ Nothing+ ]++terminationPragmaOptions :: (String, [OptDescr (Flag PragmaOptions)])+terminationPragmaOptions = ("Termination and productivity checking",) $ concat+ [ pragmaFlag "sized-types" lensOptSizedTypes+ "enable sized types" "(inconsistent with --guardedness)"+ $ Just "disable sized types"+ , pragmaFlag "guardedness" lensOptGuardedness+ "enable constructor-based guarded corecursion" "(inconsistent with --sized-types)"+ $ Just "disable constructor-based guarded corecursion"+ , pragmaFlag "forced-argument-recursion" lensOptForcedArgumentRecursion+ "allow recursion on forced constructor arguments" ""+ Nothing+ ]++patternMatchingPragmaOptions :: (String, [OptDescr (Flag PragmaOptions)])+patternMatchingPragmaOptions = ("Pattern matching",) $ concat+ [ pragmaFlag "pattern-matching" lensOptPatternMatching+ "enable pattern matching" ""+ $ Just "disable pattern matching completely"+ , pragmaFlag "copatterns" lensOptCopatterns+ "enable definitions by copattern matching" ""+ $ Just "disable definitions by copattern matching"+ , [ Option [] ["exact-split"] (NoArg $ exactSplitFlag True)+ "require all clauses in a definition to hold as definitional equalities (unless marked CATCHALL)"+ , Option [] ["no-exact-split"] (NoArg $ exactSplitFlag False)+ "do not require all clauses in a definition to hold as definitional equalities (default)"+ ]+ , pragmaFlag "hidden-argument-puns" lensOptHiddenArgumentPuns+ "interpret the patterns {x} and {{x}} as puns" ""+ Nothing+ , pragmaFlag "injective-type-constructors" lensOptInjectiveTypeConstructors+ "enable injective type constructors" "(makes Agda anti-classical and possibly inconsistent)"+ $ Just "disable injective type constructors"+ , [ Option [] ["inversion-max-depth"] (ReqArg inversionMaxDepthFlag "N")+ "set maximum depth for pattern match inversion to N (default: 50)"+ ]+ ]++instancePragmaOptions :: (String, [OptDescr (Flag PragmaOptions)])+instancePragmaOptions = ("Instance search",) $ concat+ [ [ Option [] ["instance-search-depth"] (ReqArg instanceDepthFlag "N")+ "set instance search depth to N (default: 500)"+ ]+ , backtrackingInstancesOption+ , pragmaFlag "qualified-instances" lensOptQualifiedInstances+ "use instances with qualified names" ""+ Nothing+ , pragmaFlag "experimental-lazy-instances" lensOptExperimentalLazyInstances+ "enable experimental, faster implementation of instance search" ""+ Nothing+ ]++rewritingPragmaOptions :: (String, [OptDescr (Flag PragmaOptions)])+rewritingPragmaOptions = ("Rewriting and confluence",) $ concat+ [ pragmaFlag "rewriting" lensOptRewriting+ "enable declaration and use of REWRITE rules" ""+ $ Just "disable declaration and use of REWRITE rules"+ , [ Option [] ["local-confluence-check"] (NoArg $ confluenceCheckFlag LocalConfluenceCheck)+ "enable checking of local confluence of REWRITE rules"+ , Option [] ["confluence-check"] (NoArg $ confluenceCheckFlag GlobalConfluenceCheck)+ "enable global confluence checking of REWRITE rules (more restrictive than --local-confluence-check)"+ , Option [] ["no-confluence-check"] (NoArg noConfluenceCheckFlag)+ "disable confluence checking of REWRITE rules (default)"+ ]+ , pragmaFlag "local-rewriting" lensOptLocalRewriting+ "enable declaring local rewrite rules with the @rewrite annotation" ""+ $ Just "disable local rewrite rules"+ ]++equalityCheckingPragmaOptions :: (String, [OptDescr (Flag PragmaOptions)])+equalityCheckingPragmaOptions = ("Definitional equality",) $ concat+ [ pragmaFlag "eta-equality" lensOptEta+ "default records to eta-equality" ""+ $ Just "default records to no-eta-equality"+ , lossyUnificationOption+ , requireUniqueMetaSolutionsOptions+ , [ 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)"+ ]+ , pragmaFlag "auto-inline" lensOptAutoInline+ "enable automatic compile-time inlining" ""+ $ Just "disable automatic compile-time inlining, only definitions marked INLINE will be inlined"++ , pragmaFlag "fast-reduce" lensOptFastReduce+ "enable reduction using the Agda Abstract Machine" ""+ $ Just "disable reduction using the Agda Abstract Machine"+ , pragmaFlag "call-by-name" lensOptCallByName+ "use call-by-name evaluation instead of call-by-need" ""+ $ Just "use call-by-need evaluation"+ ]++optimizationPragmaOptions :: (String, [OptDescr (Flag PragmaOptions)])+optimizationPragmaOptions = ("Type checker optimizations",) $ concat+ [ pragmaFlag "caching" lensOptCaching+ "enable caching of typechecking" ""+ $ Just "disable caching of typechecking"+ , pragmaFlag "double-check" lensOptDoubleCheck+ "enable double-checking of all terms using the internal typechecker" ""+ $ Just "disable double-checking of terms"+ , pragmaFlag "forcing" lensOptForcing+ "enable the forcing analysis for data constructors" "(optimisation)"+ $ Just "disable the forcing analysis"+ , pragmaFlag "projection-like" lensOptProjectionLike+ "enable the analysis whether function signatures liken those of projections" "(optimisation)"+ $ Just "disable the projection-like analysis"+ , pragmaFlag "infer-absurd-clauses" lensOptInferAbsurdClauses+ "eliminate absurd clauses in case splitting and coverage checking" ""+ $ Just "do not automatically eliminate absurd clauses in case splitting and coverage checking (can speed up type-checking)"+ , pragmaFlag "save-metas" lensOptSaveMetas+ "save meta-variables" ""+ Nothing+ ]++unicodePragmaOptions :: (String, [OptDescr (Flag PragmaOptions)])+unicodePragmaOptions = ("Unicode",) $ concat+ [ pragmaFlag' "unicode" lensOptUseUnicode unicodeOrAsciiEffect+ "use unicode characters when printing terms" ""+ Nothing+ ]++-- | Controlling the rendering of Agda expressions.+printerPragmaOptions :: (String, [OptDescr (Flag PragmaOptions)])+printerPragmaOptions = ("Checker output",) $ concat+ [ pragmaFlag "show-implicit" lensOptShowImplicit+ "show implicit arguments when printing" ""+ Nothing+ , pragmaFlag "show-irrelevant" lensOptShowIrrelevant+ "show irrelevant arguments when printing" ""+ Nothing+ , pragmaFlag "show-identity-substitutions" lensOptShowIdentitySubstitutions+ "show all arguments of metavariables when printing terms" ""+ Nothing+ , pragmaFlag "print-pattern-synonyms" lensOptPrintPatternSynonyms+ "keep pattern synonyms when printing terms" ""+ $ Just "expand pattern synonyms when printing terms"+ , pragmaFlag "postfix-projections" lensOptPostfixProjections+ "prefer postfix projection notation" ""+ $ Just "prefer prefix projection notation"+ , pragmaFlag "keep-pattern-variables" lensOptKeepPatternVariables+ "don't replace variables with dot patterns during case splitting" ""+ $ Just "replace variables with dot patterns during case splitting"+ ]++-- | Latex pragma options.+latexPragmaOptions :: (String, [OptDescr (Flag PragmaOptions)])+latexPragmaOptions = ("Latex options",) $ concat+ [ pragmaFlag "count-clusters" lensOptCountClusters+ "count extended grapheme clusters when generating LaTeX"+ ("(note that this flag " +++#ifdef COUNT_CLUSTERS+ "is not enabled in all builds"+#else+ "has not been enabled in this build"+#endif+ ++ " of Agda)")+ Nothing+ ]++-- | Backend-relevant options.+backendPragmaOptions :: (String, [OptDescr (Flag PragmaOptions)])+backendPragmaOptions = ("Backend options",) $ concat+ [ pragmaFlag "keep-covering-clauses" lensOptKeepCoveringClauses+ "do not discard covering clauses" "(required for some external backends)"+ $ Just "discard covering clauses"+ ]++-- | Common options for compilers.+compilationPragmaOptions :: (String, [OptDescr (Flag PragmaOptions)])+compilationPragmaOptions = ("Compilation options",) $ concat+ [ pragmaFlag "main" lensOptCompileMain+ "treat the requested module as the main module of a program when compiling" ""+ Nothing+ ]++-- | Debugging and profiling Agda.+debuggingPragmaOptions :: (String, [OptDescr (Flag PragmaOptions)])+debuggingPragmaOptions = ("Debugging and profiling Agda",) $ concat+ [ [ Option ['v'] ["verbose"] (ReqArg verboseFlag "N")+ "set verbosity level to N. Only has an effect if Agda was built with the \"debug\" flag."+ , Option [] ["profile"] (ReqArg profileFlag profileArg)+ (concat+ [ "turn on profiling for "+ , profileArg+ , " (where "+ , profileArg+ , "="+ , intercalate "|" profileValues+ , ")"+ ])+ ]+ ]++reflectionPragmaOptions :: (String, [OptDescr (Flag PragmaOptions)])+reflectionPragmaOptions = ("Reflection",) $ concat+ [ pragmaFlag "quote-metas" lensOptQuoteMetas+ "allow unquoting to not get blocked by metas" ""+ Nothing+ ]++-- | Construct a flag of type @WithDefault _@+--+pragmaFlag :: (IsBool a, KnownBool b)+ => String+ -- ^ Long option name. Prepended with @no-@ for negative version.+ -> Lens' PragmaOptions (WithDefault' a b)+ -- ^ Field to switch.+ -> String+ -- ^ Explanation for positive option.+ -> String+ -- ^ Additional info for positive option (not repeated for negative option).+ -> Maybe String+ -- ^ Explanation for negative option.+ -> [OptDescr (Flag PragmaOptions)]+pragmaFlag long field = pragmaFlag' long field (const return)++-- | Construct a flag of type @WithDefault _@+--+pragmaFlag' :: (IsBool a, KnownBool b)+ => String+ -- ^ Long option name. Prepended with @no-@ for negative version.+ -> Lens' PragmaOptions (WithDefault' a b)+ -- ^ Field to switch.+ -> (a -> Flag PragmaOptions)+ -- ^ Given the new value, perform additional effect (can override field setting).+ -> String+ -- ^ Explanation for positive option.+ -> String+ -- ^ Additional info for positive option (not repeated for negative option).+ -> Maybe String+ -- ^ Explanation for negative option.+ -> [OptDescr (Flag PragmaOptions)]+ -- ^ Pair of option descriptors (positive, negative)+pragmaFlag' long field = pragmaFlagBool' long (field . lensCollapseDefault)++-- | Construct a flag of type 'IsBool'.+--+pragmaFlagBool :: (IsBool a)+ => String+ -- ^ Long option name. Prepended with @no-@ for negative version.+ -> Lens' PragmaOptions a+ -- ^ Field to switch.+ -> String+ -- ^ Explanation for positive option.+ -> String+ -- ^ Additional info for positive option (not repeated for negative option).+ -> Maybe String+ -- ^ Explanation for negative option.+ -> [OptDescr (Flag PragmaOptions)]+pragmaFlagBool long field = pragmaFlagBool' long field (const return)++-- | Construct a flag of type 'IsBool' with extra effect.+--+pragmaFlagBool' :: IsBool a+ => String+ -- ^ Long option name. Prepended with @no-@ for negative version.+ -> Lens' PragmaOptions a+ -- ^ Field to switch.+ -> (a -> Flag PragmaOptions)+ -- ^ Given the new value, perform additional effect (can override field setting).+ -> String+ -- ^ Explanation for positive option.+ -> String+ -- ^ Additional info for positive option (not repeated for negative option).+ -> Maybe String+ -- ^ Explanation for negative option.+ -> [OptDescr (Flag PragmaOptions)]+ -- ^ Pair of option descriptors (positive, negative)+pragmaFlagBool' long field effect pos info neg =+ [ Option [] [no b long] (flag b) (def b $ expl b) | b <- [True,False] ]+ where+ b0 = defaultPragmaOptions ^. field+ no b = applyUnless b ("no-" ++)+ flag b = NoArg $ effect a . set field a+ where a = fromBool b+ def b = applyWhen (fromBool b == b0) (++ " (default)")+ expl b = if b then unwords1 [pos, info] else fromMaybe ("do not " ++ pos) neg++pragmaOptionDefault :: KnownBool b => (PragmaOptions -> WithDefault b) -> Bool -> String+pragmaOptionDefault f b =+ if b == collapseDefault (f defaultPragmaOptions) then " (default)" else ""++lossyUnificationOption :: [OptDescr (Flag PragmaOptions)]+lossyUnificationOption =+ pragmaFlag "lossy-unification" lensOptFirstOrder+ "enable heuristically unifying `f es = f es'` by unifying `es = es'`"+ "even when it could lose solutions"+ Nothing++requireUniqueMetaSolutionsOptions :: [OptDescr (Flag PragmaOptions)]+requireUniqueMetaSolutionsOptions =+ pragmaFlag "require-unique-meta-solutions" lensOptRequireUniqueMetaSolutions+ "require unique solutions to meta variables"+ "even when it could lose solutions"+ Nothing++backtrackingInstancesOption :: [OptDescr (Flag PragmaOptions)]+backtrackingInstancesOption =+ pragmaFlag "backtracking-instance-search" lensOptBacktrackingInstances+ "allow backtracking during instance search"+ ""+ Nothing++-- | 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 = 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"+ , headWithDefault __IMPOSSIBLE__ lossyUnificationOption+ )+ , ( "overlapping-instances"+ , headWithDefault __IMPOSSIBLE__ backtrackingInstancesOption+ )+ ]+ ]+ 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 ()]+standardOptions_ = map void standardOptions++-- | Simple interface for Agda.Utils.GetOpt+-- Could be moved to Agda.Utils.Options (does not exist yet)+getOptSimple+ :: [String] -- ^ command line argument words+ -> [OptDescr (Flag opts)] -- ^ options handlers+ -> (String -> Flag opts) -- ^ handler of non-options (only one is allowed)+ -> Flag opts -- ^ combined opts data structure transformer+getOptSimple argv opts fileArg = \ defaults ->+ case getOpt' (ReturnInOrder fileArg) opts argv of+ (o, _, [] , [] ) -> foldl (>>=) (return defaults) o+ (_, _, unrecognized, errs) -> throwError $ umsg ++ emsg++ where+ ucap = "Unrecognized " ++ String.pluralS unrecognized "option" ++ ":"+ ecap = String.pluralS errs "Option error" ++ ":"+ umsg = if null unrecognized then "" else unlines $+ ucap : map suggest unrecognized+ emsg = if null errs then "" else unlines $+ ecap : errs++ -- Suggest alternatives that are at most 3 typos away++ longopts :: [String]+ longopts = map ("--" ++) $ concatMap (\ (Option _ long _ _) -> long) opts++ dist :: String -> String -> Int+ dist s t = restrictedDamerauLevenshteinDistance defaultEditCosts s t++ close :: String -> String -> Maybe (Int, String)+ close s t = let d = dist s t in if d <= 3 then Just (d, t) else Nothing++ closeopts :: String -> [(Int, String)]+ closeopts s = mapMaybe (close s) longopts++ alts :: String -> [List1 String]+ alts s = map (fmap snd) $ List1.groupOn fst $ closeopts s++ suggest :: String -> String+ suggest s = case alts s of+ [] -> s+ as : _ -> s ++ " (did you mean " ++ sugs as ++ " ?)"++ sugs :: List1 String -> String+ sugs (a :| []) = a+ sugs as = "any of " ++ List1.unwords as++-- | Parse options from an options pragma.+parsePragmaOptions+ :: OptionsPragma+ -- ^ Pragma options.+ -> CommandLineOptions+ -- ^ Command-line options which should be updated.+ -> OptM PragmaOptions+parsePragmaOptions argv opts = do+ ps <- getOptSimple+ (pragmaStrings argv)+ (deadPragmaOptions ++ pragmaOptions)+ (\s _ -> throwError $ "Bad option in pragma: " ++ s)+ (optPragmaOptions opts)+ checkPragmaOptions ps++-- | Parse options for a plugin.+parsePluginOptions :: [String] -> [OptDescr (Flag opts)] -> Flag opts+parsePluginOptions argv opts =+ getOptSimple argv opts+ (\s _ -> throwError $+ "Internal error: Flag " ++ s ++ " passed to a plugin")++-- | Removes RTS options from a list of options.++stripRTS :: [String] -> [String]+stripRTS [] = []+stripRTS ("--RTS" : argv) = argv+stripRTS (arg : argv)+ | is "+RTS" arg = stripRTS $ drop 1 $ dropWhile (not . is "-RTS") argv+ | otherwise = arg : stripRTS argv+ where+ is x arg = [x] == take 1 (words arg)++------------------------------------------------------------------------+-- Erased matches++-- | Different options for @--erased-matches@.++data ErasedMatchOption+ = None+ -- ^ No erased matches are allowed.+ | Empty+ -- ^ Erased matches are allowed for the empty type.+ | NonDependent+ -- ^ Erased matches are allowed for single-constructor,+ -- non-indexed data types.+ | Restricted+ -- ^ @[]-cong@ is allowed.+ | Unrestricted+ -- ^ All kinds of erased matches are allowed for+ -- single-constructor data types (indexed or not).+ deriving (Show, Generic, Enum, Bounded)++-- | Parses the argument of @--erased-matches@.++parseErasedMatchesArg :: Maybe String -> Flag PragmaOptions+parseErasedMatchesArg ms opts =+ (\allowed -> over' lensOptErasedMatches (<> allowed) opts) <$>+ case ms of+ Nothing -> return C.ErasedMatchesDefaultOn+ Just s ->+ mconcat . map (C.ErasedMatches . allowedErasedMatches) <$>+ mapM parse (chopWhen (== ',') s)+ where+ parse "none" = return None+ parse "empty" = return Empty+ parse "non-dependent" = return NonDependent+ parse "restricted" = return Restricted+ parse "unrestricted" = return Unrestricted+ parse s = throwError $+ "Unknown argument to --erased-matches: " ++ s++-- | Translates from 'ErasedMatchOption' to 'AllowedErasedMatches'.++allowedErasedMatches :: ErasedMatchOption -> AllowedErasedMatches+allowedErasedMatches None =+ mempty+allowedErasedMatches Empty = C.AllowedErasedMatches+ { emEmpty = True+ , emNonDependent = False+ , emDependent = Strict.Nothing+ }+allowedErasedMatches NonDependent = C.AllowedErasedMatches+ { emEmpty = False+ , emNonDependent = True+ , emDependent = Strict.Nothing+ }+allowedErasedMatches Restricted = C.AllowedErasedMatches+ { emEmpty = False+ , emNonDependent = False+ , emDependent = Strict.Just C.Restricted+ }+allowedErasedMatches Unrestricted = C.AllowedErasedMatches+ { emEmpty = False+ , emNonDependent = True+ , emDependent = Strict.Just C.Unrestricted+ }++-- | Translates from 'AllowedErasedMatches' to lists of+-- 'ErasedMatchOption's.++erasedMatchOptions :: AllowedErasedMatches -> List1 ErasedMatchOption+erasedMatchOptions allowed = List1.fromListSafe (None :| []) flags+ where+ flags =+ (if C.emEmpty allowed then [Empty] else []) +++ (if C.emUnrestricted allowed then [Unrestricted] else+ (if C.emRestricted allowed then [Restricted] else []) +++ (if C.emNonDependent allowed then [NonDependent] else []))++-- | Turns a non-empty list of 'ErasedMatchOption's into a+-- corresponding instance of @--erased-matches@.++showErasedMatchFlags :: List1 ErasedMatchOption -> String+showErasedMatchFlags opts =+ "--erased-matches=" +++ intercalate "," (fmap showOpt (List1.toList opts))+ where+ showOpt = \case+ None -> "none"+ Empty -> "empty"+ NonDependent -> "non-dependent"+ Unrestricted -> "unrestricted"+ Restricted -> "restricted"++-- | An instance of @--erased-matches@ that would lead to the given+-- 'AllowedErasedMatches' record.++showEffectiveErasedMatchFlags :: AllowedErasedMatches -> String+showEffectiveErasedMatchFlags =+ showErasedMatchFlags . erasedMatchOptions
+ src/full/Agda/Interaction/Options/BashCompletion.hs view
@@ -0,0 +1,158 @@+{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-}++-- | Tools for shell completion scripts.+--+-- Bash completion takes a list of completion words (the current commandline)+-- and a completion index (the current word to be completed) and returns+-- a list of possible completions of this word.+--+-- To do bash completion /inside/ Agda, we need to pass this data to Agda.+-- So we equip Agda with a special option @--bash-completion@ which takes+-- first the completion index (number) and then the completion words.+-- E.g.+--+-- @+-- agda --bash-completion 1 --warn+-- @+--+-- This should complete @--warn@ to @--warning=@.+--+-- @+-- agda --bash-completion 1 --warning=+-- @+--+-- This would list the possible values for WARNING.+-- However, these are too many and one may get the annoying question+-- whether one really wants to see all.+-- So we should only produce a small enough list.+-- We show the common prefixes of all values up to a maximal number (threshold).+-- To this end, we may store the possible completion as a compressed trie+-- where instead of letters we use maximal non-overlapping prefixes.+-- Then we compute a fair truncation of the tree so that the+-- total number of leaves stay below the threshold.++module Agda.Interaction.Options.BashCompletion where++import Prelude hiding (null)++import Data.Bifunctor ( first )+import Data.Map qualified as Map+import Data.Maybe+import Text.Read ( readMaybe )++import Agda.Interaction.Options.Arguments ( optionValues )+import Agda.Interaction.Options.Base ( standardOptions )++import Agda.Utils.Function ( applyWhenJust )+import Agda.Utils.GetOpt ( OptDescr(..), ArgDescr(..) )+import Agda.Utils.List ( (!!!) )+import Agda.Utils.List1 qualified as List1+import Agda.Utils.Null+import Agda.Utils.Trie (Trie)+import Agda.Utils.Trie qualified as Trie+import Agda.Utils.CompressedTrie qualified as CompressedTrie++type Help = String++printedOptions :: [String]+printedOptions = map fst printedOptionsWithHelp++printedOptionsWithHelp :: [(String, Help)]+printedOptionsWithHelp = printOptions standardOptions++-- | Print just the names of the given options (e.g. for bash completion scripts).+-- For long options with finitely enumerable arguments, print all variants.+printOptions :: [OptDescr a] -> [(String, Help)]+printOptions = concat . map \case+ Option short long arg help -> concat $+ map (,help) ss :+ map (,help) ls :+ map (map (,noHelp))+ [ [ s ++ a | s <- ss ] +++ [ l ++ "=" ++ a | l <- ls ]+ | a <- as+ ]+ where+ ss :: [String]+ ss = [ '-' : s : "" | s <- short ]+ ls :: [String]+ ls = [ "--" ++ l | l <- long ]+ as :: [String]+ as = fromMaybe [] do+ t <- argType+ Map.lookup t optionValues+ argType :: Maybe String+ argType = case arg of+ NoArg{} -> Nothing+ ReqArg _ t -> Just t+ OptArg _ t -> Just t+ noHelp :: Help+ noHelp = ""++-- | Should the 'completions' be truncated to a given maximum number of prefixes?+type Truncate = Maybe Int++-- | Handle the option @--bash-complete@.+-- It expects the index @COMP_CWORD@ as first argument+-- that tells which of the following arguments @COMP_WORDS@+-- is supposed to be completed.+--+-- It either returns an error message or the result for @COMPREPLY@.+--+bashComplete ::+ Truncate+ -- ^ Truncate completions suggestions? To how many?+ -> [String]+ -- ^ Arguments following @--bash-complete@.+ -> Either String String+ -- ^ Error or @COMPREPLY@.+bashComplete tr = \case+ cword : words+ | Just i <- readMaybe cword+ , length words > i+ , Just w <- words !!! i+ -> case complete tr w of+ Completion (Just s) _ -> return s+ Completion ms cs ->+ return $ unlines $ concat+ [ maybeToList ms+ , map fst cs+ ]+ _args -> Left "Error: Wrong invokation of --bash-complete"++-- | The result of an invokation of (bash) completion.+data Completion = Completion+ { extended :: Maybe String+ -- ^ If 'Nothing', then the completion word cannot become a valid option ever.+ , completions :: [(String, Help)]+ -- ^ If 'null', the 'extended' word cannot be further completed.+ }++-- | Cached trie of options.+optionsTrie :: Trie Char Help+optionsTrie = Trie.fromList printedOptionsWithHelp++-- | Complete the given word as an option.+complete :: Truncate -> String -> Completion+complete trunc s+ -- No completion possible?+ | null t =+ Completion Nothing []+ -- Unambiguously (partially) complete by at least one letter.+ | Just (k, _t') <- CompressedTrie.isSingleBranch t =+ Completion (Just $ s ++ List1.toList k) compls+ -- No unambiguous completion possible: just return suggestions.+ | otherwise =+ Completion Nothing compls+ where+ -- The possible suffixes.+ t = CompressedTrie.compress $ Trie.delete [] $ Trie.lookupTrie s optionsTrie+ -- The possibly truncated list of completions.+ compls = map (first (s ++)) $ CompressedTrie.toList $ CompressedTrie.substLeaves f tt+ where+ -- t truncated.+ tt = applyWhenJust trunc CompressedTrie.truncateSizeWithLeaves t+ -- Replace empty leaves by "..." branches.+ f = maybe (CompressedTrie.singleton "..." empty) CompressedTrie.root
+ src/full/Agda/Interaction/Options/Default.hs view
@@ -0,0 +1,140 @@+-- | Default values for the options.++module Agda.Interaction.Options.Default where++import Agda.Interaction.Options.ProfileOptions () -- Null instance+import Agda.Interaction.Options.Types+import Agda.Interaction.Options.Warnings ( defaultWarningMode )+import Agda.Termination.CutOff ( defaultCutOff )+import Agda.Utils.Null+import Agda.Utils.WithDefault++import Agda.Utils.Impossible++defaultOptions :: CommandLineOptions+defaultOptions = Options+ { optProgramName = "agda"+ , optInputFile = Nothing+ , optIncludePaths = []+ , optAbsoluteIncludePaths = []+ , optLibraries = []+ , optOverrideLibrariesFile = Nothing+ , optDefaultLibs = True+ , optUseLibs = True+ , optTraceImports = 1+ , optTrustedExecutables = empty+ , optPrintAgdaDataDir = False+ , optPrintAgdaAppDir = False+ , optPrintOptions = False+ , optPrintVersion = Nothing+ , optPrintHelp = Nothing+ , optBuildLibrary = False+ , optSetup = False+ , optEmacsMode = empty+ , optInteractive = False+ , optGHCiInteraction = False+ , optJSONInteraction = False+ , optExitOnError = False+ , optCompileDir = Nothing+ , optGenerateVimFile = False+ , optIgnoreInterfaces = False+ , optIgnoreAllInterfaces = False+ , optWriteInterfaces = True+ , optPragmaOptions = defaultPragmaOptions+ , optOnlyScopeChecking = False+ , optTransliterate = False+ , optDiagnosticsColour = AutoColour+ , optMdOnlyAgdaBlocks = False+ , optParallelChecking = Sequential+ }++defaultPragmaOptions :: PragmaOptions+defaultPragmaOptions = PragmaOptions+ { _optShowImplicit = Default+ , _optShowGeneralized = Default+ , _optShowIrrelevant = Default+ , _optUseUnicode = Default -- UnicodeOk+ , _optVerbose = empty+ , _optProfiling = empty+ , _optIrrelevance = Default+ , _optProp = Default+ , _optLevelUniverse = Default+ , _optTwoLevel = Default+ , _optAllowUnsolved = Default+ , _optAllowIncompleteMatch = Default+ , _optPositivityCheck = Default+ , _optTerminationCheck = Default+ , _optTerminationDepth = defaultCutOff+ , _optUniverseCheck = Default+ , _optOmegaInOmega = Default+ , _optCumulativity = Default+ , _optSizedTypes = Default+ , _optGuardedness = Default+ , _optInjectiveTypeConstructors = Default+ , _optUniversePolymorphism = Default+ , _optIrrelevantProjections = Default+ , _optExperimentalIrrelevance = Default+ , _optWithoutK = Default+ , _optCubicalCompatible = Default+ , _optCopatterns = Default+ , _optPatternMatching = Default+ , _optExactSplit = Default+ , _optHiddenArgumentPuns = Default+ , _optEta = Default+ , _optForcing = Default+ , _optProjectionLike = Default+ , _optErasure = Default+ , _optErasedMatches = mempty+ , _optEraseRecordParameters = Default+ , _optRewriting = Default+ , _optLocalRewriting = Default+ , _optCubical = Nothing+ , _optGuarded = Default+ , _optFirstOrder = Default+ , _optRequireUniqueMetaSolutions = Default+ , _optPostfixProjections = Default+ , _optKeepPatternVariables = Default+ , _optInferAbsurdClauses = Default+ , _optInstanceSearchDepth = 500+ , _optBacktrackingInstances = Default+ , _optQualifiedInstances = Default+ , _optInversionMaxDepth = 50+ , _optSafe = Default+ , _optDoubleCheck = Default+ , _optSyntacticEquality = empty+ , _optWarningMode = defaultWarningMode+ , _optCompileMain = Default+ , _optCaching = Default+ , _optCountClusters = Default+ , _optAutoInline = Default+ , _optPrintPatternSynonyms = Default+ , _optFastReduce = Default+ , _optCallByName = Default+ , _optConfluenceCheck = Nothing+ , _optCohesion = Default+ , _optFlatSplit = Default+ , _optPolarity = Default+ , _optOccurrence = Default+ , _optFunext = Default+ , _optPropext = Default+ , _optQuotients = Default+ , _optImportSorts = Default+ , _optLoadPrimitives = Default+ , _optAllowExec = Default+ , _optSaveMetas = Default+ , _optShowIdentitySubstitutions = Default+ , _optKeepCoveringClauses = Default+ , _optForcedArgumentRecursion = Default+ , _optLargeIndices = Default+ , _optExperimentalLazyInstances = Default+ , _optQuoteMetas = Default+ }++-- Null instances++instance Null CommandLineOptions where+ empty = defaultOptions+ null = __IMPOSSIBLE__++instance Null PragmaOptions where+ empty = defaultPragmaOptions
src/full/Agda/Interaction/Options/Errors.hs view
@@ -35,10 +35,14 @@ data ErasedDatatypeReason = SeveralConstructors -- ^ There are several constructors.- | NoErasedMatches- -- ^ The flag @--erased-matches@ is not used.- | NoK- -- ^ The K rule is not activated.+ | ErasedMatchesDisabledEmpty+ -- ^ Erased matches are disabled for empty types.+ | ErasedMatchesDisabledNonDependent+ -- ^ Erased matches are disabled for non-indexed,+ -- single-constructor types.+ | ErasedMatchesDisabledDependent+ -- ^ Erased matches are disabled for indexed, single-constructor+ -- types. deriving (Show, Generic, Enum, Bounded) -- | Things not allowed in dot patterns.@@ -54,8 +58,8 @@ = MissingRHS | NotAValidLetPattern | WhereClausesNotAllowed+ | CopatternsNotAllowed -- These cannot be triggered:- -- -- | CopatternsNotAllowed -- -- | EllipsisNotAllowed -- -- | WithPatternsNotAllowed deriving (Show, Generic, Enum, Bounded)@@ -81,8 +85,6 @@ -- Generic errors (alphabetically) | CompilationError_ | CustomBackendError_- | GenericError_- | GenericDocError_ | InternalError_ | LibraryError_ | NonFatalErrors_@@ -90,6 +92,7 @@ | NotSupported_ | OptionError_ | SyntaxError_+ | UserError_ -- Other errors (alphabetically) | AbsentRHSRequiresAbsurdPattern_ | AbstractConstructorNotInScope_@@ -116,8 +119,10 @@ | CannotApply_ | CannotEliminateWithPattern_ | CannotEliminateWithProjection_+ | CannotGeneralizeEtaExpandable_ | CannotGenerateHCompClause_ | CannotGenerateTransportClause_+ | CannotGenerateTransportLocalRewrite_ | CannotQuote_ CannotQuote_ | CannotQuoteTerm_ CannotQuoteTerm | CannotResolveAmbiguousPatternSynonym_@@ -151,6 +156,7 @@ | DuplicateOverlapPragma_ | DuplicatePrimitiveBinding_ | EmptyTypeOfSizes_+ | EtaPragmaVsNoEtaEquality_ | ExpectedBindingForParameter_ | ExpectedIntervalLiteral_ | FieldOutsideRecord_@@ -159,6 +165,10 @@ | FileNotFound_ | ForcedConstructorNotInstantiated_ | FunctionTypeInSizeUniv_+ | GeneralizationFailed_+ | GeneralizationPrepruneErrorRefinedContext_+ | GeneralizationPrepruneErrorCyclicDependencies_+ | GeneralizationPrepruneErrorFailedToInstantiate_ | GeneralizeCyclicDependency_ | GeneralizeNotSupportedHere_ | GeneralizedVarInLetOpenedModule_@@ -168,8 +178,8 @@ | InvalidBuiltin_ | InvalidDottedExpression_ | IllTypedPatternAfterWithAbstraction_+ | IlltypedRewriteRule_ | IllegalDeclarationBeforeTopLevelModule_- | IllegalDeclarationInDataDefinition_ | IllegalHidingInPostfixProjection_ | IllegalInstanceVariableInPatternSynonym_ | IllegalLetInTelescope_@@ -193,6 +203,7 @@ | MetaErasedSolution_ | MetaIrrelevantSolution_ | MismatchedProjectionsError_+ | MissingBindingsForTelescopeVariables_ | MissingTypeSignature_ DataRecOrFun_ | ModuleArityMismatch_ | ModuleDefinedInOtherFile_@@ -203,10 +214,12 @@ | ExplicitPolarityVsPragma_ | ConstructorNameOfNonRecord_ | NamedWhereModuleInRefinedContext_+ | NamedWhereModuleUnderWith_ | NeedOptionAllowExec_ | NeedOptionCopatterns_ | NeedOptionCubical_ | NeedOptionPatternMatching_+ | NeedOptionIrrelevance_ | NeedOptionProp_ | NeedOptionRewriting_ | NeedOptionSizedTypes_@@ -240,7 +253,6 @@ | QualifiedLocalModule_ | QuantityMismatch_ | RecordIsErased_- | RecursiveRecordNeedsInductivity_ | ReferencesFutureVariables_ | RelevanceMismatch_ | RepeatedNamesInImportDirective_@@ -273,21 +285,17 @@ | TooManyFields_ | TooManyPatternsInWithClause_ | TriedToCopyConstrainedPrim_+ | TrustedBuiltin_+ | TrustedPrimitive_ | InvalidInstanceHeadType_ | UnboundVariablesInPatternSynonym_- | UnequalCohesion_- | UnequalFiniteness_- | UnequalHiding_- | UnequalLevel_- | UnequalQuantity_- | UnequalRelevance_- | UnequalPolarity_- | UnequalSorts_ | UnequalTerms_+ | UnequalTypes_ | UnexpectedModalityAnnotationInParameter_ | UnexpectedParameter_ | UnexpectedTypeSignatureForParameter_ | UnexpectedWithPatterns_+ | UnguardedEtaRecord_ | UnknownBackend_ | UnusableAtModality_ | UnusedVariableInPatternSynonym_@@ -307,6 +315,7 @@ | WrongHidingInProjection_ | WrongIrrelevanceInLambda_ | WrongNamedArgument_+ | WrongNamedArgumentInLHS_ | WrongNumberOfConstructorArguments_ | WrongQuantityInLambda_ | WrongSharpArity_@@ -377,7 +386,6 @@ | BlockedType_ | CannotCreateMissingClause_ | CoinductiveDatatype_- | CosplitCatchall_ | CosplitNoRecordType_ | CosplitNoTarget_ | NotADatatype_@@ -406,6 +414,7 @@ | ConInsteadOfDef_ | DefineDataNotData_ | DefInsteadOfCon_+ | EscapingVariable_ | MissingDeclaration_ | MissingDefinition_ | NakedUnquote_@@ -529,8 +538,8 @@ MissingRHS -> "Missing right hand side in let binding" NotAValidLetPattern -> "Not a valid let pattern" WhereClausesNotAllowed -> "`where` clauses not allowed in let bindings"+ CopatternsNotAllowed -> "Copatterns not allowed in let bindings" -- These cannot be triggered:- -- CopatternsNotAllowed -> "Copatterns not allowed in let bindings" -- EllipsisNotAllowed -> "`...` not allowed in let bindings" -- WithPatternsNotAllowed -> "`with` patterns not allowed in let bindings" @@ -544,7 +553,7 @@ deriving via (FiniteEnumeration (Maybe a)) instance (Bounded a, Enum a) => Enum (Maybe a) deriving via (FiniteEnumeration (Maybe a))- instance (Bounded a, Enum a) => Bounded (Maybe a)+ instance (Bounded a) => Bounded (Maybe a) instance NFData CannotQuoteTerm instance NFData ErasedDatatypeReason
src/full/Agda/Interaction/Options/HasOptions.hs view
@@ -15,6 +15,9 @@ import Agda.Interaction.Options.Types (PragmaOptions, CommandLineOptions) import Agda.Utils.Update (ChangeT) import Agda.Utils.ListT (ListT)+import Agda.Utils.StrictReader qualified as Strict+import Agda.Utils.StrictWriter qualified as Strict+import Agda.Utils.StrictState qualified as Strict class (Functor m, Applicative m, Monad m) => HasOptions m where -- | Returns the pragma options which are currently in effect.@@ -39,3 +42,6 @@ instance HasOptions m => HasOptions (ReaderT r m) instance HasOptions m => HasOptions (StateT s m) instance (HasOptions m, Monoid w) => HasOptions (WriterT w m)+instance HasOptions m => HasOptions (Strict.ReaderT r m)+instance HasOptions m => HasOptions (Strict.StateT s m)+instance (HasOptions m, Monoid w) => HasOptions (Strict.WriterT w m)
src/full/Agda/Interaction/Options/Lenses.hs view
@@ -114,44 +114,26 @@ --------------------------------------------------------------------------- class LensIncludePaths a where- getIncludePaths :: a -> [FilePath]- setIncludePaths :: [FilePath] -> a -> a- mapIncludePaths :: ([FilePath] -> [FilePath]) -> a -> a- getAbsoluteIncludePaths :: a -> [AbsolutePath] setAbsoluteIncludePaths :: [AbsolutePath] -> a -> a mapAbsoluteIncludePaths :: ([AbsolutePath] -> [AbsolutePath]) -> a -> a -- default implementations- setIncludePaths = mapIncludePaths . const- mapIncludePaths f a = setIncludePaths (f $ getIncludePaths a) a setAbsoluteIncludePaths = mapAbsoluteIncludePaths . const mapAbsoluteIncludePaths f a = setAbsoluteIncludePaths (f $ getAbsoluteIncludePaths a) a instance LensIncludePaths CommandLineOptions where- getIncludePaths = optIncludePaths- setIncludePaths is opts = opts { optIncludePaths = is } getAbsoluteIncludePaths = optAbsoluteIncludePaths setAbsoluteIncludePaths is opts = opts { optAbsoluteIncludePaths = is } instance LensIncludePaths PersistentTCState where- getIncludePaths = getIncludePaths . getCommandLineOptions- mapIncludePaths = mapCommandLineOptions . mapIncludePaths getAbsoluteIncludePaths = getAbsoluteIncludePaths . getCommandLineOptions mapAbsoluteIncludePaths = mapCommandLineOptions . mapAbsoluteIncludePaths instance LensIncludePaths TCState where- getIncludePaths = getIncludePaths . getCommandLineOptions- mapIncludePaths = mapCommandLineOptions . mapIncludePaths getAbsoluteIncludePaths = getAbsoluteIncludePaths . getCommandLineOptions mapAbsoluteIncludePaths = mapCommandLineOptions . mapAbsoluteIncludePaths -modifyIncludePaths :: MonadTCState m => ([FilePath] -> [FilePath]) -> m ()-modifyIncludePaths = modifyTC . mapIncludePaths--putIncludePaths :: MonadTCState m => [FilePath] -> m ()-putIncludePaths = modifyTC . setIncludePaths- modifyAbsoluteIncludePaths :: MonadTCState m => ([AbsolutePath] -> [AbsolutePath]) -> m () modifyAbsoluteIncludePaths = modifyTC . mapAbsoluteIncludePaths @@ -159,7 +141,7 @@ putAbsoluteIncludePaths = modifyTC . setAbsoluteIncludePaths ------------------------------------------------------------------------------ ** Include directories+-- ** Verbosity --------------------------------------------------------------------------- type PersistentVerbosity = Verbosity
+ src/full/Agda/Interaction/Options/ProfileOptions.hs view
@@ -0,0 +1,115 @@++module Agda.Interaction.Options.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)++import qualified Agda.Utils.List1 as List1+import Agda.Utils.Null (Null, empty)++-- | 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+ | Instances -- ^ Collect statistics about instance search+ | Sections -- ^ Collect statistics about section applications+ 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, Null)++-- | The empty set of profiling options.+noProfileOptions :: ProfileOptions+noProfileOptions = 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+ List1.ifNull (filter (incompatible o) $ Set.toList opts)+ {-then-}+ (return $ ProfileOpts $ Set.insert o opts)+ {-else-} $ \ conflicts ->+ Left $ concat ["Cannot use profiling option '", s, "' with '", optName $ List1.head $ conflicts, "'"]++-- | 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/Interaction/Options/Types.hs view
@@ -15,7 +15,8 @@ import Data.Set ( Set ) import GHC.Generics ( Generic ) -import Agda.Syntax.Common ( Cubical )+import Agda.Syntax.Common+ (Cubical, AllowedErasedMatchesWithDefaults) import Agda.Syntax.Concrete.Glyph ( UnicodeOrAscii ) import Agda.Interaction.Library ( ExeName, LibName ) import Agda.Interaction.Options.Help ( Help )@@ -26,7 +27,7 @@ import Agda.Utils.Lens ( Lens', (^.), over ) import Agda.Utils.List1 ( String1 ) import qualified Agda.Utils.Maybe.Strict as Strict-import Agda.Utils.ProfileOptions ( ProfileOptions )+import Agda.Interaction.Options.ProfileOptions ( ProfileOptions ) import Agda.Utils.Trie ( Trie ) import Agda.Utils.WithDefault ( WithDefault, WithDefault' ) @@ -58,6 +59,8 @@ -- Setup and printing , optPrintAgdaDataDir :: Bool , optPrintAgdaAppDir :: Bool+ , optPrintOptions :: Bool+ -- ^ Print all options as a simple list (for implementing bash completion). , optPrintVersion :: Maybe PrintAgdaVersion , optPrintHelp :: Maybe Help , optBuildLibrary :: Bool@@ -84,6 +87,7 @@ , optGenerateVimFile :: Bool , optIgnoreInterfaces :: Bool , optIgnoreAllInterfaces :: Bool+ , optWriteInterfaces :: Bool , optPragmaOptions :: PragmaOptions , optOnlyScopeChecking :: Bool -- ^ Should the top-level module only be scope-checked, and not type-checked?@@ -91,6 +95,10 @@ -- ^ Should code points that are not supported by the locale be transliterated? , optDiagnosticsColour :: DiagnosticsColours -- ^ Configure colour output.+ , optMdOnlyAgdaBlocks :: Bool+ -- ^ In literate Markdown/Typst, only treat @```agda@ blocks as code.+ , optParallelChecking :: Parallelism+ -- ^ Should imports be type-checked in parallel? } deriving (Show, Generic) @@ -104,6 +112,7 @@ , _optUseUnicode :: WithDefault' UnicodeOrAscii 'True -- Would like to write UnicodeOk instead of True here , _optVerbose :: !Verbosity , _optProfiling :: ProfileOptions+ , _optIrrelevance :: WithDefault 'True , _optProp :: WithDefault 'False , _optLevelUniverse :: WithDefault 'False , _optTwoLevel :: WithDefault 'False@@ -139,14 +148,14 @@ , _optProjectionLike :: WithDefault 'True -- ^ Perform the projection-likeness analysis on functions? , _optErasure :: WithDefault 'False- , _optErasedMatches :: WithDefault 'True- -- ^ Allow matching in erased positions for single-constructor,- -- non-indexed data/record types. (This kind of matching is always- -- allowed for record types with η-equality.)+ , _optErasedMatches :: AllowedErasedMatchesWithDefaults+ -- ^ What kinds of erased matches are allowed? , _optEraseRecordParameters :: WithDefault 'False -- ^ Mark parameters of record modules as erased? , _optRewriting :: WithDefault 'False -- ^ Can rewrite rules be added and used?+ , _optLocalRewriting :: WithDefault 'False+ -- ^ Can local rewrite rules be added and used? , _optCubical :: Maybe Cubical , _optGuarded :: WithDefault 'False , _optFirstOrder :: WithDefault 'False@@ -201,6 +210,14 @@ -- ^ Can we split on a @(\@flat x : A)@ argument? , _optPolarity :: WithDefault 'False -- ^ Can we use modal polarities (@++, @+, etc.)?+ , _optOccurrence :: WithDefault 'True+ -- ^ Perform automated occurrence analysis for functions?+ , _optFunext :: WithDefault 'False+ -- ^ Can @Agda.Builtin.Erased.Funext@ be used?+ , _optPropext :: WithDefault 'False+ -- ^ Can @Agda.Builtin.Erased.Propext@ be used?+ , _optQuotients :: WithDefault 'False+ -- ^ Can @Agda.Builtin.Erased.Quotient@ be used? , _optImportSorts :: WithDefault 'True -- ^ Should every top-level module start with an implicit statement -- @open import Agda.Primitive using (Set; Prop)@?@@ -224,6 +241,7 @@ -- ^ Allow recursion on forced constructor arguments. , _optExperimentalLazyInstances :: WithDefault 'False -- ^ Defer instance search based on discrimination tree results+ , _optQuoteMetas :: WithDefault 'False } deriving (Show, Eq, Generic) @@ -241,6 +259,11 @@ | AutoColour deriving (Show, Generic) +data Parallelism+ = Sequential+ | Parallel (Maybe Int)+ deriving (Show, Generic)+ -- | If several @--emacs-mode@ commands are given, -- they are executed in the order as given in this datatype. data EmacsModeCommand@@ -300,6 +323,7 @@ instance NFData PragmaOptions instance NFData ConfluenceCheck+instance NFData Parallelism instance NFData DiagnosticsColours instance NFData EmacsModeCommand instance NFData InfectiveCoinfective
src/full/Agda/Interaction/Options/Warnings.hs view
@@ -10,6 +10,7 @@ , usualWarnings , noWarnings , unsolvedWarnings+ , unusedImportsWarnings , incompleteMatchWarnings , errorWarnings , exactSplitWarnings@@ -19,13 +20,12 @@ , warningModeUpdate , warningSets , WarningName (..)- , warningName2String+ , warningNameToString , string2WarningName , usageWarning ) where -import Control.Arrow ( (&&&) ) import Control.DeepSeq import Control.Monad ( guard, when ) import Control.Monad.Except ( throwError )@@ -45,6 +45,8 @@ import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.Maybe+import Agda.Utils.Singleton ( singleton )+import Agda.Utils.Tuple ( (&&&) ) import Agda.Utils.Impossible @@ -53,6 +55,7 @@ -- and a flag stating whether warnings should be turned into fatal errors. data WarningMode = WarningMode { _warningSet :: Set WarningName+ -- ^ Invariant: When 'UnusedImportsAll_' is in the warning set, so must be 'UnusedImports_'. , _warn2Error :: Bool } deriving (Eq, Show, Generic) @@ -85,6 +88,8 @@ -- ^ Unknown warning. | NoNoError Text -- ^ Warning that cannot be disabled.+ | NoUnusedImportsAll+ -- ^ @-WnoUnusedImports=all@ is not supported, use @-WnoUnusedImports@ instead. deriving (Show, Generic) instance NFData WarningModeError@@ -97,6 +102,8 @@ , w , " is a non-fatal error and thus cannot be ignored." ]+ NoUnusedImportsAll ->+ "-WnoUnusedImports=all is not supported, use -WnoUnusedImports instead." -- | From user-given directives we compute WarningMode updates type WarningModeUpdate = WarningMode -> WarningMode@@ -114,12 +121,22 @@ _ -> case stripPrefix "no" str of Nothing -> do wname <- stringToWarningName str- pure (over warningSet $ Set.insert wname)+ let+ wnames = case wname of+ -- Invariant: when UnusedImportsAll_ is in the warning set,+ -- so must be UnusedImports_+ UnusedImportsAll_ -> unusedImportsWarnings+ w -> singleton w+ pure $ over warningSet $ (`Set.union` wnames) Just str' -> do wname <- stringToWarningName str' when (wname `elem` errorWarnings) $ throwError $ NoNoError $ Text.pack str'- pure (over warningSet $ Set.delete wname)+ wnames <- case wname of+ UnusedImports_ -> pure unusedImportsWarnings+ UnusedImportsAll_ -> throwError NoUnusedImportsAll+ w -> pure $ singleton w+ pure $ over warningSet $ (Set.\\ wnames) where stringToWarningName :: String -> Either WarningModeError WarningName stringToWarningName str = maybeToEither (Unknown $ Text.pack str) $ string2WarningName str@@ -157,6 +174,7 @@ , ConstructorDoesNotFitInData_ , OverlappingTokensWarning_ , PragmaCompiled_+ , RecursiveRecordNeedsInductivity_ , SafeFlagPostulate_ , SafeFlagPragma_ , SafeFlagNonTerminating_@@ -165,7 +183,6 @@ , SafeFlagNoPositivityCheck_ , SafeFlagPolarity_ , SafeFlagNoUniverseCheck_- , SafeFlagEta_ , SafeFlagInjective_ , SafeFlagNoCoverageCheck_ , TerminationIssue_@@ -182,13 +199,21 @@ , RewriteMaybeNonConfluent_ , RewriteAmbiguousRules_ , RewriteMissingRule_+ , LocalRewriteOutsideTelescope_+ , InferredLocalRewrite_ , TopLevelPolarity_ + -- Recoverable parse errors+ , MismatchedBrackets_+ -- Recoverable scope-checking errors , HiddenNotInArgumentPosition_ , InstanceNotInArgumentPosition_ , MacroInLetBindings_ , AbstractInLetBindings_+ , IllegalDeclarationInDataDefinition_+ , UnknownNamesInFixityDecl_ -- This may lead to subsequent scope or operator parse errors.+ , UnknownNamesInPolarityPragmas_ -- This may lead to subsequent type-checking errors. ] allWarnings :: Set WarningName@@ -199,6 +224,8 @@ allWarnings Set.\\ exactSplitWarnings Set.\\ Set.fromList [ UnknownFixityInMixfixDecl_ , ShadowingInTelescope_+ , UnusedImports_+ , UnusedImportsAll_ ] -- | Warnings enabled by @--exact-split@.@@ -207,8 +234,13 @@ exactSplitWarnings = Set.fromList [ CoverageNoExactSplit_ , InlineNoExactSplit_+ , ShouldBeEtaRecordPattern_ ] +-- | Both of these warnings are disabled by @-WnoUnusedImports@.+unusedImportsWarnings :: Set WarningName+unusedImportsWarnings = Set.fromList [ UnusedImports_, UnusedImportsAll_ ]+ -- | The @WarningName@ data enumeration is meant to have a one-to-one correspondance -- to existing warnings in the codebase. @@ -217,6 +249,7 @@ = OptionRenamed_ | WarningProblem_ -- ^ Some warning could not be set or unset.+ | LocalRewritingConfluenceCheck_ -- Parser Warnings | OverlappingTokensWarning_ | MisplacedAttributes_@@ -224,9 +257,13 @@ | UnknownAttribute_ | UnsupportedAttribute_ | MultipleAttributes_+ | MismatchedBrackets_ -- Library Warnings | LibUnknownField_+ | LibraryVersionConflict_ -- Nicifer Warnings+ | DefinitionBeforeDeclaration_+ | DivergentModalityInClause_ | EmptyAbstract_ | EmptyConstructor_ | EmptyField_@@ -240,14 +277,18 @@ | EmptyRewritePragma_ | EmptyWhere_ | EmptyPolarityPragma_+ | FixityDeclarationForNonOperator_ | HiddenGeneralize_ | InvalidCatchallPragma_ | InvalidConstructorBlock_ | InvalidCoverageCheckPragma_+ | InvalidDataOrRecDefParameter_+ | InvalidEtaEqualityPragma_ | InvalidNoPositivityCheckPragma_ | InvalidNoUniverseCheckPragma_ | DuplicateRecordDirective_ | InvalidTerminationCheckPragma_+ | InvalidTacticAttribute_ | MissingDataDeclaration_ | MissingDefinitions_ | NotAllowedInMutual_@@ -261,6 +302,7 @@ | UnknownNamesInFixityDecl_ | UnknownNamesInPolarityPragmas_ | UselessAbstract_+ | UselessImport_ | UselessInstance_ | UselessMacro_ | UselessPrivate_@@ -278,11 +320,15 @@ | FixingCohesion_ | FixingPolarity_ | FixingRelevance_+ | MisplacedRewrite_ -- TODO: linearity -- -- | FixingQuantity_ | FixityInRenamingModule_ | InvalidCharacterLiteral_+ | UnusedImports_+ | UnusedImportsAll_ | UselessPragma_+ | IllegalDeclarationInDataDefinition_ | IllformedAsClause_ | InstanceArgWithExplicitArg_ | InstanceWithExplicitArg_@@ -294,6 +340,7 @@ | NotStrictlyPositive_ | ConstructorDoesNotFitInData_ | CoinductiveEtaRecord_+ | UnguardedEtaRecordW_ | UnsupportedIndexedMatch_ | OldBuiltin_ | BuiltinDeclaresIdentifier_@@ -307,11 +354,13 @@ | PragmaExpectsDefinedSymbol_ | PragmaExpectsUnambiguousConstructorOrFunction_ | PragmaExpectsUnambiguousProjectionOrFunction_+ | UnknownJSPrimitive_ | NoMain_ | NotARewriteRule_ | RewriteLHSNotDefinitionOrConstructor_ | RewriteVariablesNotBoundByLHS_ | RewriteVariablesBoundMoreThanOnce_+ | RewriteVariablesBoundInSingleton_ | RewriteLHSReduces_ | RewriteHeadSymbolIsProjectionLikeFunction_ | RewriteHeadSymbolIsTypeConstructor_@@ -330,7 +379,8 @@ | RewriteAmbiguousRules_ | RewriteMissingRule_ | DuplicateRewriteRule_- | SafeFlagEta_+ | LocalRewriteOutsideTelescope_+ | InferredLocalRewrite_ | SafeFlagInjective_ | SafeFlagNoCoverageCheck_ | SafeFlagNonTerminating_@@ -341,6 +391,7 @@ | SafeFlagPragma_ | SafeFlagTerminating_ | SafeFlagWithoutKFlagPrimEraseEquality_+ | ShouldBeEtaRecordPattern_ | TerminationIssue_ | TooManyArgumentsToSort_ | UnreachableClauses_@@ -356,6 +407,7 @@ | InvalidDisplayForm_ | UnusedVariablesInDisplayForm_ | RewritesNothing_+ | RecursiveRecordNeedsInductivity_ | WithClauseProjectionFixityMismatch_ | WithoutKFlagPrimEraseEquality_ | ConflictingPragmaOptions_@@ -393,10 +445,13 @@ string2WarningName :: String -> Maybe WarningName string2WarningName = (`HMap.lookup` warnings) where- warnings = HMap.fromList $ map (\x -> (warningName2String x, x)) [minBound..maxBound]+ warnings = HMap.fromList $ map (\x -> (warningNameToString x, x)) [minBound..maxBound] -warningName2String :: WarningName -> String-warningName2String = initWithDefault __IMPOSSIBLE__ . show+warningNameToString :: WarningName -> String+warningNameToString = \case+ UnguardedEtaRecordW_ -> "UnguardedEtaRecord"+ UnusedImportsAll_ -> "UnusedImports=all"+ w -> initWithDefault __IMPOSSIBLE__ $ show w -- | @warningUsage@ generated using @warningNameDescription@ @@ -430,7 +485,7 @@ warningTable printD ws = untable $ forMaybe ws $ \ w -> let wnd = warningNameDescription w in- ( warningName2String w+ ( warningNameToString w , applyWhen printD ((if w `Set.member` usualWarnings then "d" else " ") ++) " " ++ wnd@@ -454,6 +509,7 @@ -- Option Warnings OptionRenamed_ -> "Renamed options." WarningProblem_ -> "Problems with switching warnings."+ LocalRewritingConfluenceCheck_ -> "Confluence checking local rewrite rules in not yet implemented." -- Parser Warnings OverlappingTokensWarning_ -> "Multi-line comments spanning one or more literate text blocks." MisplacedAttributes_ -> "Attributes where they are not supported."@@ -461,9 +517,12 @@ UnknownAttribute_ -> "Unknown attributes." UnsupportedAttribute_ -> "Unsupported attributes." MultipleAttributes_ -> "Multiple attributes."+ MismatchedBrackets_ -> "Mismatched brackets." -- Library Warnings LibUnknownField_ -> "Unknown fields in library files."+ LibraryVersionConflict_ -> "Depending on different versions of the same library." -- Nicifer Warnings+ DivergentModalityInClause_ -> "Divergent modalities in function clauses." EmptyAbstract_ -> "Empty `abstract' blocks." EmptyConstructor_ -> "Empty `constructor' blocks." EmptyField_ -> "Empty `field` blocks."@@ -477,13 +536,17 @@ EmptyRewritePragma_ -> "Empty `REWRITE' pragmas." EmptyWhere_ -> "Empty `where' blocks." EmptyPolarityPragma_ -> "`POLARITY' pragmas giving no polarities."+ FixityDeclarationForNonOperator_ -> "Fixity declarations for non-operators." HiddenGeneralize_ -> "Hidden identifiers in variable blocks." InvalidCatchallPragma_ -> "`CATCHALL' pragmas before a non-function clause." InvalidConstructorBlock_ -> "`constructor' blocks outside of `interleaved mutual' blocks." InvalidCoverageCheckPragma_ -> "Coverage checking pragmas before non-function or `mutual' blocks."+ InvalidDataOrRecDefParameter_ -> "Invalid decorations of parameters of a `data' or `record' definition (that is separate of the `data' or `record' declaration)."+ InvalidEtaEqualityPragma_ -> "Eta equality pragmas before something other than a `record' type declaration." InvalidNoPositivityCheckPragma_ -> "Positivity checking pragmas before non-`data', `record' or `mutual' blocks." InvalidNoUniverseCheckPragma_ -> "Universe checking pragmas before non-`data' or `record' declaration." DuplicateRecordDirective_ -> "Conflicting directives in a record declaration."+ InvalidTacticAttribute_ -> "Misplaced @(tactic ...) attributes." InvalidTerminationCheckPragma_ -> "Termination checking pragmas before non-function or `mutual' blocks." MissingDataDeclaration_ -> "Constructor definitions not associated to a data declaration." MissingDefinitions_ -> "Declarations not associated to a definition."@@ -499,6 +562,7 @@ UnknownNamesInPolarityPragmas_ -> "Names not declared in the same scope as their polarity pragmas." UselessAbstract_ -> "`abstract' blocks where they have no effect." UselessHiding_ -> "Names in `hiding' directive that are anyway not imported."+ UselessImport_ -> "`import' statements that do not bring anything into scope." UselessInline_ -> "`INLINE' pragmas where they have no effect." UselessInstance_ -> "`instance' blocks where they have no effect." UselessMacro_ -> "`macro' blocks where they have no effect."@@ -516,13 +580,16 @@ CoverageNoExactSplit_ -> "Failed exact split checks." InlineNoExactSplit_ -> "Failed exact split checks after inlining record constructors." DeprecationWarning_ -> "Deprecated features."+ DefinitionBeforeDeclaration_ -> "Definitions that occur before their declarations." -- TODO: linearity -- FixingQuantity_ -> "Correcting invalid user-written quantity." FixingRelevance_ -> "Correcting invalid user-written relevance attribute." FixingCohesion_ -> "Correcting invalid user-written cohesion attribute." FixingPolarity_ -> "Correcting invalid user-written polarity attribute."+ MisplacedRewrite_ -> "Ignoring invalid user-written local rewrite attribute." InvalidCharacterLiteral_ -> "Illegal character literals." UselessPragma_ -> "Pragmas that get ignored."+ IllegalDeclarationInDataDefinition_ -> "Declarations not allowed in `data' definitions." IllformedAsClause_ -> "Illformed `as'-clauses in `import' statements." InstanceNoOutputTypeName_ -> "Instance arguments whose type does not end in a named or variable type; those are never considered by instance search." InstanceArgWithExplicitArg_ -> "Instance arguments with explicit arguments; those are never considered by instance search."@@ -535,6 +602,7 @@ NotStrictlyPositive_ -> "Failed strict positivity checks." ConstructorDoesNotFitInData_ -> "Failed constructor size checks." CoinductiveEtaRecord_ -> "Record type declared as both coinductive and having eta-equality."+ UnguardedEtaRecordW_ -> "Record type declared with eta-equality that has an unguarded recursive occurrence." UnsupportedIndexedMatch_ -> "Failures to compute full equivalence when splitting on indexed family." OldBuiltin_ -> "Deprecated `BUILTIN' pragmas." BuiltinDeclaresIdentifier_ -> "`BUILTIN' pragmas that declare a new identifier but have been given an existing one."@@ -545,14 +613,16 @@ PragmaCompileUnparsable_ -> "Unparsable `COMPILE GHC' pragmas." PragmaCompileWrong_ -> "Ill-formed `COMPILE GHC' pragmas." PragmaCompileWrongName_ -> "`COMPILE' pragmas referring to identifiers that are neither definitions nor constructors.'"- PragmaExpectsDefinedSymbol_ -> "Pragmas referrings to identifiers that are not defined symbols."+ PragmaExpectsDefinedSymbol_ -> "Pragmas referring to identifiers that are not defined symbols." PragmaExpectsUnambiguousConstructorOrFunction_ -> "Pragmas referring to identifiers that are not unambiguous constructors or functions.'" PragmaExpectsUnambiguousProjectionOrFunction_ -> "Pragmas referring to identifiers that are not unambiguous projections or functions.'"+ UnknownJSPrimitive_ -> "Primitive compiled to `Undefined' by the JS backend because it is not in the list of known primitives." NoMain_ -> "Compilation of modules that do not define `main'." NotARewriteRule_ -> "`REWRITE pragmas referring to identifiers that are neither definitions nor constructors.'" RewriteLHSNotDefinitionOrConstructor_ -> "Rewrite rule head symbol is not a defined symbol or constructor." RewriteVariablesNotBoundByLHS_ -> "Rewrite rule does not bind all of its variables." RewriteVariablesBoundMoreThanOnce_ -> "Constructor-headed rewrite rule has non-linear parameters."+ RewriteVariablesBoundInSingleton_ -> "Rewrite rule binds some variables in possibly definitionally singular contexts." RewriteLHSReduces_ -> "Rewrite rule LHS is not in weak-head normal form." RewriteHeadSymbolIsProjectionLikeFunction_ -> "Rewrite rule head symbol is a projection-like function." RewriteHeadSymbolIsTypeConstructor_ -> "Rewrite rule head symbol is a type constructor."@@ -571,7 +641,8 @@ RewriteAmbiguousRules_ -> "Failed global confluence checks because of overlapping rules." RewriteMissingRule_ -> "Failed global confluence checks because of missing rule." DuplicateRewriteRule_ -> "Duplicate rewrite rules."- SafeFlagEta_ -> "`ETA' pragmas with the safe flag."+ LocalRewriteOutsideTelescope_ -> "'@rewrite' arguments are (currently) only allowed in module telescopes."+ InferredLocalRewrite_ -> "Tried to solve a meta with an '@rewrite' function." SafeFlagInjective_ -> "`INJECTIVE' pragmas with the safe flag." SafeFlagNoCoverageCheck_ -> "`NON_COVERING` pragmas with the safe flag." SafeFlagNonTerminating_ -> "`NON_TERMINATING' pragmas with the safe flag."@@ -592,13 +663,17 @@ UserWarning_ -> "User-defined warnings via one of the 'WARNING_ON_*' pragmas." InvalidDisplayForm_ -> "Invalid display forms." UnusedVariablesInDisplayForm_ -> "Bound but unused variables in display forms."+ ShouldBeEtaRecordPattern_ -> "Irrefutable record pattern without eta." TooManyArgumentsToSort_ -> "Extra arguments given to a sort."+ RecursiveRecordNeedsInductivity_ -> "Recursive records declared neither `inductive' nor `coinductive'." RewritesNothing_ -> "`rewrite' clauses that do not fire." WithClauseProjectionFixityMismatch_ -> "With clauses using projections in different fixities than their parent clauses." WithoutKFlagPrimEraseEquality_ -> "Uses of `primEraseEquality' with the without-K flags." WrongInstanceDeclaration_ -> "Instances that do not adhere to the required format." TooManyPolarities_ -> "Too many polarities given in POLARITY pragma." TopLevelPolarity_ -> "Declaring definitions with an explicit polarity annotation."+ UnusedImports_ -> "Identifiers brought into scope but never referenced."+ UnusedImportsAll_ -> "Identifiers brought into scope but never referenced (strict version)." -- 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 does not."
src/full/Agda/Interaction/Response/Base.hs view
@@ -32,6 +32,7 @@ import Agda.Interaction.Highlighting.Precise import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Common (InteractionId(..), Arg)+import Agda.Syntax.Common.Pretty (DocTree) import Agda.Syntax.Concrete (Expr) import Agda.Syntax.Concrete.Name (Name, QName, NameInScope) import Agda.Syntax.Scope.Base (WhyInScopeData)@@ -40,6 +41,7 @@ (HighlightingMethod, ModuleToSource, NamedMeta, IPFace') import Agda.Utils.Impossible import Agda.Utils.Time+import qualified Agda.Syntax.Concrete.Name as C -- | Responses for any interactive interface --@@ -52,6 +54,8 @@ RemoveTokenBasedHighlighting HighlightingMethod ModuleToSource+ (Maybe FilePath)+ -- ^ Target file, or 'Nothing' for the current buffer. | Resp_Status Status | Resp_JumpToError FilePath Word32 | Resp_InteractionPoints [InteractionId]@@ -62,8 +66,9 @@ -- ^ Solution for one or more meta-variables. | Resp_Mimer InteractionId (Maybe String) | Resp_DisplayInfo (DisplayInfo_boot tcErr tcWarning warningsAndNonFatalErrors)- | Resp_RunningInfo Int String+ | Resp_RunningInfo Int DocTree -- ^ The integer is the message's debug level.+ -- The 'DocTree' usually does not contain a final newline. | Resp_ClearRunningInfo | Resp_ClearHighlighting TokenBased -- ^ Clear highlighting of the given kind.@@ -113,7 +118,7 @@ | Info_GoalSpecific InteractionId (GoalDisplayInfo_boot tcErr) data GoalDisplayInfo_boot tcErr- = Goal_HelperFunction (OutputConstraint' A.Expr A.Expr)+ = Goal_HelperFunction (OutputConstraint' A.Expr C.Name) | Goal_NormalForm ComputeMode A.Expr | Goal_GoalType Rewrite GoalTypeAux [ResponseContextEntry] [IPFace' Expr] [OutputForm_boot tcErr Expr Expr] | Goal_CurrentGoal Rewrite
src/full/Agda/Interaction/SearchAbout.hs view
@@ -4,27 +4,27 @@ import Control.Monad -import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.List (isInfixOf) import Data.Either (partitionEithers) import Data.Foldable (toList)+import Data.List (isInfixOf)+import Data.Map qualified as Map+import Data.Set qualified as Set +import Agda.Interaction.Base (Rewrite)+import Agda.Interaction.BasicOps (normalForm, parseName)+import Agda.Syntax.Abstract.Name (AbstractName(..), KindOfName (PatternSynName))+import Agda.Syntax.Common.Pretty (prettyShow)+import Agda.Syntax.Concrete qualified as C+import Agda.Syntax.Internal qualified as I+import Agda.Syntax.Internal.Names (namesIn) import Agda.Syntax.Position (Range) import Agda.Syntax.Scope.Base import Agda.Syntax.Scope.Monad-import Agda.TypeChecking.Monad.Signature import Agda.TypeChecking.Monad.Env-import Agda.Syntax.Internal.Names (namesIn)-import Agda.Interaction.Base (Rewrite)-import Agda.Interaction.BasicOps (normalForm, parseName)--import qualified Agda.Syntax.Concrete as C-import qualified Agda.Syntax.Internal as I+import Agda.TypeChecking.Monad.Signature -import Agda.Utils.List ( initLast1 )-import qualified Agda.Utils.List1 as List1-import Agda.Syntax.Common.Pretty ( prettyShow )+import Agda.Utils.List (initLast1)+import Agda.Utils.List1 qualified as List1 findMentions :: Rewrite -> Range -> String -> ScopeM [(C.Name, I.Type)] findMentions norm rg nm = do
src/full/Agda/Main.hs view
@@ -10,6 +10,7 @@ import Control.Monad ( void ) import Control.Monad.Except ( MonadError(..), ExceptT(..), runExceptT ) import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Concurrent (setNumCapabilities) import qualified Data.List as List import Data.Function ( (&) )@@ -18,21 +19,25 @@ import qualified Data.Set as Set import qualified Data.Text as T +import GHC.Conc (getNumProcessors)+ import System.Environment ( getArgs, getProgName ) import System.Exit ( exitSuccess, ExitCode ) import System.FilePath ( takeFileName ) import Agda.Utils.GetOpt import qualified System.IO as IO -import Agda.Interaction.BuildLibrary (buildLibrary)+import Agda.Interaction.BuildLibrary (buildLibrary, printAccumulatedWarnings) import Agda.Interaction.CommandLine import Agda.Interaction.ExitCode as ExitCode (AgdaError(..), exitSuccess, exitAgdaWith)+import Agda.Interaction.Highlighting.LaTeX.Backend (latexBackendName) import Agda.Interaction.Options-import Agda.Interaction.Options.Help (Help (..))+import Agda.Interaction.Options.BashCompletion (bashComplete, printedOptions)+import Agda.Interaction.Options.Help (Help (..), helpTopicUsage) import Agda.Interaction.EmacsTop (mimicGHCi) import Agda.Interaction.JSONTop (jsonREPL) import Agda.Interaction.FindFile ( SourceFile(SourceFile) )-import qualified Agda.Interaction.Imports as Imp+import Agda.Interaction.Imports qualified as Imp import Agda.TypeChecking.Monad import Agda.TypeChecking.Errors@@ -46,6 +51,8 @@ import Agda.Setup ( getAgdaAppDir, getDataDir, setup ) import Agda.Setup.EmacsMode++import Agda.Version (version) import Agda.VersionCommit ( versionWithCommitInfo ) import qualified Agda.Utils.Benchmark as UtilsBench@@ -58,6 +65,7 @@ import Agda.Utils.Null import Agda.Utils.Impossible+import Agda.Utils.Function (applyWhen) -- | The main function runAgda :: [Backend] -> IO ()@@ -66,19 +74,30 @@ -- | The main function without importing built-in backends runAgda' :: [Backend] -> IO () runAgda' backends = do+ getArgs >>= \case++ -- Special mode of operation for @--bash-complete@.+ "--bash-complete" : args ->+ case bashComplete trunc args of+ Right s -> putStr s+ Left err -> do+ putStrLn err+ exitAgdaWith ExitCode.OptionError+ where+ -- Truncate to max 50 completion suggestions.+ trunc = Just 50++ -- Ordinary entrypoint.+ args -> runAgdaArgs backends args++runAgdaArgs :: [Backend] -> [String] -> IO ()+runAgdaArgs backends args = do progName <- getProgName- argv <- getArgs- let (z, warns) = runOptM $ parseBackendOptions backends argv defaultOptions- conf <- runExceptT $ do- (bs, opts) <- ExceptT $ pure z- -- The absolute path of the input file, if provided- inputFile <- liftIO $ mapM absolute $ optInputFile opts- mode <- getInteractor bs inputFile opts- return (bs, opts, mode)+ let (conf, warns) = runOptM $ parseBackendOptions backends args defaultOptions case conf of Left err -> optionError err- Right (bs, opts, mode) -> do+ Right (bs, opts) -> do -- Setup Agda if requested when (optSetup opts) $ Agda.Setup.setup True@@ -88,6 +107,7 @@ whenJust (optPrintHelp opts) $ printUsage bs when (optPrintAgdaAppDir opts) $ printAgdaAppDir when (optPrintAgdaDataDir opts) $ printAgdaDataDir+ when (optPrintOptions opts) $ printOptions -- Setup emacs mode when (EmacsModeSetup `Set.member` optEmacsMode opts) do@@ -104,8 +124,12 @@ unless (optSetup opts) $ Agda.Setup.setup False printEmacsModeFile - case mode of- Nothing -> do+ -- The absolute path of the input file, if provided+ inputFile <- liftIO $ mapM absolute $ optInputFile opts++ (runExceptT $ getInteractor bs inputFile opts) >>= \case+ Left err -> optionError err+ Right Nothing -> do let something = or [ opts & optSetup@@ -113,12 +137,13 @@ , opts & optPrintHelp & isJust , opts & optPrintAgdaAppDir , opts & optPrintAgdaDataDir+ , opts & optPrintOptions , opts & optEmacsMode & not . null ] -- if no task was given to Agda unless something $ optionError "No task given." - Just interactor -> do+ Right (Just interactor) -> do unless (optSetup opts) $ Agda.Setup.setup False runTCMPrettyErrors do@@ -139,7 +164,7 @@ IO.hSetEncoding IO.stdout enc IO.hSetEncoding IO.stderr enc - setTCLens stBackends bs+ setSession lensBackends bs runAgdaWithOptions interactor progName opts @@ -221,6 +246,7 @@ return $ Just $ interactionInteractor i -- --build-library FrontEndBuildLibrary -> do+ noBackends fe -- Issue #8024: Backends are not supported yet. unless (optUseLibs opts) $ throwError "--build-library cannot be combined with --no-libraries" noInputFile fe@@ -288,6 +314,23 @@ opts <- addTrustedExecutables opts setCommandLineOptions opts + -- The GHC runtime has some funky behaviour if we ask it to set+ -- the number of capabilities on startup.+ --+ -- a) The minimum heap size seems to shoot up to approx. the GC+ -- allocation area times the number of processors, which means the+ -- performance regression tests with very low memory usage limit+ -- simply fail to start;+ --+ -- b) Even if we set the number of capabilities back down to 1,+ -- the parallel GC seems to be used unconditionally if we have+ -- more capabilities on startup, which adds a noticeable amount of+ -- overhead.+ liftIO case optParallelChecking opts of+ Parallel Nothing -> setNumCapabilities =<< getNumProcessors+ Parallel (Just i) -> setNumCapabilities i+ Sequential -> setNumCapabilities 1+ checkFile :: AbsolutePath -> TCM CheckResult checkFile inputFile = do -- Andreas, 2013-10-30 The following 'resetState' kills the@@ -308,27 +351,36 @@ let i = crInterface result reportSDoc "main" 50 $ pretty i - -- Print accumulated warnings- unlessNullM (tcWarnings . classifyWarnings . Set.toAscList <$> getAllWarnings AllWarnings) $ \ ws -> do- let banner = text $ "\n" ++ delimiter "All done; warnings encountered"- alwaysReportSDoc "warning" 1 $- vsep $ (banner :) $ map prettyTCM $ Set.toAscList ws-+ printAccumulatedWarnings return result - -- | Print usage information. printUsage :: [Backend] -> Help -> IO () printUsage backends hp = do progName <- getProgName- putStr $ usage standardOptions_ progName hp- when (hp == GeneralHelp) $ mapM_ (putStr . backendUsage) backends--backendUsage :: Backend -> String-backendUsage (Backend b) =- usageInfo ("\n" ++ T.unpack (backendName b) ++ " backend options") $- map void (commandLineFlags b)+ putStr $ unlines+ [ "Agda version " ++ version+ , ""+ , "Usage: " ++ progName ++ " [OPTIONS...] [FILE]"+ ]+ case hp of+ GeneralHelp -> do+ forM_ optionGroups \ (header, opts) -> do+ usage header opts+ forM_ backends \ (Backend b) -> do+ let+ opts = applyWhen (backendName b == latexBackendName)+ (++ map void (snd latexPragmaOptions))+ (map void (commandLineFlags b))+ -- NB: @map void@ to make the 'OptDescr' types match.+ usage (T.unpack (backendName b) ++ " backend options") opts+ HelpFor topic -> putStr $ helpTopicUsage topic+ where+ fmt h = "\n" ++ h ++ ":\n"+ width = 40+ usage :: String -> [OptDescr a] -> IO ()+ usage header opts = putStr $ usageInfo width (fmt header) opts -- | Print version information. printVersion :: [Backend] -> PrintAgdaVersion -> IO ()@@ -381,6 +433,9 @@ printAgdaAppDir :: IO () printAgdaAppDir = putStrLn =<< getAgdaAppDir +printOptions :: IO ()+printOptions = mapM_ putStrLn printedOptions+ -- | What to do for bad options. optionError :: String -> IO () optionError err = do@@ -410,7 +465,7 @@ `catchError` \err -> do s2s <- prettyTCWarnings' =<< getAllWarningsOfTCErr err s1 <- prettyError err- ANSI.putDoc $ P.vsep $ s2s ++ [ s1 ]+ ANSI.putDocLn $ P.vsep $ s2s ++ [ s1 ] liftIO $ do helpForLocaleError err return (Just TCMError)
src/full/Agda/Mimer/Mimer.hs view
@@ -27,1751 +27,664 @@ import Prelude hiding (null) -import Control.DeepSeq (force, NFData(..))-import Control.Monad-import Control.Monad.Except (catchError)-import Control.Monad.Error.Class (MonadError)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.Reader (ReaderT(..), runReaderT, asks, ask, lift)-import Data.Function (on)-import Data.Functor ((<&>))-import Data.List (sortOn, intersect, transpose, (\\))-import qualified Data.List.NonEmpty as NonEmptyList (head)-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Maybe (maybeToList, fromMaybe, maybe, isNothing)-import Data.PQueue.Min (MinQueue)-import qualified Data.PQueue.Min as Q-import GHC.Generics (Generic)-import qualified Text.PrettyPrint.Boxes as Box-import qualified Data.Text as Text--import qualified Agda.Benchmarking as Bench-import Agda.Interaction.MakeCase (makeCase, getClauseZipperForIP, recheckAbstractClause)-import Agda.Syntax.Abstract (Expr(AbsurdLam))-import qualified Agda.Syntax.Abstract as A-import qualified Agda.Syntax.Abstract.Views as A-import Agda.Syntax.Abstract.Name (QName(..), Name(..))-import Agda.Syntax.Common (InteractionId(..), MetaId(..), ArgInfo(..), defaultArgInfo, Origin(..), ConOrigin(..), Hiding(..), setOrigin, NameId, Nat, namedThing, Arg(..), setHiding, getHiding, ProjOrigin(..), rangedThing, woThing, nameOf, visible)-import Agda.Syntax.Common.Pretty (Pretty)-import qualified Agda.Syntax.Common.Pretty as P-import qualified Agda.Syntax.Concrete.Name as C-import Agda.Syntax.Info (pattern UnificationMeta, exprNoRange)-import Agda.Syntax.Internal-import Agda.Syntax.Internal.MetaVars (AllMetas(..))-import Agda.Syntax.Internal.Pattern (clausePerm)-import Agda.Syntax.Position (Range, rangeFile, rangeFilePath, noRange)-import qualified Agda.Syntax.Scope.Base as Scope-import Agda.Syntax.Translation.InternalToAbstract (reify, NamedClause(..), blankNotInScope)-import Agda.Syntax.Translation.AbstractToConcrete (abstractToConcrete_)--import Agda.TypeChecking.Primitive (getBuiltinName)-import Agda.TypeChecking.Constraints (noConstraints)-import Agda.TypeChecking.Datatypes (isDataOrRecord)-import Agda.TypeChecking.Conversion (equalType)-import Agda.TypeChecking.Empty (isEmptyType)-import Agda.TypeChecking.Free (flexRigOccurrenceIn, freeVars)-import Agda.TypeChecking.Level (levelType)-import Agda.TypeChecking.MetaVars (newValueMeta)-import Agda.TypeChecking.Monad -- (MonadTCM, lookupInteractionId, getConstInfo, liftTCM, clScope, getMetaInfo, lookupMeta, MetaVariable(..), metaType, typeOfConst, getMetaType, MetaInfo(..), getMetaTypeInContext)-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Records (isRecord, isRecursiveRecord)-import Agda.TypeChecking.Reduce (reduce, instantiateFull, instantiate)-import Agda.TypeChecking.Rules.LHS.Problem (AsBinding(..))-import Agda.TypeChecking.Rules.Term (makeAbsurdLambda)-import Agda.TypeChecking.Substitute (apply, applyE, piApply, NoSubst(..), pattern TelV, telView')-import Agda.TypeChecking.Telescope (piApplyM, flattenTel, teleArgs)--import Agda.Utils.Benchmark (billTo)-import Agda.Utils.FileName (filePath)-import Agda.Utils.Functor ((<.>))-import Agda.Utils.Impossible (__IMPOSSIBLE__)-import Agda.Utils.Maybe (catMaybes)-import Agda.Utils.Monad (ifM, and2M)-import qualified Agda.Utils.Maybe.Strict as SMaybe--- import Agda.Utils.Permutation (idP, permute, takeP)-import Agda.Utils.Null-import Agda.Utils.Time (CPUTime(..), getCPUTime, fromMilliseconds)-import Agda.Utils.Tuple (mapFst, mapSnd)-import Agda.Utils.FileName (AbsolutePath(..))--import Agda.Mimer.Options--import System.IO.Unsafe (unsafePerformIO)-import Data.IORef (IORef, writeIORef, readIORef, newIORef, modifyIORef')---- Temporary (used for custom cost verbosity hack)-import qualified Agda.Utils.Maybe.Strict as Strict-import qualified Agda.Utils.Trie as Trie-import Agda.Interaction.Base (Rewrite(..))-import Agda.Interaction.BasicOps (normalForm)-import Agda.Interaction.Options.Base (parseVerboseKey)-import Agda.Utils.List (lastWithDefault)--data MimerResult- = MimerExpr String -- ^ Returns 'String' rather than 'Expr' because the give action expects a string.- | MimerClauses QName [A.Clause]- | MimerList [(Int, String)]- | MimerNoResult- deriving (Generic)--instance NFData MimerResult---- | Entry point.--- Run Mimer on the given interaction point, returning the desired solution(s).--- Also debug prints timing statistics.-mimer :: MonadTCM tcm- => Rewrite -- ^ Degree of normalization of solution terms.- -> InteractionId -- ^ Hole to run on.- -> Range -- ^ Range of hole (for parse errors).- -> String -- ^ Content of hole (to parametrize Mimer).- -> tcm MimerResult-mimer norm ii rng argStr = liftTCM $ do- reportSDoc "mimer.top" 10 do- "Running Mimer on interaction point" <+> pretty ii <+> "with argument string" <+> text (show argStr)-- start <- liftIO $ getCPUTime-- opts <- parseOptions ii rng argStr- reportS "mimer.top" 15 ("Mimer options: " ++ show opts)-- -- Andreas, 2025-04-16, changing the plain getTC/putTC bracket to localTCState.- -- localTCState should be used by default,- -- it keeps the Statistics about metas and constraints.- -- Was there a reason to use plain getTC/putTC or is it "don't care" since- -- mimer is an interactive command and no one looks at the statistics?- sols <- localTCState $ runSearch norm opts ii rng-- -- Turn the solutions into the desired results (first solution or list of solutions).- sol <- case drop (optSkip opts) $ zip [0..] sols of- [] -> do- reportSLn "mimer.top" 10 "No solution found"- return MimerNoResult- sols' | optList opts -> pure $ MimerList [ (i, s) | (i, MimerExpr s) <- sols' ]- (_, sol) : _ -> do- reportSDoc "mimer.top" 10 $ "Solution:" <+> prettyTCM sol- return sol-- -- Print timing statistic.- stop <- liftIO $ getCPUTime- let time = stop - start- reportSDoc "mimer.top" 10 ("Total elapsed time:" <+> pretty time)- verboseS "mimer.stats" 50 $ writeTime ii (if null sols then Nothing else Just time)-- return sol----- Order to try things in:--- 1. Local variables (including let-bound)--- 2. Data constructors--- 3. Where clauses--- 4. Lambda abstract--- Other: Equality, empty type, record projections--- - If we only use constructors if the target type is a data type, we might--- generate η-reducible expressions, e.g. λ xs → _∷_ 0 xs------------------------------------------------------------------------------------ * Data types---------------------------------------------------------------------------------type SM a = ReaderT SearchOptions TCM a--data SearchBranch = SearchBranch- { sbTCState :: TCState- , sbGoals :: [Goal]- , sbCost :: Int- , sbCache :: Map CheckpointId ComponentCache- , sbComponentsUsed :: Map Name Int -- ^ Number of times each component has been used- }- deriving (Generic)-instance NFData SearchBranch---- | NOTE: Equality is only on the fields `sbCost` and `sbGoals`-instance Eq SearchBranch where- sb1 == sb2 = sbCost sb1 == sbCost sb2 && sbGoals sb1 == sbGoals sb2---- TODO: Explain-instance Ord SearchBranch where- compare = compare `on` sbCost---- Map source component to generated components-type ComponentCache = Map Component (Maybe [Component])--data Goal = Goal- { goalMeta :: MetaId- }- deriving (Generic)-instance NFData Goal---- TODO: Is this a reasonable Eq instance?-instance Eq Goal where- g1 == g2 = goalMeta g1 == goalMeta g2---- | Components that are not changed during search. Components that do change--- (local variables and let bindings) are stored in each 'SearchBranch'.-data BaseComponents = BaseComponents- { hintFns :: [Component]- , hintDataTypes :: [Component]- , hintRecordTypes :: [Component]- , hintAxioms :: [Component]- -- ^ Excluding those producing Level- , hintLevel :: [Component]- -- ^ A definition in a where clause- , hintProjections :: [Component]- -- ^ Variables that are candidates for arguments to recursive calls- , hintThisFn :: Maybe Component- , hintLetVars :: [Open Component]- , hintRecVars :: Open [(Term, NoSubst Term Int)] -- ^ Variable terms and which argument they come from- , hintSplitVars :: Open [Term]- }- deriving (Generic)--instance NFData BaseComponents--type CompId = Int-data Component = Component- { compId :: CompId -- ^ Unique id for the component. Used for the cache.- , compName :: Maybe Name -- ^ Used for keeping track of how many times a component has been used- , compPars :: Nat -- ^ How many arguments should be dropped (e.g. constructor parameters)- , compTerm :: Term- , compType :: Type- , compRec :: Bool -- ^ Is this a recursive call- , compMetas :: [MetaId]- , compCost :: Cost- }- deriving (Eq, Generic)--instance NFData Component---- TODO: Is this reasonable?-instance Ord Component where- compare = compare `on` compId--data SearchStepResult- = ResultExpr Expr- | ResultClauses [A.Clause]- | OpenBranch SearchBranch- | NoSolution- deriving (Generic)-instance NFData SearchStepResult---data SearchOptions = SearchOptions- { searchBaseComponents :: BaseComponents- , searchHintMode :: HintMode- , searchTimeout :: MilliSeconds- , searchGenProjectionsLocal :: Bool- , searchGenProjectionsLet :: Bool- , searchGenProjectionsExternal :: Bool- , searchGenProjectionsRec :: Bool- , searchSpeculateProjections :: Bool- , searchTopMeta :: MetaId- , searchTopEnv :: TCEnv- , searchTopCheckpoint :: CheckpointId- , searchInteractionId :: InteractionId- , searchFnName :: Maybe QName- , searchCosts :: Costs- , searchStats :: IORef MimerStats- , searchRewrite :: Rewrite- , searchBuiltinFlat :: Maybe QName- -- Cache BUILTIN_FLAT for issue #7662 workaround- }--type Cost = Int-data Costs = Costs- { costLocal :: Cost- , costFn :: Cost- , costDataCon :: Cost- , costRecordCon :: Cost- , costSpeculateProj :: Cost- , costProj :: Cost- , costAxiom :: Cost- , costLet :: Cost- , costLevel :: Cost- , costSet :: Cost -- Should probably be replaced with multiple different costs- , costRecCall :: Cost- , costNewMeta :: Cost -- ^ Cost of a new meta-variable appearing in a non-implicit position- , costNewHiddenMeta :: Cost -- ^ Cost of a new meta-variable appearing in an implicit position- , costCompReuse :: Nat -> Cost -- ^ Cost of reusing a component @n@ times. Only counted when @n>1@.- }--noCost :: Cost-noCost = 0--defaultCosts :: Costs-defaultCosts = Costs- { costLocal = 3- , costFn = 10- , costDataCon = 3- , costRecordCon = 3- , costSpeculateProj = 20- , costProj = 3- , costAxiom = 10- , costLet = 5- , costLevel = 3- , costSet = 10- , costRecCall = 8- , costNewMeta = 10- , costNewHiddenMeta = 1- , costCompReuse = \uses -> 10 * (uses - 1) ^ 2- }----------------------------------------------------------------------------------- * Helper functions---------------------------------------------------------------------------------predNat :: Nat -> Nat-predNat n | n > 0 = n - 1- | n == 0 = 0- | otherwise = error "predNat of negative value"--getRecordFields :: (HasConstInfo tcm, MonadTCM tcm) => QName -> tcm [QName]-getRecordFields = fmap (map unDom . recFields . theDef) . getConstInfo--allOpenMetas :: (AllMetas t, ReadTCState tcm) => t -> tcm [MetaId]-allOpenMetas t = do- openMetas <- getOpenMetas- return $ allMetas (:[]) t `intersect` openMetas--getOpenComponent :: (MonadTCM tcm, MonadDebug tcm) => Open Component -> tcm Component-getOpenComponent openComp = do- let comp = openThing openComp- reportSDoc "mimer.components.open" 40 $ "Opening component" <+> prettyTCM (compId comp) <+> prettyTCM (compName comp)- term <- getOpen $ compTerm <$> openComp- reportSDoc "mimer.components.open" 40 $ " term = " <+> prettyTCM term- typ <- getOpen $ compType <$> openComp- reportSDoc "mimer.components.open" 40 $ " typ =" <+> prettyTCM typ- when (not $ null $ compMetas comp) __IMPOSSIBLE__- return Component- { compId = compId comp- , compName = compName comp- , compPars = compPars comp- , compTerm = term- , compType = typ- , compRec = compRec comp- , compMetas = compMetas comp- , compCost = compCost comp- }--mkComponent :: CompId -> [MetaId] -> Cost -> Maybe Name -> Nat -> Term -> Type -> Component-mkComponent cId metaIds cost mName pars term typ = Component- { compId = cId- , compName = mName- , compPars = pars- , compTerm = term- , compType = typ- , compRec = False- , compMetas = metaIds- , compCost = cost }--mkComponentQ :: CompId -> Cost -> QName -> Nat -> Term -> Type -> Component-mkComponentQ cId cost qname = mkComponent cId [] cost (Just $ qnameName qname)--noName :: Maybe Name-noName = Nothing--newComponent :: MonadFresh CompId m => [MetaId] -> Cost -> Maybe Name -> Nat -> Term -> Type -> m Component-newComponent metaIds cost mName pars term typ = fresh <&> \cId -> mkComponent cId metaIds cost mName pars term typ--newComponentQ :: MonadFresh CompId m => [MetaId] -> Cost -> QName -> Nat -> Term -> Type -> m Component-newComponentQ metaIds cost qname pars term typ = fresh <&> \cId -> mkComponent cId metaIds cost (Just $ qnameName qname) pars term typ--addCost :: Cost -> Component -> Component-addCost cost comp = comp { compCost = cost + compCost comp }--addBranchGoals :: [Goal] -> SearchBranch -> SearchBranch-addBranchGoals goals branch = branch {sbGoals = goals ++ sbGoals branch}--withBranchState :: SearchBranch -> SM a -> SM a-withBranchState br ma = do- putTC (sbTCState br)- ma--withBranchAndGoal :: SearchBranch -> Goal -> SM a -> SM a-withBranchAndGoal br goal ma = inGoalEnv goal $ withBranchState br ma--inGoalEnv :: Goal -> SM a -> SM a-inGoalEnv goal ret = do- reportSDoc "mimer.env" 70 $ "going into environment of goal" <+> prettyTCM (goalMeta goal)- withMetaId (goalMeta goal) ret---- | Take the first goal off a search branch.--- Precondition: the set of goals is non-empty.-nextGoal :: SearchBranch -> (Goal, SearchBranch)-nextGoal branch =- case sbGoals branch of- [] -> __IMPOSSIBLE__- goal : goals -> (goal, branch{ sbGoals = goals })---- TODO: Rename (see metaInstantiation)-getMetaInstantiation :: (MonadTCM tcm, PureTCM tcm, MonadDebug tcm, MonadInteractionPoints tcm, MonadFresh NameId tcm)- => MetaId -> tcm (Maybe Expr)-getMetaInstantiation = metaInstantiation >=> traverse (instantiateFull >=> reify)--metaInstantiation :: (MonadTCM tcm, MonadDebug tcm, ReadTCState tcm) => MetaId -> tcm (Maybe Term)-metaInstantiation metaId = lookupLocalMeta metaId <&> mvInstantiation >>= \case- InstV inst -> return $ Just $ instBody inst- _ -> return Nothing---- TODO: why not also accept pattern record types here?-isTypeDatatype :: (MonadTCM tcm, MonadReduce tcm, HasConstInfo tcm) => Type -> tcm Bool-isTypeDatatype typ = liftTCM do- reduce typ <&> unEl >>= isDataOrRecord <&> \case- Just (_, IsData) -> True- _ -> False----------------------------------------------------------------------------------- * Components----------------------------------------------------------------------------------- | NOTE: Collects components from the *current* context, not the context of--- the 'InteractionId'.-collectComponents :: Options -> Costs -> InteractionId -> Maybe QName -> [QName] -> MetaId -> TCM BaseComponents-collectComponents opts costs ii mDefName whereNames metaId = do-- lhsVars <- collectLHSVars ii- let recVars = lhsVars <&> \ vars -> [ (tm, NoSubst i) | (tm, Just i) <- vars ]-- -- TODO: implement case splitting- -- splitVars <- getSplitVars lhsVars- splitVars <- makeOpen []-- -- Prepare the initial component record- letVars <- getLetVars (costLet costs)- let components = BaseComponents- { hintFns = []- , hintDataTypes = []- , hintRecordTypes = []- , hintProjections = []- , hintAxioms = []- , hintLevel = []- , hintThisFn = Nothing- , hintRecVars = recVars- , hintLetVars = letVars- , hintSplitVars = splitVars- }-- -- Extract additional components from the names given as hints.- hintNames <- getEverythingInScope <$> lookupLocalMeta metaId- isToLevel <- endsInLevelTester- scope <- getScope- components' <- foldM (go isToLevel scope) components $- explicitHints ++ (hintNames \\ explicitHints)-- return BaseComponents- { hintFns = doSort $ hintFns components'- , hintDataTypes = doSort $ hintDataTypes components'- , hintRecordTypes = doSort $ hintRecordTypes components'- , hintProjections = doSort $ hintProjections components'- , hintAxioms = doSort $ hintAxioms components'- , hintLevel = doSort $ hintLevel components'- , hintThisFn = hintThisFn components'- , hintRecVars = recVars- , hintLetVars = letVars- , hintSplitVars = splitVars- }- where- hintMode = optHintMode opts- explicitHints = optExplicitHints opts- -- Sort by the arity of the type- doSort = sortOn (arity . compType)-- isNotMutual qname f = case mDefName of- Nothing -> True- Just defName -> defName /= qname && fmap (defName `elem`) (funMutual f) /= Just True-- go isToLevel scope comps qname = do- def <- getConstInfo qname- let typ = defType def- case theDef def of- Axiom{}- | isToLevel typ -> addLevel- | shouldKeep -> addAxiom- | otherwise -> done- -- We can't use pattern lambdas as components nor with-functions.- -- If the function is in the same mutual block, do not include it.- f@Function{ funWith = Nothing, funExtLam = Nothing }- | Just qname == mDefName -> addThisFn- | notMutual, isToLevel typ -> addLevel- | notMutual, shouldKeep -> addFn- where notMutual = isNotMutual qname f- Function{} -> done- Datatype{} -> addData- Record{} -> do- projections <- mapM (qnameToComponent (costSpeculateProj costs)) =<< getRecordFields qname- comp <- qnameToComponent (costSet costs) qname- return comps{ hintRecordTypes = comp : hintRecordTypes comps- , hintProjections = projections ++ hintProjections comps }- -- We look up constructors when we need them- Constructor{} -> done- -- TODO: special treatment for primitives?- Primitive{}- | isToLevel typ -> addLevel- | shouldKeep -> addFn- | otherwise -> done- PrimitiveSort{} -> done- -- TODO: Check if we want to use these- DataOrRecSig{} -> done- GeneralizableVar{} -> done- AbstractDefn{} -> done- where- done = return comps- -- TODO: There is probably a better way of finding the module name- mThisModule = qnameModule <$> mDefName-- shouldKeep = or- [ qname `elem` explicitHints- , qname `elem` whereNames- , case hintMode of- Unqualified -> Scope.isNameInScopeUnqualified qname scope- AllModules -> True- Module -> Just (qnameModule qname) == mThisModule- NoHints -> False- ]- addLevel = qnameToComponent (costLevel costs) qname <&> \ comp -> comps{hintLevel = comp : hintLevel comps}- addAxiom = qnameToComponent (costAxiom costs) qname <&> \ comp -> comps{hintAxioms = comp : hintAxioms comps}- addThisFn = qnameToComponent (costRecCall costs) qname <&> \ comp -> comps{hintThisFn = Just comp{ compRec = True }}- addFn = qnameToComponent (costFn costs) qname <&> \ comp -> comps{hintFns = comp : hintFns comps}- addData = qnameToComponent (costSet costs) qname <&> \ comp -> comps{hintDataTypes = comp : hintDataTypes comps}---- | Is an element of the given type computing a level?------ The returned checker is only sound but not complete because the type is taken as-is--- rather than being reduced.-endsInLevelTester :: TCM (Type -> Bool)-endsInLevelTester = do- getBuiltinName builtinLevel >>= \case- Nothing -> return $ const False- Just level -> return \ t ->- -- NOTE: We do not reduce the type before checking, so some user definitions- -- will not be included here.- case telView' t of- TelV _ (El _ (Def x _)) -> x == level- _ -> False---qnameToComponent :: (HasConstInfo tcm, ReadTCState tcm, MonadFresh CompId tcm, MonadTCM tcm)- => Cost -> QName -> tcm Component-qnameToComponent cost qname = do- defn <- getConstInfo qname- -- #7120: we need to apply the module params to everything- mParams <- freeVarsToApply qname- let def = (Def qname [] `apply` mParams, 0)- let (term, pars) = case theDef defn of- c@Constructor{} -> (Con (conSrcCon c) ConOCon [], conPars c - length mParams)- Axiom{} -> def- GeneralizableVar{} -> def- Function{} -> def- Datatype{} -> def- Record{} -> def- Primitive{} -> def- PrimitiveSort{} -> def- DataOrRecSig{} -> __IMPOSSIBLE__- AbstractDefn{} -> __IMPOSSIBLE__- newComponentQ [] cost qname pars term (defType defn `piApply` mParams)---- | From the scope of the given meta variable,--- extract all names in scope that we could use during synthesis.--- (This excludes macros, generalizable variables, pattern synonyms.)-getEverythingInScope :: MetaVariable -> [QName]-getEverythingInScope metaVar = do- let scope = clScope $ getMetaInfo metaVar- let nameSpace = Scope.everythingInScope scope- names = Scope.nsNames nameSpace- validKind = \ case- Scope.PatternSynName -> False -- could consider allowing pattern synonyms, but the problem is they can't be getConstInfo'd- Scope.GeneralizeName -> False -- and any way finding the underlying constructors should be easy- Scope.DisallowedGeneralizeName -> False- Scope.MacroName -> False- Scope.QuotableName -> False- Scope.ConName -> True- Scope.CoConName -> True- Scope.FldName -> True- Scope.DataName -> True- Scope.RecName -> True- Scope.FunName -> True- Scope.AxiomName -> True- Scope.PrimName -> True- Scope.OtherDefName -> True- qnames = map Scope.anameName- . filter (validKind . Scope.anameKind)- . map NonEmptyList.head- $ Map.elems names- qnames---- | Turn the let bindings of the current 'TCEnv' into components.-getLetVars :: forall tcm. (MonadFresh CompId tcm, MonadTCM tcm, Monad tcm) => Cost -> tcm [Open Component]-getLetVars cost = do- bindings <- asksTC envLetBindings- mapM makeComp $ Map.toAscList bindings- where- makeComp :: (Name, Open LetBinding) -> tcm (Open Component)- makeComp (name, opn) = do- cId <- fresh- return $ opn <&> \ (LetBinding _origin term typ) ->- mkComponent cId [] cost (Just name) 0 term (unDom typ)---- IDEA for implementing case-splitting:--- [x] 1. Modify the collectRecVarCandidates to get all variables.--- [ ] 2. Go through all variables to see if they are data types (not records)--- [ ] 3. Run makeCase for those variables.--- [ ] 4. Find out how to get the new interaction points/metas from the cases--- [ ] 5. After search is done, compute out-of-scope variables.--- [ ] 6. Run make-case again to introduce those variables.--- [ ] 7. Redo the reification in the new clauses.--- [ ] 8. Return the new clauses and follow Auto for insertion.--getSplitVars :: Open [(Term, Maybe Int)] -> TCM (Open [Term])-getSplitVars lhsVars' = do-- -- Compute the hintSplitVars from the pattern variables of function at the interaction point.- lhsVars <- getOpen $ map fst <$> lhsVars'- typedLocals <- getLocalVarTerms 0- reportSDoc "mimer.components" 40 $ "All LHS variables:" <+> prettyTCM lhsVars <+> parens ("or" <+> pretty lhsVars)- let typedLhsVars = filter (\(term,typ) -> term `elem` lhsVars) typedLocals- reportSDoc "mimer.components" 40 $- "LHS variables with types:" <+> prettyList (map prettyTCMTypedTerm typedLhsVars) <+> parens ("or"- <+> prettyList (map prettyTypedTerm typedLhsVars))- -- TODO: For now, we *never* split on implicit arguments even if they are- -- written explicitly on the LHS.- splitVarsTyped <-- filterM (\ (term, dom) -> pure (visible dom) `and2M` isTypeDatatype (unDom dom))- typedLhsVars- reportSDoc "mimer.components" 40 $- "Splittable variables" <+> prettyList (map prettyTCMTypedTerm splitVarsTyped) <+> parens ("or"- <+> prettyList (map prettyTypedTerm splitVarsTyped))- makeOpen $ map fst splitVarsTyped- where- prettyTCMTypedTerm :: (PrettyTCM tm, PrettyTCM ty) => (tm, ty) -> TCM Doc- prettyTCMTypedTerm (term, typ) = prettyTCM term <+> ":" <+> prettyTCM typ- prettyTypedTerm (term, typ) = pretty term <+> ":" <+> pretty typ---- | Returns the variables as terms together with whether they where found under--- some constructor, and if so which argument of the function they appeared in. This--- information is used when building recursive calls, where it's important that we don't try to--- construct non-terminating solutions.-collectLHSVars :: (ReadTCState tcm, MonadError TCErr tcm, MonadTCM tcm, HasConstInfo tcm)- => InteractionId -> tcm (Open [(Term, Maybe Int)])-collectLHSVars ii = do- ipc <- ipClause <$> lookupInteractionPoint ii- case ipc of- IPNoClause -> makeOpen []- IPClause{ipcQName = fnName, ipcClauseNo = clauseNr} -> do- reportSDoc "mimer.components" 40 $ "Collecting LHS vars for" <+> prettyTCM ii- info <- getConstInfo fnName- parCount <- liftTCM getCurrentModuleFreeVars- case theDef info of- fnDef@Function{} -> do- let clause = funClauses fnDef !! clauseNr- naps = namedClausePats clause-- -- Telescope at interaction point- iTel <- getContextTelescope- -- Telescope for the body of the clause- let cTel = clauseTel clause- -- HACK: To get the correct indices, we shift by the difference in telescope lengths- let shift = length (telToArgs iTel) - length (telToArgs cTel)-- reportSDoc "mimer" 60 $ vcat- [ "Tel:"- , nest 2 $ pretty iTel $$ prettyTCM iTel- , "CTel:"- , nest 2 $ pretty cTel $$ prettyTCM cTel- ]- reportSDoc "mimer" 60 $ "Shift:" <+> pretty shift-- makeOpen [ (Var (n + shift) [], (i - parCount) <$ guard underCon) -- We count arguments excluding module parameters- | (i, nap) <- zip [0..] naps- , (n, underCon) <- go False $ namedThing $ unArg nap- ]- _ -> do- makeOpen []- where- go isUnderCon = \case- VarP patInf x -> [(dbPatVarIndex x, isUnderCon)]- DotP patInf t -> [] -- Ignore dot patterns- ConP conHead conPatInf namedArgs -> concatMap (go True . namedThing . unArg) namedArgs- LitP{} -> []- ProjP{} -> []- IApplyP{} -> [] -- Only for Cubical?- DefP{} -> [] -- Only for Cubical?--declarationQnames :: A.Declaration -> [QName]-declarationQnames dec = [ q | Scope.WithKind _ q <- A.declaredNames dec ]----------------------------------------------------------------------------------- * Measure performance--------------------------------------------------------------------------------data MimerStats = MimerStats- { statCompHit :: Nat -- ^ Could make use of an already generated component- , statCompGen :: Nat -- ^ Could use a generator for a component- , statCompRegen :: Nat -- ^ Had to regenerate the cache (new context)- , statCompNoRegen :: Nat -- ^ Did not have to regenerate the cache- , statMetasCreated :: Nat -- ^ Total number of meta-variables created explicitly (not through unification)- , statTypeEqChecks :: Nat -- ^ Number of times type equality is tested (with unification)- , statRefineSuccess :: Nat -- ^ Number of times a refinement has been successful- , statRefineFail :: Nat -- ^ Number of times a refinement has failed- } deriving (Show, Eq, Generic)-instance NFData MimerStats--emptyMimerStats :: MimerStats-emptyMimerStats = MimerStats- { statCompHit = 0, statCompGen = 0, statCompRegen = 0 , statCompNoRegen = 0 , statMetasCreated = 0, statTypeEqChecks = 0, statRefineSuccess = 0 , statRefineFail = 0}--incCompHit, incCompGen, incCompRegen, incCompNoRegen, incMetasCreated, incTypeEqChecks, incRefineSuccess, incRefineFail :: MimerStats -> MimerStats-incCompHit stats = stats {statCompHit = succ $ statCompHit stats}-incCompGen stats = stats {statCompGen = succ $ statCompGen stats}-incCompRegen stats = stats {statCompRegen = succ $ statCompRegen stats}-incCompNoRegen stats = stats {statCompNoRegen = succ $ statCompNoRegen stats}-incMetasCreated stats = stats {statMetasCreated = succ $ statMetasCreated stats}-incTypeEqChecks stats = stats {statTypeEqChecks = succ $ statTypeEqChecks stats}-incRefineSuccess stats = stats {statRefineSuccess = succ $ statRefineSuccess stats}-incRefineFail stats = stats {statRefineFail = succ $ statRefineFail stats}--updateStat :: (MimerStats -> MimerStats) -> SM ()-updateStat f = verboseS "mimer.stats" 10 $ do- ref <- asks searchStats- liftIO $ modifyIORef' ref f------------------------------------------------------------------------------------ * Core algorithm---------------------------------------------------------------------------------runSearch :: Rewrite -> Options -> InteractionId -> Range -> TCM [MimerResult]-runSearch norm options ii rng = withInteractionId ii $ do- (mTheFunctionQName, whereNames) <- fmap ipClause (lookupInteractionPoint ii) <&> \case- clause@IPClause{} -> ( Just $ ipcQName clause- , case A.whereDecls $ A.clauseWhereDecls $ ipcClause clause of- Just decl -> declarationQnames decl- _ -> []- )- IPNoClause -> (Nothing, [])-- reportSDoc "mimer.init" 15 $ "Interaction point in function:" <+> pretty mTheFunctionQName- reportSDoc "mimer.init" 25 $ "Names in where-block" <+> pretty whereNames-- metaId <- lookupInteractionId ii- metaVar <- lookupLocalMeta metaId-- -- We want to be able to solve with recursive calls- setMetaOccursCheck metaId DontRunMetaOccursCheck-- metaIds <- case mvInstantiation metaVar of- InstV inst -> do-- metaIds <- allOpenMetas (instBody inst)-- -- TODO: Make pretty instantiation for 'Instantiation'?- reportSDoc "mimer.init" 20 $ sep [ "Interaction point already instantiated:" <+> pretty (instBody inst)- , "with args" <+> pretty (instTel inst) ]-- -- ctx <- getContextTelescope- -- #7402: still solve the top-level meta, because we don't have the correct contexts for the- -- submetas- return [metaId | not $ null metaIds]- OpenMeta UnificationMeta -> do- reportSLn "mimer.init" 20 "Interaction point not instantiated."- return [metaId]- _ -> __IMPOSSIBLE__- -- TODO: Print each meta-variable's full context telescope- reportSDoc "mimer.init" 20 $ "Remaining meta-variables to solve:" <+> prettyTCM metaIds- reportSDoc "mimer.init" 20 $ "Meta var args" <+> (prettyTCM =<< getMetaContextArgs metaVar)--- fnArgs1 <- withShowAllArguments' False $ getContextArgs >>= mapM prettyTCM- fnArgs2 <- withShowAllArguments' True $ getContextArgs >>= mapM prettyTCM- let bringScope = map snd $ filter (uncurry (/=)) $ zip fnArgs1 fnArgs2- bringScopeNoBraces = map (filter (`notElem` ['{', '}']) . P.render) bringScope- reportSDoc "mimer.temp" 20 $ vcat- [ "Things to bring into scope:"- , nest 2 $ vcat- [ "Context args (don't show):" <+> pretty fnArgs1- , "Context args (show all): " <+> pretty fnArgs2- , "To bring into scope: " <+> pretty bringScope- , "To bring into scope (str):" <+> pretty bringScopeNoBraces- ]- ]-- -- Check if there are any meta-variables to be solved- case metaIds of- -- No variables to solve, return the instantiation given- [] -> do- case mvInstantiation metaVar of- InstV inst -> do- expr <- withInteractionId ii $ do- metaArgs <- getMetaContextArgs metaVar- instantiateFull (apply (MetaV metaId []) metaArgs) >>= normalForm norm >>= reify- str <- P.render <$> prettyTCM expr- let sol = MimerExpr str- reportSDoc "mimer.init" 10 $ "Goal already solved. Solution:" <+> text str- return [sol]- _ -> __IMPOSSIBLE__- _ -> do- costs <- ifM (hasVerbosity "mimer.cost.custom" 10)- {- then -} customCosts- {- else -} (return defaultCosts)- reportSDoc "mimer.cost.custom" 10 $ "Using costs:" $$ nest 2 (pretty costs)- components <- collectComponents options costs ii mTheFunctionQName whereNames metaId- let startGoals = map Goal metaIds-- state <- getTC- env <- askTC-- let startBranch = SearchBranch- { sbTCState = state- , sbGoals = startGoals- , sbCost = 0- , sbCache = Map.empty- , sbComponentsUsed = Map.empty- }-- statsRef <- liftIO $ newIORef emptyMimerStats- checkpoint <- viewTC eCurrentCheckpoint- mflat <- getBuiltinName BuiltinFlat- let searchOptions = SearchOptions- { searchBaseComponents = components- , searchHintMode = optHintMode options- , searchTimeout = optTimeout options- , searchGenProjectionsLocal = True- , searchGenProjectionsLet = True- , searchGenProjectionsExternal = False- , searchGenProjectionsRec = True- , searchSpeculateProjections = True- , searchTopMeta = metaId- , searchTopEnv = env- , searchTopCheckpoint = checkpoint- , searchInteractionId = ii- , searchFnName = mTheFunctionQName- , searchCosts = costs- , searchStats = statsRef- , searchRewrite = norm- , searchBuiltinFlat = mflat- }-- reportSDoc "mimer.init" 20 $ "Using search options:" $$ nest 2 (prettyTCM searchOptions)- reportSDoc "mimer.init" 20 $ "Initial search branch:" $$ nest 2 (pretty startBranch)-- flip runReaderT searchOptions $ bench [] $ do-- -- TODO: Check what timing stuff is used in Agda.Utils.Time- timeout <- fromMilliseconds <$> asks searchTimeout- startTime <- liftIO getCPUTime- let go :: Int -> Int -> MinQueue SearchBranch -> SM ([MimerResult], Int)- go 0 n _ = pure ([], n)- go need n branchQueue = case Q.minView branchQueue of- Nothing -> do- reportSLn "mimer.search" 30 $ "No remaining search branches."- return ([], n)- Just (branch, branchQueue') -> do- time <- liftIO getCPUTime- mimerTrace 0 10 $ vcat- [ "Choosing branch"- , nest 2 $ sep- [ branchInstantiationDocCost branch <> ","- , nest 2 $ "metas:" <+> prettyTCM (map goalMeta $ sbGoals branch)- ]- ]- reportSDoc "mimer.search" 50 $ "Full branch:" <+> pretty branch- reportSMDoc "mimer.search" 50 $- "Instantiation of other branches:" <+> prettyList (map branchInstantiationDocCost $ Q.toAscList branchQueue')-- let elapsed = time - startTime- if elapsed < timeout- then do- (newBranches, sols) <- refine branch >>= partitionStepResult- let branchQueue'' = foldr Q.insert branchQueue' newBranches- reportSLn "mimer.search" 40 $ show (length sols) ++ " solutions found during cycle " ++ show (n + 1)- reportSMDoc "mimer.search" 45 $ "Solutions:" <+> prettyTCM sols- mimerTrace 0 40 $ vcat- [ "Cycle" <+> pretty (n + 1) <+> "branches"- , nest 2 $ vcat $ map branchInstantiationDocCost $ Q.toAscList branchQueue''- ]- unless (null sols) $ mimerTrace 0 20 $ vcat- [ "Cycle" <+> pretty (n + 1) <+> "solutions"- , nest 2 $ vcat $ map prettyTCM sols- ]-- let sols' = take need sols- mapFst (sols' ++) <$> go (need - length sols') (n + 1) branchQueue''- else do- reportSLn "mimer.search" 30 $ "Search time limit reached. Elapsed search time: " ++ show elapsed- return ([], n)- let numSolutions | optList options = 10 + optSkip options- | otherwise = 1 + optSkip options- (sols, nrSteps) <- go numSolutions 0 $ Q.singleton startBranch- reportSLn "mimer.search" 20 $ "Search ended after " ++ show (nrSteps + 1) ++ " cycles"- -- results <- liftTCM $ mapM exprToStringAndVars sols- reportSDoc "mimer.search" 15 $ "Solutions found: " <+> prettyList (map prettyTCM sols)- reportSMDoc "mimer.stats" 10 $ do- ref <- asks searchStats- stats <- liftIO $ readIORef ref- "Statistics:" <+> text (show stats)- return sols--tryComponents :: Goal -> Type -> SearchBranch -> [(Component, [Component])] -> SM [SearchStepResult]-tryComponents goal goalType branch comps = withBranchAndGoal branch goal $ do- checkpoint <- viewTC eCurrentCheckpoint- let tryFor (sourceComp, comps') = do- -- Clear out components that depend on meta-variables that have been used.- let newCache = Map.insert sourceComp Nothing (sbCache branch Map.! checkpoint)- newBranches <- catMaybes <$> mapM (tryRefineWith goal goalType branch) comps'- return $ map (\br -> br{sbCache = Map.insert checkpoint newCache (sbCache branch)}) newBranches- newBranches <- concatMapM tryFor comps- mapM checkSolved newBranches---- | If there is no cache entry for the checkpoint, create one. If there already--- is one, even if the components are not yet generated for some entries, it is--- returned as is.-prepareComponents :: Goal -> SearchBranch -> SM (SearchBranch, [(Component, [Component])])-prepareComponents goal branch = withBranchAndGoal branch goal $ do- reportSDoc "mimer.components" 50 $ "Preparing components for goal" <+> prettyTCM (goalMeta goal)- checkpoint <- viewTC eCurrentCheckpoint- -- Check if we there is something in the cache for this checkpoint- comps <- case Map.lookup checkpoint (sbCache branch) of- -- No, generate components from scratch- Nothing -> do- updateStat incCompRegen- reportSDoc "mimer.components" 20 $ vcat- [ "No cache found checkpoint:" <+> pretty checkpoint- , nest 2 $ "with context:" <+> (inTopContext . prettyTCM =<< getContextTelescope) ]- -- Generate components for this context- comps <- genComponents- reportSDoc "mimer.components" 20 $ "Generated" <+> pretty (sum $ map (length . snd) comps) <+> "components"- return comps- -- Yes, just update the missing generated components- Just cache -> mapM prepare (Map.toAscList cache)- let newCache = Map.fromList $ map (mapSnd Just) comps- branch' <- updateBranch [] branch{sbCache = Map.insert checkpoint newCache (sbCache branch)}- return (branch', comps)- where- prepare :: (Component, Maybe [Component]) -> SM (Component, [Component])- prepare (sourceComp, Just comps) = do- updateStat incCompNoRegen- return (sourceComp, comps)- prepare (sourceComp, Nothing) = do- updateStat incCompRegen- (sourceComp,) <$> genComponentsFrom True sourceComp--localVarCount :: SM Int-localVarCount = do- top <- asks $ length . envContext . searchTopEnv- cur <- length <$> getContext- pure $ cur - top--genComponents :: SM [(Component, [Component])]-genComponents = do- opts <- ask- let comps = searchBaseComponents opts- n <- localVarCount- localVars <- lift (getLocalVars n (costLocal $ searchCosts opts))- >>= genAddSource (searchGenProjectionsLocal opts)- recCalls <- genAddSource (searchGenProjectionsRec opts) (maybeToList $ hintThisFn comps)- letVars <- mapM getOpenComponent (hintLetVars comps)- >>= genAddSource (searchGenProjectionsLet opts)- fns <- genAddSource (searchGenProjectionsExternal opts) (hintFns comps)- axioms <- genAddSource (searchGenProjectionsExternal opts) (hintAxioms comps)- return $ localVars ++ letVars ++ recCalls ++ fns ++ axioms- where- genAddSource :: Bool -> [Component] -> SM [(Component, [Component])]- genAddSource genProj = mapM (\comp -> (comp,) <$> genComponentsFrom genProj comp)---genComponentsFrom :: Bool -- ^ Apply record elimination- -> Component- -> SM [Component]-genComponentsFrom appRecElims origComp = do- reportSDoc "mimer.components" 50 $ "Generating components from original component" <+> prettyTCM (compId origComp) <+> prettyTCM (compName origComp)- comps <- if | compRec origComp -> mapM (applyToMetasG Nothing) =<< genRecCalls origComp- | otherwise -> (:[]) <$> applyToMetasG Nothing origComp- if appRecElims- then concat <$> mapM (applyProjections Set.empty) comps- else return comps- where- applyProjections :: Set QName -> Component -> SM [Component]- applyProjections seenRecords comp = do- projComps <- getRecordInfo (compType comp) >>= \case- Nothing -> return []- Just (recordName, args, fields, isRecursive)- | Set.member recordName seenRecords -> do- reportSDoc "mimer.components" 60 $- "Skipping projection because recursive record already seen:" <+> pretty recordName- return []- | otherwise -> do- let seenRecords' = if isRecursive then Set.insert recordName seenRecords else seenRecords- comps <- mapM (applyProj args comp >=> applyToMetasG Nothing) fields- concatMapM (applyProjections seenRecords') comps- return $ comp : projComps--getRecordInfo :: Type- -> SM (Maybe ( QName -- Record name- , Args -- Record parameters converted to (hidden) arguments- , [QName] -- Field names- , Bool -- Is recursive?- ))-getRecordInfo typ = case unEl typ of- Def qname elims -> isRecord qname >>= \case- Nothing -> return Nothing- Just defn -> do- fields <- getRecordFields qname- return $ Just (qname, argsFromElims elims, fields, recRecursive_ defn)- _ -> return Nothing--applyProj :: Args -> Component -> QName -> SM Component-applyProj recordArgs comp' qname = do- cost <- asks (costProj . searchCosts)- -- Andreas, 2025-03-31, issue #7662: hack to prevent postfix printing of ♭- projOrigin <- maybe ProjSystem (\ flat -> if qname == flat then ProjPrefix else ProjSystem)- <$> asks searchBuiltinFlat- let newTerm = applyE (compTerm comp') [Proj projOrigin qname]- projType <- defType <$> getConstInfo qname- projTypeWithArgs <- piApplyM projType recordArgs- newType <- piApplyM projTypeWithArgs (compTerm comp')- newComponentQ (compMetas comp') (compCost comp' + cost) qname 0 newTerm newType----- TODO: currently reducing twice-applyToMetasG- :: Maybe Nat -- ^ Max number of arguments to apply.- -> Component -> SM Component-applyToMetasG (Just m) comp | m <= 0 = return comp-applyToMetasG maxArgs comp = do- reportSDoc "mimer.component" 25 $ "Applying component to metas" <+> prettyTCM (compId comp) <+> prettyTCM (compTerm comp)- ctx <- getContextTelescope- compTyp <- reduce $ compType comp- case unEl compTyp of- Pi dom abs -> do- let domainType = unDom dom- (metaId, metaTerm) <- createMeta domainType- reportSDoc "mimer.component" 30 $ "New arg meta" <+> prettyTCM metaTerm- let arg = setOrigin Inserted $ metaTerm <$ argFromDom dom- newType <- reduce =<< piApplyM (compType comp) metaTerm- -- Constructor parameters are not included in the term- let skip = compPars comp- newTerm | skip > 0 = compTerm comp- | otherwise = apply (compTerm comp) [arg]- cost <- asks $ (if getHiding arg == Hidden then costNewHiddenMeta else costNewMeta) . searchCosts- applyToMetasG (predNat <$> maxArgs)- comp{ compTerm = newTerm- , compType = newType- , compPars = predNat skip- , compMetas = metaId : compMetas comp- , compCost = cost + compCost comp- }- _ ->- -- Set the type to the reduced version- return comp{compType = compTyp}--createMeta :: Type -> SM (MetaId, Term)-createMeta typ = do- (metaId, metaTerm) <- newValueMeta DontRunMetaOccursCheck CmpLeq typ- verboseS "mimer.stats" 20 $ updateStat incMetasCreated- reportSDoc "mimer.components" 80 $ do- "Created meta-variable (type in context):" <+> pretty metaTerm <+> ":" <+> (pretty =<< getMetaTypeInContext metaId)- return (metaId, metaTerm)---partitionStepResult :: [SearchStepResult] -> SM ([SearchBranch], [MimerResult])-partitionStepResult [] = return ([],[])-partitionStepResult (x:xs) = do- let rest = partitionStepResult xs- (brs',sols) <- rest- case x of- NoSolution -> rest- OpenBranch br -> return (br:brs', sols)- ResultExpr exp -> do- str <- P.render <$> prettyTCM exp- return $ (brs', MimerExpr str : sols)- ResultClauses cls -> do- f <- fromMaybe __IMPOSSIBLE__ <$> asks searchFnName- return $ (brs', MimerClauses f cls : sols)---topInstantiationDoc :: SM Doc-topInstantiationDoc = asks searchTopMeta >>= getMetaInstantiation >>= maybe (return "(nothing)") prettyTCM--prettyGoalInst :: Goal -> SM Doc-prettyGoalInst goal = inGoalEnv goal $ do- args <- map Apply <$> getContextArgs- prettyTCM =<< instantiate (MetaV (goalMeta goal) args)--branchInstantiationDocCost :: SearchBranch -> SM Doc-branchInstantiationDocCost branch = branchInstantiationDoc branch <+> parens ("cost:" <+> pretty (sbCost branch))---- | For debug-branchInstantiationDoc :: SearchBranch -> SM Doc-branchInstantiationDoc branch = withBranchState branch topInstantiationDoc--refine :: SearchBranch -> SM [SearchStepResult]-refine branch = withBranchState branch $ do- let (goal1, branch1) = nextGoal branch-- withBranchAndGoal branch1 goal1 $ do- goalType1 <- bench [Bench.Reduce] $ reduce =<< getMetaTypeInContext (goalMeta goal1)-- mimerTrace 1 10 $ sep- [ "Refining goal"- , nest 2 $ prettyTCM (goalMeta goal1) <+> ":" <+> prettyTCM goalType1- , nest 2 $ "in context" <+> (inTopContext . prettyTCM =<< getContextTelescope)- ]-- reportSDoc "mimer.refine" 30 $ "Goal type:" <+> pretty goalType1- reportSDoc "mimer.refine" 30 $ "Goal context:" <+> (pretty =<< getContextTelescope)-- -- Lambda-abstract as far as possible- tryLamAbs goal1 goalType1 branch1 >>= \case- -- Absurd lambda- Left branch2 -> do- mimerTrace 1 10 $ sep- [ "Absurd bambda refinement", nest 2 $ prettyGoalInst goal1 ]- args <- map Apply <$> getContextArgs- e <- blankNotInScope =<< reify (MetaV (goalMeta goal1) args)- return [ResultExpr e]- -- Normal abstraction- Right (goal2, goalType2, branch2) -> withBranchAndGoal branch2 goal2 $ do- (branch3, components) <- prepareComponents goal2 branch2- withBranchAndGoal branch3 goal2 $ do-- when (goalMeta goal2 /= goalMeta goal1) $ do- mimerTrace 1 10 $ sep- [ "Lambda refinement", nest 2 $ prettyGoalInst goal1 ]- mimerTrace 1 10 $ sep- [ "Refining goal"- , nest 2 $ prettyTCM (goalMeta goal2) <+> ":" <+> prettyTCM goalType2- , nest 2 $ "in context" <+> (inTopContext . prettyTCM =<< getContextTelescope)- ]-- mimerTrace 2 40 $ vcat- [ "Components:"- , nest 2 $ vcat $ map prettyTCM $ concatMap snd components- ]-- results1 <- tryComponents goal2 goalType2 branch3 components- results2 <- tryDataRecord goal2 goalType2 branch3- return $ results1 ++ results2--tryFns :: Goal -> Type -> SearchBranch -> SM [SearchStepResult]-tryFns goal goalType branch = withBranchAndGoal branch goal $ do- reportSDoc "mimer.refine.fn" 50 $ "Trying functions"- fns <- asks (hintFns . searchBaseComponents)- newBranches <- catMaybes <$> mapM (tryRefineAddMetas goal goalType branch) fns- mapM checkSolved newBranches--tryProjs :: Goal -> Type -> SearchBranch -> SM [SearchStepResult]-tryProjs goal goalType branch = withBranchAndGoal branch goal $ do- projs <- asks (hintProjections . searchBaseComponents)- newBranches <- catMaybes <$> mapM (tryRefineAddMetas goal goalType branch) projs- mapM checkSolved newBranches--tryAxioms :: Goal -> Type -> SearchBranch -> SM [SearchStepResult]-tryAxioms goal goalType branch = withBranchAndGoal branch goal $ do- axioms <- asks (hintAxioms . searchBaseComponents)- newBranches <- catMaybes <$> mapM (tryRefineAddMetas goal goalType branch) axioms- mapM checkSolved newBranches--tryLet :: Goal -> Type -> SearchBranch -> SM [SearchStepResult]-tryLet goal goalType branch = withBranchAndGoal branch goal $ do- letVars <- asks (hintLetVars . searchBaseComponents) >>= mapM getOpenComponent- newBranches <- catMaybes <$> mapM (tryRefineAddMetas goal goalType branch) letVars- mapM checkSolved newBranches---- | Returns @Right@ for normal lambda abstraction and @Left@ for absurd lambda.-tryLamAbs :: Goal -> Type -> SearchBranch -> SM (Either SearchBranch (Goal, Type, SearchBranch))-tryLamAbs goal goalType branch =- case unEl goalType of- Pi dom abs -> isEmptyType (unDom dom) >>= \case- True -> do- f <- liftTCM $ makeAbsurdLambda noRange dom abs- args <- map Apply <$> getContextArgs- newMetaIds <- assignMeta (goalMeta goal) (Def f args) goalType- Left <$> updateBranch newMetaIds branch- False -> do- reportSDoc "mimer.lam" 40 $ "Trying lambda abstraction for pi type" <+> prettyTCM goalType- let abs' | isNoName (absName abs) = abs { absName = "z" }- | otherwise = abs- (metaId', bodyType, metaTerm, env) <- underAbstractionAbs dom abs' $ \bodyType -> do- reportSDoc "mimer.lam" 40 $ " bodyType = " <+> prettyTCM bodyType- bodyType <- bench [Bench.Reduce] $ reduce bodyType -- TODO: Good place to reduce?- reportSDoc "mimer.lam" 40 $ " bodyType (reduced) = " <+> prettyTCM bodyType- (metaId', metaTerm) <- bench [Bench.Free] $ newValueMeta DontRunMetaOccursCheck CmpLeq bodyType- reportSDoc "mimer.lam" 40 $ " metaId' = " <+> prettyTCM metaId'- env <- askTC- return (metaId', bodyType, metaTerm, env)-- let argInf = domInfo dom -- TODO: is this the correct arg info?- newAbs = Abs (absName abs') metaTerm- -- look at mkLam- term = Lam argInf newAbs-- newMetaIds <- assignMeta (goalMeta goal) term goalType-- withEnv env $ do- branch' <- updateBranch newMetaIds branch- tryLamAbs (Goal metaId') bodyType branch'- _ -> done- where- done = do- branch' <- updateBranch [] branch -- TODO: Is this necessary?- return $ Right (goal, goalType, branch')---genRecCalls :: Component -> SM [Component]-genRecCalls thisFn = do- reportSDoc "mimer.components.open" 40 $ "Generating recursive calls for component" <+> prettyTCM (compId thisFn) <+> prettyTCM (compName thisFn)- reportSDoc "mimer.components.open" 60 $ " checkpoint =" <+> (prettyTCM =<< viewTC eCurrentCheckpoint)- -- TODO: Make sure there are no pruning problems- asks (hintRecVars . searchBaseComponents) >>= getOpen >>= \case- -- No candidate arguments for a recursive call- [] -> return []- recCandTerms -> do- Costs{..} <- asks searchCosts- n <- localVarCount- localVars <- lift $ getLocalVars n costLocal- let recCands = [ (t, i) | t@(compTerm -> v@Var{}) <- localVars, NoSubst i <- maybeToList $ lookup v recCandTerms ]-- let newRecCall = do- -- Apply the recursive call to new metas- (thisFnTerm, thisFnType, newMetas) <- applyToMetas 0 (compTerm thisFn) (compType thisFn)- let argGoals = map Goal newMetas- comp <- newComponent newMetas (compCost thisFn) (compName thisFn) 0 thisFnTerm thisFnType- return (comp, zip argGoals [0..])-- -- go :: Component -- ^ Recursive call function applied to meta-variables- -- -> [(Goal, Int)] -- ^ Remaining parameters to try to fill- -- -> [(Component, Int)] -- ^ Remaining argument candidates for the current parameter- -- -> SM [Component]- go _thisFn [] _args = return []- go thisFn (_ : goals) [] = go thisFn goals recCands- go thisFn ((goal, i) : goals) ((arg, j) : args) | i == j = do- reportSMDoc "mimer.components.rec" 80 $ hsep- [ "Trying to generate recursive call"- , prettyTCM (compTerm thisFn)- , "with" <+> prettyTCM (compTerm arg)- , "for" <+> prettyTCM (goalMeta goal) ]- goalType <- getMetaTypeInContext (goalMeta goal)- state <- getTC- tryRefineWith' goal goalType arg >>= \case- Nothing -> do- putTC state- go thisFn ((goal, i) : goals) args- Just (newMetas1, newMetas2) -> do- let newComp = thisFn{compMetas = newMetas1 ++ newMetas2 ++ (compMetas thisFn \\ [goalMeta goal])}- (thisFn', goals') <- newRecCall- (newComp:) <$> go thisFn' (drop (length goals' - length goals - 1) goals') args- go thisFn goals (_ : args) = go thisFn goals args- (thisFn', argGoals) <- newRecCall- comps <- go thisFn' argGoals recCands- -- Compute costs for the calls:- -- - costNewMeta/costNewHiddenMeta for each unsolved argument- -- - zero for solved arguments- -- - costLocal for the parameter we recurse on- let callCost comp = (costLocal +) . sum <$> argCosts (compTerm comp)- argCosts (Def _ elims) = mapM argCost elims- argCosts _ = __IMPOSSIBLE__- argCost (Apply arg) = instantiate arg <&> \ case- Arg h MetaV{} | visible h -> costNewMeta- | otherwise -> costNewHiddenMeta- _ -> 0- argCost Proj{} = pure 0- argCost IApply{} = pure 0- mapM (\ c -> (`addCost` c) <$> callCost c) comps----- TODO: Factor out `checkSolved`-tryDataRecord :: Goal -> Type -> SearchBranch -> SM [SearchStepResult]-tryDataRecord goal goalType branch = withBranchAndGoal branch goal $ do- -- TODO: There is a `isRecord` function, which performs a similar case- -- analysis as here, but it does not work for data types.- case unEl goalType of- Def qname elims -> theDef <$> getConstInfo qname >>= \case- recordDefn@Record{} -> do- tryRecord recordDefn- dataDefn@Datatype{} -> do- tryData dataDefn- primitive@Primitive{} -> do- return []- -- TODO: Better way of checking that type is Level- Axiom{}- | P.prettyShow qname == "Agda.Primitive.Level" -> do- tryLevel- | otherwise -> do- return []- DataOrRecSig{} -> do- return []- GeneralizableVar{} -> do- return []- AbstractDefn{} -> do- return []- Function{} -> do- return []- Constructor{} -> do- return []- PrimitiveSort{} -> do- return []- Sort (Type level) -> do- trySet level- Sort sort -> do- return []- _ -> return []- where- -- TODO: Alternatively, the constructor can be accessed via `getRecordConstructor`- -- TODO: There might be a neater way of applying the constructor to new metas- tryRecord :: Defn -> SM [SearchStepResult]- tryRecord recordDefn = do- cost <- asks (costRecordCon . searchCosts) -- TODO: Use lenses for this?- comp <- qnameToComponent cost $ conName $ recConHead recordDefn- -- NOTE: at most 1- newBranches <- maybeToList <$> tryRefineAddMetas goal goalType branch comp- mapM checkSolved newBranches-- tryData :: Defn -> SM [SearchStepResult]- tryData dataDefn = do- let constructors = dataCons dataDefn- reportSDoc "mimer.try" 40 $ hsep $ "tryData" : map prettyTCM constructors- cost <- asks (costDataCon . searchCosts)- comps <- mapM (qnameToComponent cost) constructors- newBranches <- mapM (tryRefineAddMetas goal goalType branch) comps- -- TODO: Reduce overlap between e.g. tryLocals, this and tryRecord- mapM checkSolved (catMaybes newBranches)-- tryLevel :: SM [SearchStepResult]- tryLevel = do- levelHints <- asks (hintLevel . searchBaseComponents)- newBranches <- catMaybes <$> mapM (tryRefineAddMetas goal goalType branch) levelHints- mapM checkSolved newBranches-- -- TODO: Add an extra filtering on the sort- trySet :: Level -> SM [SearchStepResult]- trySet level = do- reducedLevel <- reduce level- cost <- asks (costSet . searchCosts)- setCandidates <- case reducedLevel of- (Max i [])- | i > 0 -> do- comp <- newComponent [] cost Nothing 0 (Sort $ Type $ Max (i - 1) []) goalType- return [(branch, comp)]- | otherwise -> return []- (Max i ps) -> do- (metaId, metaTerm) <- createMeta =<< levelType- comp <- newComponent [metaId] cost Nothing 0 (Sort $ Type $ Max (max 0 (i - 1)) [Plus 0 metaTerm]) goalType- branch' <- updateBranch [metaId] branch- return [(branch', comp)]- reportSDoc "mimer.refine.set" 40 $- "Trying" <+> prettyTCM (map snd setCandidates) <+> "for" <+> prettyTCM goalType- newBranches <- catMaybes <$> mapM (\(br,c) -> tryRefineWith goal goalType br c) setCandidates- components <- asks searchBaseComponents- newBranches' <- catMaybes <$> mapM (tryRefineAddMetas goal goalType branch)- (concatMap ($ components)- [ hintDataTypes- , hintRecordTypes- , hintAxioms])- mapM checkSolved (newBranches ++ newBranches')---- | Type should already be reduced here--- NOTE: Does not reset the state!--- TODO: Make sure the type is always reduced-tryRefineWith :: Goal -> Type -> SearchBranch -> Component -> SM (Maybe SearchBranch)-tryRefineWith goal goalType branch comp = withBranchAndGoal branch goal $ do-- metasCreatedBy (dumbUnifierErr (compType comp) goalType) >>= \case- (Nothing, newMetaStore) -> do- updateStat incRefineSuccess- -- TODO: Why is newMetaIds not used here?- newMetaIds <- assignMeta (goalMeta goal) (compTerm comp) goalType- let newMetaIds' = Map.keys (openMetas newMetaStore)- reportSDoc "mimer.refine" 60 $- "Refine: assignMeta created new metas:" <+> prettyTCM newMetaIds-- reportSMDoc "mimer.refine" 50 $ "Refinement succeeded"-- mimerTrace 2 10 $ sep- [ "Found refinement"- , nest 2 $ sep [ prettyTCM (compTerm comp)- , ":" <+> prettyTCM (compType comp) ] ]- -- Take the metas stored in the component and add them as sub-goals- Just <$> updateBranchCost comp (newMetaIds' ++ compMetas comp) branch- (Just err, _) -> do- updateStat incRefineFail- reportSMDoc "mimer.refine" 50 $ "Refinement failed"-- mimerTrace 2 60 $ vcat- [ "Failed refinement"- , nest 2 $ sep [ prettyTCM (compTerm comp)- , ":" <+> prettyTCM (compType comp) ]- , nest 2 $ prettyTCM err ]- return Nothing--tryRefineWith' :: Goal -> Type -> Component -> SM (Maybe ([MetaId], [MetaId]))-tryRefineWith' goal goalType comp = do- metasCreatedBy (dumbUnifier (compType comp) goalType) >>= \case- (True, newMetaStore) -> do- newMetaIds <- assignMeta (goalMeta goal) (compTerm comp) goalType- let newMetaIds' = Map.keys (openMetas newMetaStore)- return $ Just (newMetaIds, newMetaIds')- (False, _) -> return Nothing---- TODO: Make policy for when state should be put-tryRefineAddMetas :: Goal -> Type -> SearchBranch -> Component -> SM (Maybe SearchBranch)-tryRefineAddMetas goal goalType branch comp = withBranchAndGoal branch goal $ do- -- Apply the hint to new metas (generating @c@, @c ?@, @c ? ?@, etc.)- -- TODO: Where is the best place to reduce the hint type?- comp' <- applyToMetasG Nothing comp- branch' <- updateBranch [] branch- tryRefineWith goal goalType branch' comp'---- TODO: Make sure the type is reduced the first time this is called--- TODO: Rewrite with Component?--- NOTE: The new metas are in left-to-right order -- the opposite of the--- order they should be solved in.-applyToMetas :: Nat -> Term -> Type -> SM (Term, Type, [MetaId])-applyToMetas skip term typ = do- ctx <- getContextTelescope- case unEl typ of- Pi dom abs -> do- let domainType = unDom dom- -- TODO: What exactly does the occur check do?- (metaId', metaTerm) <- bench [Bench.Free] $ newValueMeta DontRunMetaOccursCheck CmpLeq domainType- let arg = setOrigin Inserted $ metaTerm <$ argFromDom dom- newType <- bench [Bench.Reduce] $ reduce =<< piApplyM typ metaTerm -- TODO: Is this the best place to reduce?- -- For records, the parameters are not included in the term- let newTerm = if skip > 0 then term else apply term [arg]- (term', typ', metas) <- applyToMetas (predNat skip) newTerm newType- return (term', typ', metaId' : metas)- _ -> return (term, typ, [])--normaliseSolution :: Term -> SM Term-normaliseSolution t = do- norm <- asks searchRewrite- lift . normalForm norm =<< instantiateFull t--checkSolved :: SearchBranch -> SM SearchStepResult-checkSolved branch = do- reportSDoc "mimer" 20 $ "Checking if branch is solved"- reportSDoc "mimer" 30 $ " remaining subgoals: " <+> prettyTCM (map goalMeta $ sbGoals branch)- topMetaId <- asks searchTopMeta- topMeta <- lookupLocalMeta topMetaId- ii <- asks searchInteractionId- withInteractionId ii $ withBranchState branch $ do- metaArgs <- getMetaContextArgs topMeta- inst <- normaliseSolution $ apply (MetaV topMetaId []) metaArgs- -- Issue #7639: The subgoals as generated by `applyToMetasG` (and other functions)- -- are already stored in the `sbGoals` field of the branch.- -- Here we just prune the subgoals that are already solved by unification.- goals <- filterM (isNothing <.> getMetaInstantiation . goalMeta) $ sbGoals branch- case goals of- -- Issue #378: Blank out variables that are not in scope.- -- This might leave unsolved metas but is probably better- -- than generating out-of-scope variables.- [] -> ResultExpr <$> (blankNotInScope =<< reify inst)- _ -> do- return $ OpenBranch branch { sbGoals = goals }--setAt :: Int -> a -> [a] -> [a]-setAt i x xs = case splitAt i xs of- (ls, _r:rs) -> ls ++ (x : rs)- _ -> error "setAt: index out of bounds"--updateBranch' :: Maybe Component -> [MetaId] -> SearchBranch -> SM SearchBranch-updateBranch' mComp newMetaIds branch = do- state <- getTC- let compsUsed = sbComponentsUsed branch- (deltaCost, compsUsed') <- case mComp of- Nothing -> return (0, compsUsed)- Just comp -> do- case compName comp of- Nothing -> return (compCost comp, compsUsed)- Just name -> case compsUsed Map.!? name of- Nothing -> return (compCost comp, Map.insert name 1 compsUsed)- Just uses -> do- reuseCost <- asks (costCompReuse . searchCosts)- return (compCost comp + reuseCost uses, Map.adjust succ name compsUsed)- return branch{ sbTCState = state- , sbGoals = map Goal newMetaIds ++ sbGoals branch- , sbCost = sbCost branch + deltaCost- , sbComponentsUsed = compsUsed'- }--updateBranch :: [MetaId] -> SearchBranch -> SM SearchBranch-updateBranch = updateBranch' Nothing--updateBranchCost :: Component -> [MetaId] -> SearchBranch -> SM SearchBranch-updateBranchCost comp = updateBranch' (Just comp)--assignMeta :: MetaId -> Term -> Type -> SM [MetaId]-assignMeta metaId term metaType = bench [Bench.CheckRHS] $ do- ((), newMetaStore) <- metasCreatedBy $ do- metaVar <- lookupLocalMeta metaId- metaArgs <- getMetaContextArgs metaVar-- reportSMDoc "mimer.assignMeta" 60 $ vcat- [ "Assigning" <+> pretty term- , nest 2 $ vcat [ "to" <+> pretty metaId <+> ":" <+> pretty metaType- , "in context" <+> (pretty =<< getContextTelescope)- ]- ]-- assignV DirLeq metaId metaArgs term (AsTermsOf metaType) `catchError` \err -> do- reportSMDoc "mimer.assignMeta" 30 $ vcat- [ "Got error from assignV:" <+> prettyTCM err- , nest 2 $ vcat- [ "when trying to assign" <+> prettyTCM term- , "to" <+> prettyTCM metaId <+> ":" <+> prettyTCM metaType- , "in context" <+> (inTopContext . prettyTCM =<< getContextTelescope)- ]- ]-- let newMetaIds = Map.keys (openMetas newMetaStore)- return newMetaIds--dumbUnifier :: Type -> Type -> SM Bool-dumbUnifier t1 t2 = isNothing <$> dumbUnifierErr t1 t2--dumbUnifierErr :: Type -> Type -> SM (Maybe TCErr)-dumbUnifierErr t1 t2 = bench [Bench.UnifyIndices] $ do- updateStat incTypeEqChecks- noConstraints (Nothing <$ equalType t2 t1) `catchError` \err -> do- reportSDoc "mimer.unify" 80 $ sep [ "Unification failed with error:", nest 2 $ prettyTCM err ]- return $ Just err---- Duplicate of a local definition in Agda.Interaction.BasicOps-showTCM :: (MonadPretty tcm, PrettyTCM a) => a -> tcm String-showTCM v = P.render <$> prettyTCM v--bench :: NFData a => [Bench.Phase] -> SM a -> SM a-bench k ma = billTo (mimerAccount : k) ma- where- -- Dummy account to avoid updating Bench. Doesn't matter since this is only used interactively- -- to debug Mimer performance.- mimerAccount = Bench.Sort---- Local variables:--- getContext :: MonadTCEnv m => m [Dom (Name, Type)]--- getContextArgs :: (Applicative m, MonadTCEnv m) => m Args--- getContextTelescope :: (Applicative m, MonadTCEnv m) => m Telescope--- getContextTerms :: (Applicative m, MonadTCEnv m) => m [Term]-getLocalVars :: Int -> Cost -> TCM [Component]-getLocalVars localCxt cost = do- typedTerms <- getLocalVarTerms localCxt- let varZeroDiscount (Var 0 []) = 1- varZeroDiscount _ = 0- mapM (\(term, domTyp) -> newComponent [] (cost - varZeroDiscount term) noName 0 term (unDom domTyp)) typedTerms--getLocalVarTerms :: Int -> TCM [(Term, Dom Type)]-getLocalVarTerms localCxt = do- contextTerms <- getContextTerms- contextTypes <- flattenTel <$> getContextTelescope- let inScope i _ | i < localCxt = pure True -- Ignore scope for variables we inserted ourselves- inScope _ Dom{ unDom = name } = do- x <- abstractToConcrete_ name- pure $ C.isInScope x == C.InScope- scope <- mapM (uncurry inScope) =<< getContextVars- return [ e | (True, e) <- zip scope $ zip contextTerms contextTypes ]----prettyBranch :: SearchBranch -> SM String-prettyBranch branch = withBranchState branch $ do- metaId <- asks searchTopMeta- P.render <$> "Branch" <> braces (sep $ punctuate ","- [ "cost:" <+> pretty (sbCost branch)- , "metas:" <+> prettyTCM (map goalMeta (sbGoals branch))- , sep [ "instantiation:"- , nest 2 $ pretty metaId <+> "=" <+> (prettyTCM =<< getMetaInstantiation metaId) ]- , "used components:" <+> pretty (Map.toList $ sbComponentsUsed branch)- ])---instance Pretty Goal where- pretty goal = P.pretty $ goalMeta goal--instance Pretty SearchBranch where- pretty branch = keyValueList- [ ("sbTCState", "[...]")- , ("sbGoals", P.pretty $ sbGoals branch)- , ("sbCost", P.pretty $ sbCost branch)- , ("sbComponentsUsed", P.pretty $ sbComponentsUsed branch)- ]---instance PrettyTCM BaseComponents where- prettyTCM comps = do- let thisFn = case hintThisFn comps of- Nothing -> "(nothing)"- Just comp -> prettyComp comp- vcat [ "Base components:"- , nest 2 $ vcat- [ f "hintFns" (hintFns comps)- , f "hintDataTypes" (hintDataTypes comps)- , f "hintRecordTypes" (hintRecordTypes comps)- , f "hintAxioms" (hintAxioms comps)- , f "hintLevel" (hintLevel comps)- , f "hintProjections" (hintProjections comps)- , "hintThisFn:" <+> thisFn- , g prettyOpenComp "hintLetVars" (hintLetVars comps)- , "hintRecVars: Open" <+> pretty (mapSnd unNoSubst <$> openThing (hintRecVars comps))- , "hintSplitVars: Open" <+> pretty (openThing $ hintSplitVars comps)- ]- ]- where- prettyComp comp = pretty (compTerm comp) <+> ":" <+> pretty (compType comp)- prettyOpenComp openComp = "Open" <+> parens (prettyComp $ openThing openComp)- prettyTCMComp comp = prettyTCM (compTerm comp) <+> ":" <+> prettyTCM (compType comp)- f = g prettyTCMComp- g p n [] = n <> ": []"- g p n xs = (n <> ":") $+$ nest 2 (vcat $ map p xs)----- -- TODO: Is it possible to derive the pretty instances?-instance Pretty BaseComponents where- pretty comps = P.vcat- [ f "hintFns" (hintFns comps)- , f "hintDataTypes" (hintDataTypes comps)- , f "hintRecordTypes" (hintRecordTypes comps)- , f "hintAxioms" (hintAxioms comps)- , f "hintLevel" (hintLevel comps)- , f "hintProjections" (hintProjections comps)- ]- where- f n [] = n P.<> ": []"- f n xs = (n P.<> ":") P.$$ P.nest 2 (P.pretty xs)--instance Pretty SearchOptions where- pretty opts = P.vcat- [ "searchBaseComponents:"- , P.nest 2 $ P.pretty $ searchBaseComponents opts- , keyValueList- [ ("searchHintMode", P.pretty $ searchHintMode opts)- , ("searchTimeout", P.pretty $ searchTimeout opts)- , ("searchTopMeta", P.pretty $ searchTopMeta opts)- , ("searchTopEnv", "[...]")- ]- , "searchCosts:"- , P.nest 2 (P.pretty $ searchCosts opts)- ]--instance PrettyTCM SearchOptions where- prettyTCM opts = vcat- [ "searchBaseComponents:"- , nest 2 $ prettyTCM $ searchBaseComponents opts- , vcat- [ "searchHintMode:" <+> pretty (searchHintMode opts)- , "searchTimeout:" <+> pretty (searchTimeout opts)- , "searchTopMeta:" <+> prettyTCM (searchTopMeta opts)- , "searchTopEnv: [...]"- , "searchTopCheckpoint:" <+> prettyTCM (searchTopCheckpoint opts)- , "searchInteractionId:" <+> pretty (searchInteractionId opts)- , "searchFnName:" <+> pretty (searchFnName opts)- , "searchStats: [...]"- ]- , "searchCosts:"- , nest 2 $ pretty $ searchCosts opts- ]--instance Pretty Component where- pretty comp = haskellRecord "Component"- [ ("compId", P.pretty $ compId comp)- , ("compTerm", P.pretty $ compTerm comp)- , ("compType", P.pretty $ compType comp)- , ("compMetas", P.pretty $ compMetas comp)- , ("compCost", P.pretty $ compCost comp)- ]--instance Pretty Costs where- pretty costs = P.align 20 entries- where- entries =- [ ("costLocal:" , P.pretty $ costLocal costs)- , ("costFn:" , P.pretty $ costFn costs)- , ("costDataCon:" , P.pretty $ costDataCon costs)- , ("costRecordCon:" , P.pretty $ costRecordCon costs)- , ("costSpeculateProj:" , P.pretty $ costSpeculateProj costs)- , ("costProj:" , P.pretty $ costProj costs)- , ("costAxiom:" , P.pretty $ costAxiom costs)- , ("costLet:" , P.pretty $ costLet costs)- , ("costLevel:" , P.pretty $ costLevel costs)- , ("costSet:" , P.pretty $ costSet costs)- , ("costRecCall:" , P.pretty $ costRecCall costs)- , ("costNewMeta:" , P.pretty $ costNewMeta costs)- , ("costNewHiddenMeta:" , P.pretty $ costNewHiddenMeta costs)- , ("costCompReuse:" , "{function}")- ]--instance PrettyTCM Component where- prettyTCM Component{..} = parens (prettyTCM compId) <+> sep- [ sep [ prettyTCM compTerm- , ":" <+> prettyTCM compType ]- , parens $ fsep $ punctuate ","- [ "cost:" <+> prettyTCM compCost- , "metas:" <+> prettyTCM compMetas- ]- ]--instance PrettyTCM MimerResult where- prettyTCM = \case- MimerExpr expr -> pretty expr- MimerClauses f cl -> "MimerClauses" <+> pretty f <+> "[..]" -- TODO: display the clauses- MimerNoResult -> "MimerNoResult"- MimerList sols -> "MimerList" <+> pretty sols--concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]-concatMapM f = fmap concat . mapM f--reportSMDoc :: VerboseKey -> VerboseLevel -> SM Doc -> SM ()-reportSMDoc vk vl md = reportSDoc vk vl . runReaderT md =<< ask--mimerTrace :: Int -> VerboseLevel -> SM Doc -> SM ()-mimerTrace ilvl vlvl doc = reportSMDoc "mimer.trace" vlvl $ nest (2 * ilvl) $ "-" <+> doc--haskellRecord :: Doc -> [(Doc, Doc)] -> Doc-haskellRecord name fields = P.sep [ name, P.nest 2 $ P.braces (P.sep $ P.punctuate "," [ P.hang (k P.<+> "=") 2 v | (k, v) <- fields ]) ]--keyValueList :: [(Doc, Doc)] -> Doc-keyValueList kvs = P.braces $ P.sep $ P.punctuate "," [ P.hang (k P.<> ":") 2 v | (k, v) <- kvs ]--writeTime :: (ReadTCState m, MonadError TCErr m, MonadTCM m, MonadDebug m) => InteractionId -> Maybe CPUTime -> m ()-writeTime ii mTime = do- let time = case mTime of- Nothing -> "n/a"- Just (CPUTime t) -> show t- file <- rangeFile . ipRange <$> lookupInteractionPoint ii- case file of- SMaybe.Nothing ->- reportSLn "mimer.stats" 2 "No file found for interaction id"- SMaybe.Just file -> do- let path = filePath (rangeFilePath file) ++ ".stats"- liftIO $ appendFile path (show (interactionId ii) ++ " " ++ time ++ "\n")---- Hack to let you experiment with costs using verbosity flags.-customCosts :: TCM Costs-customCosts = do- costLocal <- cost "local"- costFn <- cost "fn"- costDataCon <- cost "dataCon"- costRecordCon <- cost "recordCon"- costSpeculateProj <- cost "speculateProj"- costProj <- cost "proj"- costAxiom <- cost "axiom"- costLet <- cost "let"- costLevel <- cost "level"- costSet <- cost "set"- costRecCall <- cost "recCall"- costNewMeta <- cost "newMeta"- costNewHiddenMeta <- cost "newHiddenMeta"- compReuse <- cost "compReuse"- let costCompReuse uses = compReuse * uses ^ 2- pure Costs{..}- where- cost key = getVerbosityLevel ("mimer-cost." ++ key)--getVerbosityLevel :: MonadDebug m => VerboseKey -> m VerboseLevel-getVerbosityLevel k = do- t <- getVerbosity- return $ case t of- Strict.Nothing -> 1- Strict.Just t- | t == Trie.singleton [] 0 -> 0- | otherwise -> lastWithDefault 0 $ Trie.lookupPath ks t- where ks = parseVerboseKey k+import Control.Monad+import Control.Monad.Except (catchError)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (ReaderT(..), runReaderT, asks, ask, lift)+import Data.Functor ((<&>))+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Maybe (maybeToList)+import Data.PQueue.Min (MinQueue)+import qualified Data.PQueue.Min as Q++import qualified Agda.Benchmarking as Bench+import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty qualified as P+import Agda.Syntax.Info (pattern UnificationMeta)+import Agda.Syntax.Internal+import Agda.Syntax.Position (Range, noRange)+import Agda.Syntax.Translation.InternalToAbstract (reify, blankNotInScope)++import Agda.TypeChecking.CheckInternal ( checkInternal )+import Agda.TypeChecking.Empty (isEmptyType)+import Agda.TypeChecking.Level (levelType)+import Agda.TypeChecking.MetaVars (newValueMeta)+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Reduce (reduce, instantiateFull, instantiate)+import Agda.TypeChecking.Rules.Term (makeAbsurdLambda)+import Agda.TypeChecking.Substitute (apply)++import Agda.Interaction.Options ( optDoubleCheck )++import Agda.Utils.Impossible (__IMPOSSIBLE__)+import Agda.Utils.Maybe (catMaybes)+import Agda.Utils.Monad (concatMapM, ifM, whenM)+import Agda.Utils.Null+import Agda.Utils.Singleton+import Agda.Utils.Tuple (first, second)+import Agda.Utils.Time (measureTime, getCPUTime, fromMilliseconds)++import Data.IORef (readIORef)++import Agda.Interaction.Base (Rewrite(..))+import Agda.Interaction.BasicOps (normalForm)++import Agda.Mimer.Types (MimerResult(..), BaseComponents(..), Component(..), RecCall(..),+ SearchBranch(..), SearchStepResult(..), SearchOptions(..),+ Goal(..), Costs(..), goalMeta, deleteCompMeta,+ incRefineFail, incRefineSuccess, incCompRegen, incCompNoRegen,+ nextGoal, addCost, isNoResult)+import Agda.Mimer.Monad+import Agda.Mimer.Options++-- IDEA for implementing case-splitting:+-- 1. Modify the collectRecVarCandidates to get all variables.+-- 2. Go through all variables to see if they are data types (not records)+-- 3. Run makeCase for those variables.+-- 4. Find out how to get the new interaction points/metas from the cases+-- 5. After search is done, compute out-of-scope variables.+-- 6. Run make-case again to introduce those variables.+-- 7. Redo the reification in the new clauses.+-- 8. Return the new clauses and follow Auto for insertion.++-- | Entry point.+-- Run Mimer on the given interaction point, returning the desired solution(s).+-- Also debug prints timing statistics.+mimer :: MonadTCM tcm+ => Rewrite -- ^ Degree of normalization of solution terms.+ -> InteractionId -- ^ Hole to run on.+ -> Range -- ^ Range of hole (for parse errors).+ -> String -- ^ Content of hole (to parametrize Mimer).+ -> tcm MimerResult+mimer norm ii rng argStr = liftTCM $ do+ reportSDoc "mimer.top" 10 do+ "Running Mimer on interaction point" <+> pretty ii <+> "with argument string" <+> text (show argStr)++ (sol, time) <- measureTime $ do++ opts <- parseOptions ii rng argStr+ reportS "mimer.top" 60 ("Mimer options: " ++ show opts)++ sols <- localTCState $ runSearch norm opts ii rng++ -- Turn the solutions into the desired results (first solution or list of solutions).+ case drop (optSkip opts) $ zip [0..] sols of+ [] -> do+ reportSLn "mimer.top" 10 "No solution found"+ return MimerNoResult+ sols' | optList opts -> pure $ MimerList [ (i, s) | (i, MimerExpr s) <- sols' ]+ (_, sol) : _ -> do+ reportSDoc "mimer.top" 10 $ "Solution:" <+> prettyTCM sol+ return sol++ -- Print timing statistic.+ reportSDoc "mimer.top" 10 ("Total elapsed time:" <+> pretty time)+ when (not $ isNoResult sol) $+ verboseS "mimer.stats" 50 $ writeTime ii time++ return sol+++-- Order to try things in:+-- 1. Local variables (including let-bound)+-- 2. Data constructors+-- 3. Where clauses+-- 4. Lambda abstract+-- Other: Equality, empty type, record projections+-- - If we only use constructors if the target type is a data type, we might+-- generate η-reducible expressions, e.g. λ xs → _∷_ 0 xs+++------------------------------------------------------------------------------+-- * Core algorithm+------------------------------------------------------------------------------++runSearch :: Rewrite -> Options -> InteractionId -> Range -> TCM [MimerResult]+runSearch norm options ii rng = withInteractionId ii $ do+ metaId <- lookupInteractionId ii+ metaVar <- lookupLocalMeta metaId++ -- We want to be able to solve with recursive calls+ setMetaOccursCheck metaId DontRunMetaOccursCheck++ metaIds <- case mvInstantiation metaVar of+ InstV inst -> do++ metaIds <- allOpenMetas (instBody inst)++ -- TODO: Make pretty instantiation for 'Instantiation'?+ reportSDoc "mimer.init" 20 $ sep [ "Interaction point already instantiated:" <+> pretty (instBody inst)+ , "with args" <+> pretty (instTel inst) ]++ -- ctx <- getContextTelescope+ -- #7402: still solve the top-level meta, because we don't have the correct contexts for the+ -- submetas+ return [metaId | not $ null metaIds]+ OpenMeta UnificationMeta -> do+ reportSLn "mimer.init" 20 "Interaction point not instantiated."+ return [metaId]+ _ -> __IMPOSSIBLE__+ -- TODO: Print each meta-variable's full context telescope+ reportSDoc "mimer.init" 20 $ "Remaining meta-variables to solve:" <+> prettyTCM metaIds+ reportSDoc "mimer.init" 20 $ "Meta var args" <+> (prettyTCM =<< getMetaContextArgs metaVar)+++ fnArgs1 <- withShowAllArguments' False $ getContextArgs >>= mapM prettyTCM+ fnArgs2 <- withShowAllArguments' True $ getContextArgs >>= mapM prettyTCM+ let bringScope = map snd $ filter (uncurry (/=)) $ zip fnArgs1 fnArgs2+ bringScopeNoBraces = map (filter (`notElem` ['{', '}']) . P.render) bringScope+ reportSDoc "mimer.temp" 20 $ vcat+ [ "Things to bring into scope:"+ , nest 2 $ vcat+ [ "Context args (don't show):" <+> pretty fnArgs1+ , "Context args (show all): " <+> pretty fnArgs2+ , "To bring into scope: " <+> pretty bringScope+ , "To bring into scope (str):" <+> pretty bringScopeNoBraces+ ]+ ]++ -- Check if there are any meta-variables to be solved+ case metaIds of+ -- No variables to solve, return the instantiation given+ [] -> do+ case mvInstantiation metaVar of+ InstV inst -> do+ expr <- withInteractionId ii $ do+ metaArgs <- getMetaContextArgs metaVar+ instantiateFull (apply (MetaV metaId []) metaArgs) >>= normalForm norm >>= reify+ str <- P.render <$> prettyTCM expr+ let sol = MimerExpr str+ reportSDoc "mimer.init" 10 $ "Goal already solved. Solution:" <+> text str+ return [sol]+ _ -> __IMPOSSIBLE__+ _ -> do+ searchOptions <- makeSearchOptions norm options ii+ -- Caution: startSearchBranch puts the current TCState in the branch, which includes+ -- the freshId counter for components, that gets bumped in makeSearchOptions+ -- above (computing the initial components), so it's important to not switch+ -- these two calls around.+ startBranch <- startSearchBranch metaIds++ reportSDoc "mimer.init" 20 $ "Using search options:" $$ nest 2 (prettyTCM searchOptions)+ reportSDoc "mimer.init" 20 $ "Initial search branch:" $$ nest 2 (pretty startBranch)++ flip runReaderT searchOptions $ bench [] $ do++ -- TODO: Check what timing stuff is used in Agda.Utils.Time+ timeout <- fromMilliseconds <$> asks searchTimeout+ startTime <- liftIO getCPUTime+ let go :: Int -> Int -> MinQueue SearchBranch -> SM ([MimerResult], Int)+ go 0 n _ = pure ([], n)+ go need n branchQueue = case Q.minView branchQueue of+ Nothing -> do+ reportSLn "mimer.search" 30 $ "No remaining search branches."+ return ([], n)+ Just (branch, branchQueue') -> do+ time <- liftIO getCPUTime+ mimerTrace 0 10 $ vcat+ [ "Choosing branch"+ , nest 2 $ sep+ [ branchInstantiationDocCost branch <> ","+ , nest 2 $ "metas:" <+> prettyTCM (map goalMeta $ sbGoals branch)+ ]+ ]+ reportSDoc "mimer.search" 50 $ "Full branch:" <+> pretty branch+ reportSMDoc "mimer.search" 50 $+ "Instantiation of other branches:" <+> prettyList (map branchInstantiationDocCost $ Q.toAscList branchQueue')++ let elapsed = time - startTime+ if elapsed < timeout+ then do+ stepResults <- refine branch+ reportSLn "mimer.search" 45 "partitionStepResult"+ (newBranches, sols) <- partitionStepResult stepResults+ let branchQueue'' = foldr Q.insert branchQueue' newBranches+ reportSLn "mimer.search" 40 $ show (length sols) ++ " solutions found during cycle " ++ show (n + 1)+ reportSMDoc "mimer.search" 45 $ "Solutions:" <+> prettyTCM sols+ mimerTrace 0 40 $ vcat+ [ "Cycle" <+> pretty (n + 1) <+> "branches"+ , nest 2 $ vcat $ map branchInstantiationDocCost $ Q.toAscList branchQueue''+ ]+ unless (null sols) $ mimerTrace 0 20 $ vcat+ [ "Cycle" <+> pretty (n + 1) <+> "solutions"+ , nest 2 $ vcat $ map prettyTCM sols+ ]++ let sols' = take need sols+ first (sols' ++) <$> go (need - length sols') (n + 1) branchQueue''+ else do+ reportSLn "mimer.search" 30 $ "Search time limit reached. Elapsed search time: " ++ show elapsed+ return ([], n)+ let numSolutions | optList options = 10 + optSkip options+ | otherwise = 1 + optSkip options+ (sols, nrSteps) <- go numSolutions 0 $ Q.singleton startBranch+ reportSLn "mimer.search" 20 $ "Search ended after " ++ show (nrSteps + 1) ++ " cycles"+ -- results <- liftTCM $ mapM exprToStringAndVars sols+ reportSDoc "mimer.search" 15 $ "Solutions found: " <+> prettyList (map prettyTCM sols)+ reportSMDoc "mimer.stats" 10 $ do+ ref <- asks searchStats+ stats <- liftIO $ readIORef ref+ "Statistics:" <+> text (show stats)+ return sols++-- | If there is no cache entry for the checkpoint, create one. If there already+-- is one, even if the components are not yet generated for some entries, it is+-- returned as is.+prepareComponents :: Goal -> SearchBranch -> SM (SearchBranch, [(Component, [Component])])+prepareComponents goal branch = withBranchAndGoal branch goal $ do+ reportSDoc "mimer.components" 50 $ "Preparing components for goal" <+> prettyTCM (goalMeta goal)+ checkpoint <- viewTC eCurrentCheckpoint+ -- Check if we there is something in the cache for this checkpoint+ comps <- case Map.lookup checkpoint (sbCache branch) of+ -- No, generate components from scratch+ Nothing -> do+ updateStat incCompRegen+ reportSDoc "mimer.components" 20 $ vcat+ [ "No cache found checkpoint:" <+> pretty checkpoint+ , nest 2 $ "with context:" <+> (inTopContext . prettyTCM =<< getContextTelescope) ]+ -- Generate components for this context+ comps <- genComponents+ reportSDoc "mimer.components" 20 $ "Generated" <+> pretty (sum $ map (length . snd) comps) <+> "components"+ whenM (optDoubleCheck <$> pragmaOptions) $+ mapM_ checkInternalComponent $ concatMap (\(x,xs) -> x:xs) comps+ return comps+ -- Yes, just update the missing generated components+ Just cache -> mapM prepare (Map.toAscList cache)+ let newCache = Map.fromList $ map (second Just) comps+ branch' <- updateBranch [] branch{sbCache = Map.insert checkpoint newCache (sbCache branch)}+ return (branch', comps)+ where+ prepare :: (Component, Maybe [Component]) -> SM (Component, [Component])+ prepare (sourceComp, Just comps) = do+ updateStat incCompNoRegen+ return (sourceComp, comps)+ prepare (sourceComp, Nothing) = do+ updateStat incCompRegen+ (sourceComp,) <$> genComponentsFrom True sourceComp++checkInternalComponent :: Component -> SM ()+checkInternalComponent comp = do+ reportSDoc "mimer.components" 40 $ "double-checking component" <+> prettyTCM comp+ lift $ checkInternal (compTerm comp) CmpLeq (compType comp)++genComponents :: SM [(Component, [Component])]+genComponents = do+ opts <- ask+ let comps = searchBaseComponents opts+ n <- localVarCount+ reportSDoc "mimer.components" 20 $ "Generating components"+ localVars <- lift (getLocalVars n (costLocal $ searchCosts opts))+ >>= genAddSource (searchGenProjectionsLocal opts)+ reportSDoc "mimer.components" 25 $ " localVars = " <+> pretty localVars+ recCalls <- genAddSource (searchGenProjectionsRec opts) (maybeToList (hintThisFn comps) ++ hintMutualFns comps)+ reportSDoc "mimer.components" 25 $ " recCalls = " <+> pretty recCalls+ letVars <- mapM getOpenComponent (hintLetVars comps)+ >>= genAddSource (searchGenProjectionsLet opts)+ reportSDoc "mimer.components" 25 $ " letVars = " <+> pretty letVars+ fns <- genAddSource (searchGenProjectionsExternal opts) (hintFns comps)+ reportSDoc "mimer.components" 25 $ " fns = " <+> pretty fns+ axioms <- genAddSource (searchGenProjectionsExternal opts) (hintAxioms comps)+ reportSDoc "mimer.components" 25 $ " axioms = " <+> pretty axioms+ return $ localVars ++ letVars ++ recCalls ++ fns ++ axioms+ where+ genAddSource :: Bool -> [Component] -> SM [(Component, [Component])]+ genAddSource genProj = mapM (\comp -> (comp,) <$> genComponentsFrom genProj comp)+++genComponentsFrom :: Bool -- ^ Apply record elimination+ -> Component+ -> SM [Component]+genComponentsFrom appRecElims origComp = do+ reportSDoc "mimer.components" 50 $ "Generating components from original component" <+> prettyTCM (compId origComp) <+> prettyTCM (compName origComp)+ comps <- if | compRec origComp /= NotRecCall+ -> mapM (applyToMetasG Nothing) =<< genRecCalls origComp+ | otherwise+ -> singleton <$> applyToMetasG Nothing origComp+ if appRecElims+ then concat <$> mapM (applyProjections Set.empty) comps+ else return comps+ where+ applyProjections :: Set QName -> Component -> SM [Component]+ applyProjections seenRecords comp = do+ projComps <- getRecordInfo (compType comp) >>= \case+ Nothing -> return []+ Just (recordName, args, fields, isRecursive)+ | Set.member recordName seenRecords -> do+ reportSDoc "mimer.components" 60 $+ "Skipping projection because recursive record already seen:" <+> pretty recordName+ return []+ | otherwise -> do+ let seenRecords' = if isRecursive then Set.insert recordName seenRecords else seenRecords+ comps <- mapM (applyProj args comp >=> applyToMetasG Nothing) fields+ concatMapM (applyProjections seenRecords') comps+ return $ comp : projComps++genRecCalls :: Component -> SM [Component]+genRecCalls thisFn = do+ reportSDoc "mimer.components.open" 40 $ "Generating recursive calls for component" <+> prettyTCM (compId thisFn) <+> prettyTCM (compName thisFn)+ reportSDoc "mimer.components.open" 60 $ " checkpoint =" <+> (prettyTCM =<< viewTC eCurrentCheckpoint)+ -- TODO: Make sure there are no pruning problems+ rv <- asks (hintRecVars . searchBaseComponents)+ reportSDoc "mimer.components" 40 $ " rv = " <+> pretty (fmap (map fst) rv)+ getOpen rv >>= \case+ [] -> do+ reportSDoc "mimer.components" 40 $ "No candidate arguments for a recursive call"+ return []+ recCandTerms -> do+ reportSDoc "mimer.components" 45 $ " recCandTerms = " <+> pretty (map fst recCandTerms)+ Costs{ costLocal, costNewMeta, costNewHiddenMeta } <- asks searchCosts+ n <- localVarCount+ localVars <- lift $ getLocalVars n costLocal+ let recCands = [ (t, i) | t@(compTerm -> v@Var{}) <- localVars, NoSubst i <- maybeToList $ lookup v recCandTerms ]++ -- For a mutual call, argument positions need not correspond (#8783).+ let isMutualCall = compRec thisFn == MutualCall+ samePos i j = isMutualCall || i == j++ newRecCall = do+ -- Apply the recursive call to new metas+ (thisFnTerm, thisFnType, newMetas) <- lift $ applyToMetas 0 (compTerm thisFn) (compType thisFn)+ let argGoals = map Goal newMetas+ comp <- newComponent newMetas (compCost thisFn) (compName thisFn) 0 thisFnTerm thisFnType+ return (comp, zip argGoals [0..])++ -- go :: Component -- ^ Recursive call function applied to meta-variables+ -- -> [(Goal, Int)] -- ^ Remaining parameters to try to fill+ -- -> [(Component, Int)] -- ^ Remaining argument candidates for the current parameter+ -- -> SM [Component]+ go _thisFn [] _args = return []+ go thisFn (_ : goals) [] = go thisFn goals recCands+ go thisFn ((goal, i) : goals) ((arg, j) : args) | samePos i j = do+ reportSMDoc "mimer.components.rec" 80 $ hsep+ [ "Trying to generate recursive call"+ , prettyTCM (compTerm thisFn)+ , "with" <+> prettyTCM (compTerm arg)+ , "for" <+> prettyTCM (goalMeta goal) ]+ goalType <- getMetaTypeInContext (goalMeta goal)+ state <- getTC+ ifM (tryRefineWith' goal goalType arg)+ (do+ let newComp = deleteCompMeta (goalMeta goal) thisFn+ (thisFn', goals') <- newRecCall+ (newComp:) <$> go thisFn' (drop (length goals' - length goals - 1) goals') args)+ (do+ putTC state+ go thisFn ((goal, i) : goals) args)+ go thisFn goals (_ : args) = go thisFn goals args+ (thisFn', argGoals) <- newRecCall+ comps <- go thisFn' argGoals recCands+ reportSDoc "mimer.components" 45 $ " comps = " <+> pretty comps+ -- Compute costs for the calls:+ -- - costNewMeta/costNewHiddenMeta for each unsolved argument+ -- - zero for solved arguments+ -- - costLocal for the parameter we recurse on+ let callCost comp = (costLocal +) . sum <$> argCosts (compTerm comp)+ argCosts (Def _ elims) = mapM argCost elims+ argCosts _ = __IMPOSSIBLE__+ argCost (Apply arg) = instantiate arg <&> \ case+ Arg h MetaV{} | visible h -> costNewMeta+ | otherwise -> costNewHiddenMeta+ _ -> 0+ argCost Proj{} = pure 0+ argCost IApply{} = pure 0+ mapM (\ c -> (`addCost` c) <$> callCost c) comps+++refine :: SearchBranch -> SM [SearchStepResult]+refine branch = withBranchState branch $ do+ let (goal1, branch1) = nextGoal branch++ withBranchAndGoal branch1 goal1 $ do+ goalType1 <- bench [Bench.Reduce] $ reduce =<< getMetaTypeInContext (goalMeta goal1)++ mimerTrace 1 10 $ sep+ [ "Refining goal"+ , nest 2 $ prettyTCM (goalMeta goal1) <+> ":" <+> prettyTCM goalType1+ , nest 2 $ "in context" <+> (inTopContext . prettyTCM =<< getContextTelescope)+ ]++ reportSDoc "mimer.refine" 30 $ "Goal type:" <+> pretty goalType1+ reportSDoc "mimer.refine" 30 $ "Goal context:" <+> (pretty =<< getContextTelescope)++ -- Lambda-abstract as far as possible.+ -- Assigning the goal can wake up postponed constraints, which may fail;+ -- then the branch is dead (rather than the whole search).+ tryLamAbs' goal1 goalType1 branch1 >>= \case+ Nothing -> return []+ -- Absurd lambda+ Just (Left branch2) -> do+ mimerTrace 1 10 $ sep+ [ "Absurd lambda refinement", nest 2 $ prettyGoalInst goal1 ]+ args <- map Apply <$> getContextArgs+ e <- blankNotInScope =<< reify (MetaV (goalMeta goal1) args)+ return [ResultExpr e]+ -- Normal abstraction+ Just (Right (goal2, goalType2, branch2)) -> withBranchAndGoal branch2 goal2 $ do+ (branch3, components) <- prepareComponents goal2 branch2+ withBranchAndGoal branch3 goal2 $ do++ when (goalMeta goal2 /= goalMeta goal1) $ do+ mimerTrace 1 10 $ sep+ [ "Lambda refinement", nest 2 $ prettyGoalInst goal1 ]+ mimerTrace 1 10 $ sep+ [ "Refining goal"+ , nest 2 $ prettyTCM (goalMeta goal2) <+> ":" <+> prettyTCM goalType2+ , nest 2 $ "in context" <+> (inTopContext . prettyTCM =<< getContextTelescope)+ ]++ mimerTrace 2 40 $ vcat+ [ "Components:"+ , nest 2 $ vcat $ map prettyTCM $ concatMap snd components+ ]++ results1 <- tryComponents goal2 goalType2 branch3 components+ results2 <- tryDataRecord goal2 goalType2 branch3+ return $ results1 ++ results2++tryComponents :: Goal -> Type -> SearchBranch -> [(Component, [Component])] -> SM [SearchStepResult]+tryComponents goal goalType branch comps = withBranchAndGoal branch goal $ do+ reportSLn "mimer.search" 45 "tryComponents"+ checkpoint <- viewTC eCurrentCheckpoint+ let tryFor (sourceComp, comps') = do+ -- Clear out components that depend on meta-variables that have been used.+ let newCache = Map.insert sourceComp Nothing (sbCache branch Map.! checkpoint)+ newBranches <- catMaybes <$> mapM (tryRefineWith goal goalType branch) comps'+ return $ map (\br -> br{sbCache = Map.insert checkpoint newCache (sbCache branch)}) newBranches+ newBranches <- concatMapM tryFor comps+ mapM checkSolved newBranches++-- | Like 'tryLamAbs', but returns @Nothing@ if lambda abstraction fails,+-- e.g. because the assignment woke up a postponed constraint that turned out to be unsolvable.+tryLamAbs' :: Goal -> Type -> SearchBranch -> SM (Maybe (Either SearchBranch (Goal, Type, SearchBranch)))+tryLamAbs' goal goalType branch =+ (Just <$> tryLamAbs goal goalType branch) `catchError` \ err -> do+ mimerTrace 1 10 $ vcat+ [ "Failed lambda abstraction for goal" <+> prettyTCM (goalMeta goal)+ , nest 2 $ prettyTCM err ]+ return Nothing++-- | Returns @Right@ for normal lambda abstraction and @Left@ for absurd lambda.+tryLamAbs :: Goal -> Type -> SearchBranch -> SM (Either SearchBranch (Goal, Type, SearchBranch))+tryLamAbs goal goalType branch =+ case unEl goalType of+ Pi dom abs -> isEmptyType dom >>= \case+ True -> do+ reportSDoc "mimer.lam" 40 $ "Trying absurd lambda for pi type" <+> prettyTCM goalType+ f <- liftTCM $ makeAbsurdLambda noRange dom abs+ args <- map Apply <$> getContextArgs+ -- TODO: what happens when assignMeta fails?+ assignMeta (goalMeta goal) (Def f args) goalType+ return $ Left branch+ False -> do+ reportSDoc "mimer.lam" 40 $ "Trying lambda abstraction for pi type" <+> prettyTCM goalType+ let abs' | isNoName (absName abs) = abs { absName = "z" }+ | otherwise = abs+ (metaId', bodyType, metaTerm, env) <- underAbstractionAbs dom abs' $ \bodyType -> do+ reportSDoc "mimer.lam" 40 $ " bodyType = " <+> prettyTCM bodyType+ bodyType <- bench [Bench.Reduce] $ reduce bodyType -- TODO: Good place to reduce?+ reportSDoc "mimer.lam" 40 $ " bodyType (reduced) = " <+> prettyTCM bodyType+ (metaId', metaTerm) <- bench [Bench.Free] $ lift $ newValueMeta DontRunMetaOccursCheck CmpLeq bodyType+ reportSDoc "mimer.lam" 40 $ " metaId' = " <+> prettyTCM metaId'+ env <- askTC+ return (metaId', bodyType, metaTerm, env)++ let argInf = domInfo dom -- TODO: is this the correct arg info?+ newAbs = Abs (absName abs') metaTerm+ -- look at mkLam+ term = Lam argInf newAbs++ assignMeta (goalMeta goal) term goalType++ withEnv env $ tryLamAbs (Goal metaId') bodyType branch+ _ -> done+ where+ done = do+ branch' <- updateBranch [] branch -- TODO: Is this necessary?+ return $ Right (goal, goalType, branch')++-- TODO: Factor out `checkSolved`+tryDataRecord :: Goal -> Type -> SearchBranch -> SM [SearchStepResult]+tryDataRecord goal goalType branch = withBranchAndGoal branch goal $ do+ -- TODO: There is a `isRecord` function, which performs a similar case+ -- analysis as here, but it does not work for data types.+ case unEl goalType of+ Def qname elims -> theDef <$> getConstInfo qname >>= \case+ recordDefn@Record{} -> do+ tryRecord recordDefn+ dataDefn@Datatype{} -> do+ tryData dataDefn+ primitive@Primitive{} -> do+ return []+ -- TODO: Better way of checking that type is Level+ Axiom{}+ | P.prettyShow qname == "Agda.Primitive.Level" -> do+ tryLevel+ | otherwise -> do+ return []+ DataOrRecSig{} -> do+ return []+ GeneralizableVar{} -> do+ return []+ AbstractDefn{} -> do+ return []+ Function{} -> do+ return []+ Constructor{} -> do+ return []+ PrimitiveSort{} -> do+ return []+ Sort (Type level) -> do+ trySet level+ Sort sort -> do+ return []+ _ -> return []+ where+ -- TODO: Alternatively, the constructor can be accessed via `getRecordConstructor`+ -- TODO: There might be a neater way of applying the constructor to new metas+ tryRecord :: Defn -> SM [SearchStepResult]+ tryRecord recordDefn = do+ cost <- asks (costRecordCon . searchCosts) -- TODO: Use lenses for this?+ comp <- qnameToComponent cost $ conName $ recConHead recordDefn+ -- NOTE: at most 1+ newBranches <- maybeToList <$> tryRefineAddMetas goal goalType branch comp+ mapM checkSolved newBranches++ tryData :: Defn -> SM [SearchStepResult]+ tryData dataDefn = do+ let constructors = dataCons dataDefn+ reportSDoc "mimer.try" 40 $ hsep $ "tryData" : map prettyTCM constructors+ cost <- asks (costDataCon . searchCosts)+ comps <- mapM (qnameToComponent cost) constructors+ newBranches <- mapM (tryRefineAddMetas goal goalType branch) comps+ -- TODO: Reduce overlap between e.g. tryLocals, this and tryRecord+ mapM checkSolved (catMaybes newBranches)++ tryLevel :: SM [SearchStepResult]+ tryLevel = do+ levelHints <- asks (hintLevel . searchBaseComponents)+ newBranches <- catMaybes <$> mapM (tryRefineAddMetas goal goalType branch) levelHints+ mapM checkSolved newBranches++ -- TODO: Add an extra filtering on the sort+ trySet :: Level -> SM [SearchStepResult]+ trySet level = do+ reportSDoc "mimer.try" 40 $ "trySet" <+> prettyTCM level+ reducedLevel <- reduce level+ cost <- asks (costSet . searchCosts)+ setCandidates <- case reducedLevel of+ (Max i [])+ | i > 0 -> do+ comp <- newComponent [] cost Nothing 0 (Sort $ Type $ Max (i - 1) []) goalType+ return [(branch, comp)]+ | otherwise -> return []+ (Max i ps) -> do+ (metaId, metaTerm) <- createMeta =<< levelType+ comp <- newComponent [metaId] cost Nothing 0 (Sort $ Type $ Max (max 0 (i - 1)) [Plus 0 metaTerm]) goalType+ reportSDoc "mimer.lam" 45 $ " new metaId =" <+> pretty metaId+ branch' <- updateBranch [metaId] branch+ return [(branch', comp)]+ reportSDoc "mimer.refine.set" 40 $+ "Trying" <+> prettyTCM (map snd setCandidates) <+> "for" <+> prettyTCM goalType+ newBranches <- catMaybes <$> mapM (\(br,c) -> tryRefineWith goal goalType br c) setCandidates+ components <- asks searchBaseComponents+ newBranches' <- catMaybes <$> mapM (tryRefineAddMetas goal goalType branch)+ (concatMap ($ components)+ [ hintDataTypes+ , hintRecordTypes+ , hintAxioms])+ mapM checkSolved (newBranches ++ newBranches')++-- | Type should already be reduced here+-- NOTE: Does not reset the state!+-- TODO: Make sure the type is always reduced+tryRefineWith :: Goal -> Type -> SearchBranch -> Component -> SM (Maybe SearchBranch)+tryRefineWith goal goalType branch comp = withBranchAndGoal branch goal do+ reportSLn "mimer.search" 45 "tryRefineWith"+ ifM (tryRefineWith' goal goalType comp)+ -- Take the metas stored in the component and add them as sub-goals+ {-then-} (Just <$> updateBranchCost comp (compMetas comp) branch)+ {-else-} (return Nothing)++tryRefineWith' :: Goal -> Type -> Component -> SM Bool+tryRefineWith' goal goalType comp = do+ -- 2025-10-17, Jesper (#8097): the calls to dumbUnifier and assignMeta+ -- here might generate new metas (e.g. through pruning existing ones) but+ -- these do not necessarily fall under the same context as the hole we're+ -- solving so we should not consider them as new goals (lest we run into+ -- bad checkpoints later).+ dumbUnifier (compType comp) goalType+ reportSLn "mimer.search" 45 "assignMeta"+ assignMeta (goalMeta goal) (compTerm comp) goalType+ -- Postponed constraints might have been woken up by the assignment.+ solveSearchConstraints++ updateStat incRefineSuccess+ reportSMDoc "mimer.refine" 50 $ "Refinement succeeded"++ mimerTrace 2 10 $ sep+ [ "Found refinement"+ , nest 2 $ sep [ prettyTCM (compTerm comp)+ , ":" <+> prettyTCM (compType comp) ] ]+ return True+ `catchError` \err -> do+ updateStat incRefineFail+ reportSMDoc "mimer.refine" 50 $ "Refinement failed"++ mimerTrace 2 60 $ vcat+ [ "Failed refinement"+ , nest 2 $ sep [ prettyTCM (compTerm comp)+ , ":" <+> prettyTCM (compType comp) ]+ , nest 2 $ prettyTCM err ]+ return False++-- TODO: Make policy for when state should be put+tryRefineAddMetas :: Goal -> Type -> SearchBranch -> Component -> SM (Maybe SearchBranch)+tryRefineAddMetas goal goalType branch comp = withBranchAndGoal branch goal $ do+ -- Apply the hint to new metas (generating @c@, @c ?@, @c ? ?@, etc.)+ -- TODO: Where is the best place to reduce the hint type?+ comp' <- applyToMetasG Nothing comp+ branch' <- updateBranch [] branch+ tryRefineWith goal goalType branch' comp'
+ src/full/Agda/Mimer/Monad.hs view
@@ -0,0 +1,789 @@+{-# LANGUAGE RecordWildCards #-}++module Agda.Mimer.Monad where++import Control.DeepSeq (NFData(..))+import Control.Monad+import Control.Monad.Except (catchError, MonadError)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (ReaderT(..), asks, ask, lift)+import Data.Functor ( ($>) )+import Data.IORef (modifyIORef', newIORef)+import Data.Map qualified as Map+import Data.List qualified as List+import Data.List.NonEmpty qualified as NonEmptyList (head)+import Data.Maybe+import Data.Set qualified as Set++import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty qualified as P+import Agda.Syntax.Internal+import Agda.Syntax.Position (rangeFile, rangeFilePath)+import Agda.Syntax.Concrete.Name qualified as C+import Agda.Syntax.Abstract (Expr)+import Agda.Syntax.Abstract qualified as A+import Agda.Syntax.Abstract.Views qualified as A+import Agda.Syntax.Internal.MetaVars (AllMetas(..))+import Agda.Syntax.Translation.AbstractToConcrete (abstractToConcrete_)+import Agda.Syntax.Translation.InternalToAbstract (reify, blankNotInScope)+import Agda.Syntax.Scope.Base qualified as Scope+import Agda.TypeChecking.Monad+import Agda.TypeChecking.MetaVars (newValueMeta)+import Agda.TypeChecking.Primitive (getBuiltinName)+import Agda.TypeChecking.Datatypes (isDataOrRecord)+import Agda.TypeChecking.Reduce (reduce, instantiateFull, instantiate)+import Agda.TypeChecking.Records (isRecord)+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Conversion (equalType)+import Agda.TypeChecking.Telescope (flattenTel, piApplyM)+import Agda.TypeChecking.Substitute (pattern TelV, telView', piApply, apply, applyE)+import Agda.Interaction.BasicOps (normalForm)+import Agda.Interaction.Base (Rewrite(..))+import Agda.Benchmarking qualified as Bench+import Agda.Utils.Benchmark (billTo)+import Agda.Utils.Functor ((<&>), (<.>))+import Agda.Utils.FileName (filePath)+import Agda.Utils.Impossible+import Agda.Utils.Monad (ifM)+import Agda.Utils.Maybe.Strict qualified as SMaybe+import Agda.Utils.Time (CPUTime(..))++import Agda.Mimer.Options+import Agda.Mimer.Types++type SM a = ReaderT SearchOptions TCM a++------------------------------------------------------------------------+-- * Agda internals+------------------------------------------------------------------------++getRecordFields :: (HasConstInfo tcm) => QName -> tcm [QName]+getRecordFields = fmap (map unDom . recFields . theDef) . getConstInfo++getRecordInfo :: (MonadTCM tcm, HasConstInfo tcm) => Type+ -> tcm (Maybe ( QName -- Record name+ , Args -- Record parameters converted to (hidden) arguments+ , [QName] -- Field names+ , Bool -- Is recursive?+ ))+getRecordInfo typ = case unEl typ of+ Def qname elims -> isRecord qname >>= \case+ Nothing -> return Nothing+ Just defn -> do+ fields <- getRecordFields qname+ return $ Just (qname, argsFromElims elims, fields, recRecursive_ defn)+ _ -> return Nothing++allOpenMetas :: (AllMetas t, ReadTCState tcm) => t -> tcm [MetaId]+allOpenMetas t = do+ openMetas <- getOpenMetas+ return $ allMetas (:[]) t `List.intersect` openMetas++assignMeta :: MetaId -> Term -> Type -> SM ()+assignMeta metaId term metaType = bench [Bench.CheckRHS] $ do+ metaVar <- lookupLocalMeta metaId+ metaArgs <- getMetaContextArgs metaVar++ reportSMDoc "mimer.assignMeta" 60 do+ tel <- getContextTelescope+ vcat $ concat+ [ [ "Assigning" <+> pretty term ]+ , [ nest 2 $ "to" <+> pretty metaId <+> ":" <+> pretty metaType ]+ , [ nest 2 $ "in context" <+> pretty tel | not $ null tel ]+ ]++ assignV DirLeq metaId metaArgs term (AsTermsOf metaType)++getLocalVarTerms :: Int -> TCM [(Term, Dom Type)]+getLocalVarTerms localCxt = do+ contextTerms <- getContextTerms+ contextTypes <- flattenTel <$> getContextTelescope+ let inScope i _ | i < localCxt = pure True -- Ignore scope for variables we inserted ourselves+ inScope _ (unDom -> name) = do+ x <- abstractToConcrete_ name+ pure $ C.isInScope x == C.InScope+ scope <- mapM (uncurry inScope) =<< getContextVars+ return [ e | (True, e) <- zip scope $ zip contextTerms contextTypes ]++-- TODO: Rename (see metaInstantiation)+getMetaInstantiation :: (MonadTCM tcm, PureTCM tcm, MonadInteractionPoints tcm, MonadFresh NameId tcm)+ => MetaId -> tcm (Maybe Expr)+getMetaInstantiation = metaInstantiation >=> traverse (instantiateFull >=> reify)++metaInstantiation :: (MonadDebug tcm, ReadTCState tcm) => MetaId -> tcm (Maybe Term)+metaInstantiation metaId = lookupLocalMeta metaId <&> mvInstantiation >>= \case+ InstV inst -> return $ Just $ instBody inst+ _ -> return Nothing++-- TODO: why not also accept pattern record types here?+isTypeDatatype :: (MonadTCM tcm) => Type -> tcm Bool+isTypeDatatype typ = liftTCM do+ reduce typ <&> unEl >>= isDataOrRecord <&> \case+ Just (_, IsData) -> True+ _ -> False++-- | Is an element of the given type computing a level?+--+-- The returned checker is only sound but not complete because the type is taken as-is+-- rather than being reduced.+endsInLevelTester :: TCM (Type -> Bool)+endsInLevelTester = do+ getBuiltinName builtinLevel >>= \case+ Nothing -> return $ const False+ Just level -> return \ t ->+ -- NOTE: We do not reduce the type before checking, so some user definitions+ -- will not be included here.+ case telView' t of+ TelV _ (El _ (Def x _)) -> x == level+ _ -> False++-- | From the scope of the given meta variable,+-- extract all names in scope that we could use during synthesis.+-- (This excludes macros, generalizable variables, pattern synonyms.)+getEverythingInScope :: MetaVariable -> [QName]+getEverythingInScope metaVar = do+ let scope = clScope $ getMetaInfo metaVar+ let nameSpace = Scope.everythingInScope scope+ names = Scope.nsNames nameSpace+ validKind = \ case+ PatternSynName -> False -- could consider allowing pattern synonyms, but the problem is they can't be getConstInfo'd+ GeneralizeName -> False -- and any way finding the underlying constructors should be easy+ DisallowedGeneralizeName -> False+ MacroName -> False+ QuotableName -> False+ ConName -> True+ CoConName -> True+ FldName -> True+ DataName -> True+ RecName -> True+ FunName -> True+ AxiomName -> True+ PrimName -> True+ OtherDefName -> True+ qnames = map anameName+ . filter (validKind . anameKind)+ . map NonEmptyList.head+ $ Map.elems names+ qnames++-- TODO: Make sure the type is reduced the first time this is called+-- TODO: Rewrite with Component?+-- NOTE: The new metas are in left-to-right order -- the opposite of the+-- order they should be solved in.+applyToMetas :: Nat -> Term -> Type -> TCM (Term, Type, [MetaId])+applyToMetas skip term typ = do+ ctx <- getContextTelescope+ case unEl typ of+ Pi dom abs -> do+ let domainType = unDom dom+ -- TODO: What exactly does the occur check do?+ (metaId', metaTerm) <- newValueMeta DontRunMetaOccursCheck CmpLeq domainType+ let arg = setOrigin Inserted $ metaTerm <$ argFromDom dom+ newType <- reduce =<< piApplyM typ metaTerm -- TODO: Is this the best place to reduce?+ -- For records, the parameters are not included in the term+ let newTerm = if skip > 0 then term else apply term [arg]+ (term', typ', metas) <- applyToMetas (max 0 $ skip - 1) newTerm newType+ return (term', typ', metaId' : metas)+ _ -> return (term, typ, [])++------------------------------------------------------------------------+-- * Components+------------------------------------------------------------------------++localVarCount :: SM Int+localVarCount = do+ top <- asks $ length . view eContext . searchTopEnv+ cur <- length <$> getContext+ pure $ cur - top++getOpenComponent :: (MonadTCM tcm, MonadDebug tcm) => Open Component -> tcm Component+getOpenComponent openComp = do+ let comp = openThing openComp+ reportSDoc "mimer.components.open" 40 $ "Opening component" <+> prettyTCM (compId comp) <+> prettyTCM (compName comp)+ term <- getOpen $ compTerm <$> openComp+ reportSDoc "mimer.components.open" 40 $ " term = " <+> prettyTCM term+ typ <- getOpen $ compType <$> openComp+ reportSDoc "mimer.components.open" 40 $ " typ =" <+> prettyTCM typ+ when (not $ null $ compMetas comp) __IMPOSSIBLE__+ return Component+ { compId = compId comp+ , compName = compName comp+ , compPars = compPars comp+ , compTerm = term+ , compType = typ+ , compRec = compRec comp+ , compMetas = compMetas comp+ , compCost = compCost comp+ }++newComponent :: MonadFresh CompId m => [MetaId] -> Cost -> Maybe Name -> Nat -> Term -> Type -> m Component+newComponent metaIds cost mName pars term typ = fresh <&> \cId -> mkComponent cId metaIds cost mName pars term typ++newComponentQ :: MonadFresh CompId m => [MetaId] -> Cost -> QName -> Nat -> Term -> Type -> m Component+newComponentQ metaIds cost qname pars term typ = fresh <&> \cId -> mkComponent cId metaIds cost (Just $ qnameName qname) pars term typ++-- Local variables:+-- getContext :: MonadTCEnv m => m [Dom (Name, Type)]+-- getContextArgs :: (Applicative m, MonadTCEnv m) => m Args+-- getContextTelescope :: (Applicative m, MonadTCEnv m) => m Telescope+-- getContextTerms :: (Applicative m, MonadTCEnv m) => m [Term]+getLocalVars :: Int -> Cost -> TCM [Component]+getLocalVars localCxt cost = do+ typedTerms <- getLocalVarTerms localCxt+ let varZeroDiscount (Var 0 []) = 1+ varZeroDiscount _ = 0+ mapM (\(term, domTyp) -> newComponent [] (cost - varZeroDiscount term) noName 0 term (unDom domTyp)) typedTerms++-- | NOTE: Collects components from the *current* context, not the context of+-- the 'InteractionId'.+collectComponents :: Options+ -> Costs+ -> InteractionId+ -> Maybe QName+ -> [QName]+ -> MetaId+ -> TCM BaseComponents+collectComponents opts costs ii mDefName whereNames metaId = do++ reportSDoc "mimer.components" 30 $ "collectComponents"+ reportSDoc "mimer.components" 40 $ nest 2 $ vcat+ [ "ii =" <+> pretty ii+ , "mDefName =" <+> pretty mDefName+ , "whereNames =" <+> pretty whereNames+ , "metaId =" <+> pretty metaId+ ]++ lhsVars <- collectLHSVars ii+ let recVars = lhsVars <&> \ vars -> [ (tm, NoSubst i) | (tm, Just i) <- vars ]++ reportSDoc "mimer.components" 40 $ "recVars =" <+> pretty recVars++ -- Prepare the initial component record+ letVars <- getLetVars (costLet costs)+ let components = BaseComponents+ { hintFns = []+ , hintDataTypes = []+ , hintRecordTypes = []+ , hintProjections = []+ , hintAxioms = []+ , hintLevel = []+ , hintThisFn = Nothing+ , hintMutualFns = []+ , hintRecVars = recVars+ , hintLetVars = letVars+ }++ -- Names in the same (syntactic) mutual block as the function we are defining (#8783).+ mutualBlockNames <- case mDefName of+ Nothing -> return Set.empty+ Just defName -> do+ mid <- defMutual <$> getConstInfo defName+ if mid == 0 then return Set.empty else mutualNames <$> lookupMutualBlock mid++ -- Extract additional components from the names given as hints.+ hintNames <- getEverythingInScope <$> lookupLocalMeta metaId+ isToLevel <- endsInLevelTester+ scope <- getScope+ components' <- foldM (go isToLevel scope mutualBlockNames) components $+ explicitHints ++ (hintNames List.\\ explicitHints)++ return BaseComponents+ { hintFns = doSort $ hintFns components'+ , hintDataTypes = doSort $ hintDataTypes components'+ , hintRecordTypes = doSort $ hintRecordTypes components'+ , hintProjections = doSort $ hintProjections components'+ , hintAxioms = doSort $ hintAxioms components'+ , hintLevel = doSort $ hintLevel components'+ , hintThisFn = hintThisFn components'+ , hintMutualFns = hintMutualFns components'+ , hintRecVars = recVars+ , hintLetVars = letVars+ }+ where+ hintMode = optHintMode opts+ explicitHints = optExplicitHints opts+ -- Sort by the arity of the type+ doSort = List.sortOn (arity . compType)++ -- A function is mutual with the one we are defining if it is in the+ -- same recursive group (computed by the positivity checker), or if it+ -- is declared in the same mutual block and not a local helper in a @where@.+ isMutual mutualBlockNames qname f = case mDefName of+ Nothing -> False+ Just defName -> defName /= qname && or+ [ fmap (defName `elem`) (funMutual f) == Just True+ , qname `Set.member` mutualBlockNames && qname `notElem` whereNames+ ]++ go isToLevel scope mutualBlockNames comps qname = do+ def <- getConstInfo qname+ let typ = defType def+ case theDef def of+ Axiom{}+ | isToLevel typ -> addLevel+ | shouldKeep -> addAxiom+ | otherwise -> done+ -- We can't use pattern lambdas as components nor with-functions.+ -- If the function is in the same mutual block, we only call it+ -- with structurally smaller arguments, like the function itself (#8783).+ f@Function{ funWith = NoWithFunction, funExtLam = Nothing }+ | Just qname == mDefName -> addThisFn+ | isMutual mutualBlockNames qname f -> addMutualFn+ | isToLevel typ -> addLevel+ | shouldKeep -> addFn+ Function{} -> done+ Datatype{} -> addData+ Record{} -> do+ projections <- mapM (qnameToComponent (costSpeculateProj costs)) =<< getRecordFields qname+ comp <- qnameToComponent (costSet costs) qname+ return comps{ hintRecordTypes = comp : hintRecordTypes comps+ , hintProjections = projections ++ hintProjections comps }+ -- We look up constructors when we need them+ Constructor{} -> done+ -- TODO: special treatment for primitives?+ Primitive{}+ | isToLevel typ -> addLevel+ | shouldKeep -> addFn+ | otherwise -> done+ PrimitiveSort{} -> done+ -- TODO: Check if we want to use these+ DataOrRecSig{} -> done+ GeneralizableVar{} -> done+ AbstractDefn{} -> done+ where+ done = return comps+ -- TODO: There is probably a better way of finding the module name+ mThisModule = qnameModule <$> mDefName++ shouldKeep = or+ [ qname `elem` explicitHints+ , qname `elem` whereNames+ , case hintMode of+ Unqualified -> Scope.isNameInScopeUnqualified qname scope+ AllModules -> True+ Module -> Just (qnameModule qname) == mThisModule+ NoHints -> False+ ]+ addLevel = qnameToComponent (costLevel costs) qname <&> \ comp -> comps{hintLevel = comp : hintLevel comps}+ addAxiom = qnameToComponent (costAxiom costs) qname <&> \ comp -> comps{hintAxioms = comp : hintAxioms comps}+ addThisFn = qnameToComponent (costRecCall costs) qname <&> \ comp -> comps{hintThisFn = Just comp{ compRec = SelfCall }}+ addMutualFn = qnameToComponent (costRecCall costs) qname <&> \ comp -> comps{hintMutualFns = comp{ compRec = MutualCall } : hintMutualFns comps}+ addFn = qnameToComponent (costFn costs) qname <&> \ comp -> comps{hintFns = comp : hintFns comps}+ addData = qnameToComponent (costSet costs) qname <&> \ comp -> comps{hintDataTypes = comp : hintDataTypes comps}+++qnameToComponent :: (HasConstInfo tcm, ReadTCState tcm, MonadFresh CompId tcm)+ => Cost -> QName -> tcm Component+qnameToComponent cost qname = do+ defn <- getConstInfo qname+ -- #7120: we need to apply the module params to everything+ mParams <- freeVarsToApply qname+ let def = (Def qname [] `apply` mParams, 0)+ let (term, pars) = case theDef defn of+ c@Constructor{} -> (Con (conSrcCon c) ConOCon [], conPars c - length mParams)+ Axiom{} -> def+ GeneralizableVar{} -> def+ f@Function{}+ | Right proj <- funProjection f+ , projIndex proj > 0 ->+ let totalToDrop = projIndex proj - 1+ term = Def qname $ map Apply $ drop totalToDrop mParams+ stillToDrop = max 0 $ totalToDrop - length mParams+ in (term , stillToDrop)+ Function{} -> def+ Datatype{} -> def+ Record{} -> def+ Primitive{} -> def+ PrimitiveSort{} -> def+ DataOrRecSig{} -> __IMPOSSIBLE__+ AbstractDefn{} -> __IMPOSSIBLE__+ newComponentQ [] cost qname pars term (defType defn `piApply` mParams)++-- | Turn the let bindings of the current 'TCEnv' into components.+getLetVars :: forall tcm. (MonadFresh CompId tcm, MonadTCM tcm) => Cost -> tcm [Open Component]+getLetVars cost = do+ bindings <- viewTC eLetBindings+ mapM makeComp $ Map.toAscList bindings+ where+ makeComp :: (Name, Open LetBinding) -> tcm (Open Component)+ makeComp (name, opn) = do+ cId <- fresh+ return $ opn <&> \ (LetBinding _isAxiom _origin term typ) ->+ mkComponent cId [] cost (Just name) 0 term (unDom typ)++-- | Returns the variables as terms together with whether they where found under+-- some constructor, and if so which argument of the function they appeared in. This+-- information is used when building recursive calls, where it's important that we don't try to+-- construct non-terminating solutions.+collectLHSVars :: (ReadTCState tcm, MonadError TCErr tcm, MonadTCM tcm, HasConstInfo tcm)+ => InteractionId -> tcm (Open [(Term, Maybe Int)])+collectLHSVars ii = do+ ipc <- ipClause <$> lookupInteractionPoint ii+ case ipc of+ IPNoClause -> makeOpen []+ IPClause{ipcQName = fnName, ipcClauseNo = clauseNr} -> do+ reportSDoc "mimer.components" 40 $ "Collecting LHS vars for" <+> prettyTCM ii+ reportSDoc "mimer.components" 45 $ nest 2 $ vcat+ [ "fnName =" <+> pretty fnName+ , "clauseNr =" <+> pretty clauseNr+ ]+ info <- getConstInfo fnName+ parCount <- liftTCM getCurrentModuleFreeVars+ case theDef info of+ fnDef@Function{} -> do+ let clause = funClauses fnDef !! clauseNr+ naps = namedClausePats clause++ -- Telescope at interaction point+ iTel <- getContextTelescope+ -- Telescope for the body of the clause+ let cTel = clauseTel clause+ -- HACK: To get the correct indices, we shift by the difference in telescope lengths+ let shift = length (telToArgs iTel) - length (telToArgs cTel)++ reportSDoc "mimer" 60 $ vcat+ [ "Tel:"+ , nest 2 $ pretty iTel $$ prettyTCM iTel+ , "CTel:"+ , nest 2 $ pretty cTel $$ prettyTCM cTel+ ]+ reportSDoc "mimer" 60 $ "Shift:" <+> pretty shift++ makeOpen [ (Var (n + shift) [], (i - parCount) <$ guard underCon) -- We count arguments excluding module parameters+ | (i, nap) <- zip [0..] naps+ , (n, underCon) <- go False $ namedThing $ unArg nap+ ]+ _ -> do+ makeOpen []+ where+ go isUnderCon = \case+ VarP patInf x -> [(dbPatVarIndex x, isUnderCon)]+ DotP patInf t -> [] -- Ignore dot patterns+ ConP conHead conPatInf namedArgs -> concatMap (go True . namedThing . unArg) namedArgs+ LitP{} -> []+ ProjP{} -> []+ IApplyP{} -> [] -- Only for Cubical?+ DefP{} -> [] -- Only for Cubical?++declarationQnames :: A.Declaration -> [QName]+declarationQnames dec = [ q | Scope.WithKind _ q <- A.declaredNames dec ]++applyProj :: Args -> Component -> QName -> SM Component+applyProj recordArgs comp' qname = do+ cost <- asks (costProj . searchCosts)+ -- Andreas, 2025-03-31, issue #7662: hack to prevent postfix printing of ♭+ projOrigin <- maybe ProjSystem (\ flat -> if qname == flat then ProjPrefix else ProjSystem)+ <$> asks searchBuiltinFlat+ let newTerm = applyE (compTerm comp') [Proj projOrigin qname]+ projType <- defType <$> getConstInfo qname+ projTypeWithArgs <- piApplyM projType recordArgs+ newType <- piApplyM projTypeWithArgs (compTerm comp')+ newComponentQ (compMetas comp') (compCost comp' + cost) qname 0 newTerm newType+++-- TODO: currently reducing twice+applyToMetasG+ :: Maybe Nat -- ^ Max number of arguments to apply.+ -> Component -> SM Component+applyToMetasG (Just m) comp | m <= 0 = return comp+applyToMetasG maxArgs comp = do+ reportSDoc "mimer.component" 25 $ "Applying component to metas" <+> prettyTCM (compId comp) <+> prettyTCM (compTerm comp)+ ctx <- getContextTelescope+ compTyp <- reduce $ compType comp+ case unEl compTyp of+ Pi dom abs -> do+ let domainType = unDom dom+ (metaId, metaTerm) <- createMeta domainType+ reportSDoc "mimer.component" 30 $ "New arg meta" <+> prettyTCM metaTerm+ let arg = setOrigin Inserted $ metaTerm <$ argFromDom dom+ newType <- reduce =<< piApplyM (compType comp) metaTerm+ -- Constructor parameters are not included in the term+ let skip = compPars comp+ newTerm | skip > 0 = compTerm comp+ | otherwise = apply (compTerm comp) [arg]+ cost <- asks $ (if getHiding arg == Hidden then costNewHiddenMeta else costNewMeta) . searchCosts+ let predNat n | n > 0 = n - 1+ | n == 0 = 0+ | otherwise = __IMPOSSIBLE__+ applyToMetasG (predNat <$> maxArgs)+ comp{ compTerm = newTerm+ , compType = newType+ , compPars = predNat skip+ , compMetas = metaId : compMetas comp+ , compCost = cost + compCost comp+ }+ _ ->+ -- Set the type to the reduced version+ return comp{compType = compTyp}++createMeta :: Type -> SM (MetaId, Term)+createMeta typ = do+ (metaId, metaTerm) <- lift $ newValueMeta DontRunMetaOccursCheck CmpLeq typ+ verboseS "mimer.stats" 20 $ updateStat incMetasCreated+ reportSDoc "mimer.components" 80 $ do+ "Created meta-variable (type in context):" <+> pretty metaTerm <+> ":" <+> (pretty =<< getMetaTypeInContext metaId)+ return (metaId, metaTerm)++------------------------------------------------------------------------+-- * Search branches+------------------------------------------------------------------------++startSearchBranch :: [MetaId] -> TCM SearchBranch+startSearchBranch metaIds = do+ state <- getTC+ pure SearchBranch+ { sbTCState = state+ , sbGoals = map Goal metaIds+ , sbCost = 0+ , sbCache = Map.empty+ , sbComponentsUsed = Map.empty+ }++withBranchState :: SearchBranch -> SM a -> SM a+withBranchState br ma = do+ putTC (sbTCState br)+ ma++withBranchAndGoal :: SearchBranch -> Goal -> SM a -> SM a+withBranchAndGoal br goal ma = inGoalEnv goal $ withBranchState br ma++inGoalEnv :: Goal -> SM a -> SM a+inGoalEnv goal ret = do+ reportSDoc "mimer.env" 70 $ "going into environment of goal" <+> prettyTCM (goalMeta goal)+ withMetaId (goalMeta goal) ret++updateBranch' :: Maybe Component -> [MetaId] -> SearchBranch -> SM SearchBranch+updateBranch' mComp newMetaIds branch = do+ state <- getTC+ let compsUsed = sbComponentsUsed branch+ (deltaCost, compsUsed') <- case mComp of+ Nothing -> return (0, compsUsed)+ Just comp -> do+ case compName comp of+ Nothing -> return (compCost comp, compsUsed)+ Just name -> case compsUsed Map.!? name of+ Nothing -> return (compCost comp, Map.insert name 1 compsUsed)+ Just uses -> do+ reuseCost <- asks (costCompReuse . searchCosts)+ return (compCost comp + reuseCost uses, Map.adjust succ name compsUsed)+ return branch{ sbTCState = state+ , sbGoals = map Goal newMetaIds ++ sbGoals branch+ , sbCost = sbCost branch + deltaCost+ , sbComponentsUsed = compsUsed'+ }++updateBranch :: [MetaId] -> SearchBranch -> SM SearchBranch+updateBranch = updateBranch' Nothing++updateBranchCost :: Component -> [MetaId] -> SearchBranch -> SM SearchBranch+updateBranchCost comp = updateBranch' (Just comp)++checkSolved :: SearchBranch -> SM SearchStepResult+checkSolved branch = do+ reportSDoc "mimer" 20 $ "Checking if branch is solved"+ topMetaId <- asks searchTopMeta+ topMeta <- lookupLocalMeta topMetaId+ ii <- asks searchInteractionId+ withInteractionId ii $ withBranchState branch $ do+ reportSDoc "mimer" 30 $ " remaining subgoals: " <+> prettyTCM (map goalMeta $ sbGoals branch)+ metaArgs <- getMetaContextArgs topMeta+ inst <- normaliseSolution $ apply (MetaV topMetaId []) metaArgs+ -- Issue #7639: The subgoals as generated by `applyToMetasG` (and other functions)+ -- are already stored in the `sbGoals` field of the branch.+ -- Here we just prune the subgoals that are already solved by unification.+ goals <- filterM (isNothing <.> getMetaInstantiation . goalMeta) $ sbGoals branch+ case goals of+ -- Postponed constraints must be solved by the complete solution.+ [] -> ifM (not <$> searchConstraintsSolved) (return NoSolution) $+ -- Issue #378: Blank out variables that are not in scope.+ -- This might leave unsolved metas but is probably better+ -- than generating out-of-scope variables.+ ResultExpr <$> (blankNotInScope =<< reify inst)+ _ -> do+ return $ OpenBranch branch { sbGoals = goals }++normaliseSolution :: Term -> SM Term+normaliseSolution t = do+ norm <- asks searchRewrite+ lift . normalForm norm =<< instantiateFull t++partitionStepResult :: [SearchStepResult] -> SM ([SearchBranch], [MimerResult])+partitionStepResult [] = return ([],[])+partitionStepResult (x:xs) = do+ let rest = partitionStepResult xs+ (brs',sols) <- rest+ case x of+ NoSolution -> rest+ OpenBranch br -> return (br:brs', sols)+ ResultExpr exp -> do+ reportSLn "mimer.search" 45 "partitionStepResult: render ResultExpr"+ str <- P.render <$> prettyTCM exp+ return $ (brs', MimerExpr str : sols)++------------------------------------------------------------------------+-- * Search options+------------------------------------------------------------------------++makeSearchOptions :: Rewrite+ -> Options+ -> InteractionId+ -> TCM SearchOptions+makeSearchOptions norm options ii = do+ metaId <- lookupInteractionId ii+ (mTheFunctionQName, whereNames) <- fmap ipClause (lookupInteractionPoint ii) <&> \case+ clause@IPClause{} -> ( Just $ ipcQName clause+ , case A.whereDecls $ A.clauseWhereDecls $ ipcClause clause of+ Just decl -> declarationQnames decl+ _ -> []+ )+ IPNoClause -> (Nothing, [])++ reportSDoc "mimer.init" 15 $ "Interaction point in function:" <+> pretty mTheFunctionQName+ reportSDoc "mimer.init" 25 $ "Names in where-block" <+> pretty whereNames++ env <- askTC+ costs <- ifM (hasVerbosity "mimer-custom-costs" 123456)+ {- then -} customCosts+ {- else -} (return defaultCosts)+ reportSDoc "mimer-custom-costs" 123456 $ "Using costs:" $$ nest 2 (pretty costs)+ components <- collectComponents options costs ii mTheFunctionQName whereNames metaId+ statsRef <- liftIO $ newIORef emptyMimerStats+ checkpoint <- viewTC eCurrentCheckpoint+ pid <- fresh+ mflat <- getBuiltinName BuiltinFlat+ pure SearchOptions+ { searchBaseComponents = components+ , searchHintMode = optHintMode options+ , searchTimeout = optTimeout options+ , searchGenProjectionsLocal = True+ , searchGenProjectionsLet = True+ , searchGenProjectionsExternal = False+ , searchGenProjectionsRec = True+ , searchSpeculateProjections = True+ , searchTopMeta = metaId+ , searchTopEnv = env+ , searchTopCheckpoint = checkpoint+ , searchProblem = pid+ , searchInteractionId = ii+ , searchFnName = mTheFunctionQName+ , searchCosts = costs+ , searchStats = statsRef+ , searchRewrite = norm+ , searchBuiltinFlat = mflat+ }++------------------------------------------------------------------------+-- * Unification+------------------------------------------------------------------------++-- | Unify the type of a candidate with the goal type.+--+-- Constraints that cannot be solved yet, e.g. @f ?n = f n@ blocked on+-- meta @?n@ which is a subgoal of the candidate, are postponed under+-- the search problem (see 'searchProblem').+-- They are woken up when their blocking metas are solved, and+-- 'checkSolved' only accepts a branch once they are gone.+dumbUnifier :: Type -> Type -> SM ()+dumbUnifier t1 t2 = bench [Bench.UnifyIndices] $ do+ updateStat incTypeEqChecks+ pid <- asks searchProblem+ lift $ solvingProblem pid $ equalType t2 t1++-- | Solve constraints woken up by meta assignments.+-- Throws an error if one of them turns out to be unsolvable.+solveSearchConstraints :: SM ()+solveSearchConstraints = lift solveAwakeConstraints++-- | Are all constraints solved that were postponed during search?+searchConstraintsSolved :: SM Bool+searchConstraintsSolved = do+ pid <- asks searchProblem+ (solveSearchConstraints >> null <$> getConstraintsForProblem pid)+ `catchError` \ _ -> return False++------------------------------------------------------------------------+-- * Debugging+------------------------------------------------------------------------++reportSMDoc :: VerboseKey -> VerboseLevel -> SM Doc -> SM ()+reportSMDoc vk vl md = reportSDoc vk vl . runReaderT md =<< ask++mimerTrace :: Int -> VerboseLevel -> SM Doc -> SM ()+mimerTrace ilvl vlvl doc = reportSMDoc "mimer.trace" vlvl $ nest (2 * ilvl) $ "-" <+> doc++topInstantiationDoc :: SM Doc+topInstantiationDoc = asks searchTopMeta >>= getMetaInstantiation >>= maybe (return "(nothing)") prettyTCM++prettyGoalInst :: Goal -> SM Doc+prettyGoalInst goal = inGoalEnv goal $ do+ args <- map Apply <$> getContextArgs+ prettyTCM =<< instantiate (MetaV (goalMeta goal) args)++branchInstantiationDocCost :: SearchBranch -> SM Doc+branchInstantiationDocCost branch = branchInstantiationDoc branch <+> parens ("cost:" <+> pretty (sbCost branch))++-- | For debug+branchInstantiationDoc :: SearchBranch -> SM Doc+branchInstantiationDoc branch = withBranchState branch topInstantiationDoc++prettyBranch :: SearchBranch -> SM String+prettyBranch branch = withBranchState branch $ do+ metaId <- asks searchTopMeta+ P.render <$> "Branch" <> braces (sep $ punctuate ","+ [ "cost:" <+> pretty (sbCost branch)+ , "metas:" <+> prettyTCM (map goalMeta (sbGoals branch))+ , sep [ "instantiation:"+ , nest 2 $ pretty metaId <+> "=" <+> (prettyTCM =<< getMetaInstantiation metaId) ]+ , "used components:" <+> pretty (Map.toList $ sbComponentsUsed branch)+ ])++-- Hack to let you experiment with costs using verbosity flags.+customCosts :: TCM Costs+customCosts = do+ costLocal <- cost "local"+ costFn <- cost "fn"+ costDataCon <- cost "dataCon"+ costRecordCon <- cost "recordCon"+ costSpeculateProj <- cost "speculateProj"+ costProj <- cost "proj"+ costAxiom <- cost "axiom"+ costLet <- cost "let"+ costLevel <- cost "level"+ costSet <- cost "set"+ costRecCall <- cost "recCall"+ costNewMeta <- cost "newMeta"+ costNewHiddenMeta <- cost "newHiddenMeta"+ compReuse <- cost "compReuse"+ let costCompReuse uses = compReuse * uses ^ 2+ pure Costs{..}+ where+ cost key = getVerbosityLevel ("mimer-cost." ++ key)++------------------------------------------------------------------------+-- * Stats+------------------------------------------------------------------------++updateStat :: (MimerStats -> MimerStats) -> SM ()+updateStat f = verboseS "mimer.stats" 10 $ do+ ref <- asks searchStats+ liftIO $ modifyIORef' ref f++bench :: [Bench.Phase] -> SM a -> SM a+bench k ma = billTo (mimerAccount : k) ma+ where+ -- Dummy account to avoid updating Bench. Doesn't matter since this is only used interactively+ -- to debug Mimer performance.+ mimerAccount = Bench.Sort++writeTime :: (ReadTCState m, MonadError TCErr m, MonadTCM m, MonadDebug m)+ => InteractionId+ -> CPUTime+ -> m ()+writeTime ii (CPUTime time) = do+ file <- rangeFile . ipRange <$> lookupInteractionPoint ii+ case file of+ SMaybe.Nothing ->+ reportSLn "mimer.stats" 2 "No file found for interaction id"+ SMaybe.Just file -> do+ let path = filePath (rangeFilePath file) ++ ".stats"+ liftIO $ appendFile path (show (interactionId ii) ++ " " ++ show time ++ "\n")
src/full/Agda/Mimer/Options.hs view
@@ -9,7 +9,6 @@ import Agda.Syntax.Common.Pretty (Pretty, pretty, text) import Agda.Syntax.Abstract.Name (QName) import Agda.TypeChecking.Monad.Base (TCM)-import Agda.Interaction.Highlighting.Range (empty) import Agda.Syntax.Common (InteractionId) import Agda.Syntax.Position (Range) import qualified Agda.Syntax.Abstract as A
+ src/full/Agda/Mimer/Types.hs view
@@ -0,0 +1,412 @@++module Agda.Mimer.Types where++import Control.DeepSeq (NFData)+import Data.Function (on)+import Data.Map (Map)+import Data.List qualified as List+import GHC.Generics (Generic)+import Data.IORef (IORef)++import Agda.Syntax.Abstract (Expr)+import Agda.Syntax.Common.Pretty qualified as P+import Agda.Syntax.Common.Pretty (Pretty)+import Agda.Syntax.Common (InteractionId, Nat)+import Agda.Syntax.Internal+import Agda.TypeChecking.Monad (TCState, CheckpointId, Open, TCEnv, openThing)+import Agda.TypeChecking.Pretty+import Agda.Interaction.Base (Rewrite(..))+import Agda.Utils.Tuple (second)+import Agda.Utils.Impossible++import Agda.Mimer.Options++------------------------------------------------------------------------+-- * Results+------------------------------------------------------------------------++data MimerResult+ = MimerExpr String -- ^ Returns 'String' rather than 'Expr' because the give action expects a string.+ | MimerList [(Int, String)]+ | MimerNoResult+ deriving (Generic)++instance NFData MimerResult++isNoResult :: MimerResult -> Bool+isNoResult MimerNoResult = True+isNoResult _ = False++data SearchStepResult+ = ResultExpr Expr+ | OpenBranch SearchBranch+ | NoSolution+ deriving (Generic)++instance NFData SearchStepResult++------------------------------------------------------------------------+-- * Search branches+------------------------------------------------------------------------++data SearchBranch = SearchBranch+ { sbTCState :: TCState+ , sbGoals :: [Goal]+ , sbCost :: Int+ , sbCache :: Map CheckpointId ComponentCache+ , sbComponentsUsed :: Map Name Int -- ^ Number of times each component has been used+ }+ deriving (Generic)+instance NFData SearchBranch++-- | NOTE: Equality is only on the fields `sbCost` and `sbGoals`+instance Eq SearchBranch where+ sb1 == sb2 = sbCost sb1 == sbCost sb2 && sbGoals sb1 == sbGoals sb2++-- TODO: Explain+instance Ord SearchBranch where+ compare = compare `on` sbCost++data Goal = Goal+ { goalMeta :: MetaId+ }+ deriving (Generic)+instance NFData Goal++-- TODO: Is this a reasonable Eq instance?+instance Eq Goal where+ g1 == g2 = goalMeta g1 == goalMeta g2++-- | Take the first goal off a search branch.+-- Precondition: the set of goals is non-empty.+nextGoal :: SearchBranch -> (Goal, SearchBranch)+nextGoal branch =+ case sbGoals branch of+ [] -> __IMPOSSIBLE__+ goal : goals -> (goal, branch{ sbGoals = goals })++------------------------------------------------------------------------+-- * Components+------------------------------------------------------------------------++-- Map source component to generated components+type ComponentCache = Map Component (Maybe [Component])++-- | Components that are not changed during search. Components that do change+-- (local variables and let bindings) are stored in each 'SearchBranch'.+data BaseComponents = BaseComponents+ { hintFns :: [Component]+ , hintDataTypes :: [Component]+ , hintRecordTypes :: [Component]+ , hintAxioms :: [Component]+ -- ^ Excluding those producing Level+ , hintLevel :: [Component]+ -- ^ A definition in a where clause+ , hintProjections :: [Component]+ -- ^ Variables that are candidates for arguments to recursive calls+ , hintThisFn :: Maybe Component+ , hintMutualFns :: [Component]+ -- ^ Functions mutually defined with the one we are defining (#8783).+ , hintLetVars :: [Open Component]+ , hintRecVars :: Open [(Term, NoSubst Term Int)] -- ^ Variable terms and which argument they come from+ }+ deriving (Generic)++instance NFData BaseComponents++type CompId = Int+data Component = Component+ { compId :: CompId -- ^ Unique id for the component. Used for the cache.+ , compName :: Maybe Name -- ^ Used for keeping track of how many times a component has been used+ , compPars :: Nat -- ^ How many arguments should be dropped (e.g. constructor parameters)+ , compTerm :: Term+ , compType :: Type+ , compRec :: RecCall -- ^ Is this a (mutually) recursive call?+ , compMetas :: [MetaId]+ , compCost :: Cost+ }+ deriving (Eq, Generic)++instance NFData Component++-- | Is a component a call to the function we are defining+-- or a function mutually defined with it?+-- Such calls are only generated with structurally smaller arguments.+data RecCall+ = NotRecCall+ -- ^ Not a recursive call.+ | SelfCall+ -- ^ Recursive call to the function we are defining.+ -- An argument needs to be structurally smaller than the parameter+ -- in the same position.+ | MutualCall+ -- ^ Call to a function mutually defined with the one we are defining (#8783).+ -- As arguments of different functions need not correspond by position,+ -- we accept any structurally smaller variable in any position.+ deriving (Eq, Show, Generic)++instance NFData RecCall++-- TODO: Is this reasonable?+instance Ord Component where+ compare = compare `on` compId++mkComponent :: CompId -> [MetaId] -> Cost -> Maybe Name -> Nat -> Term -> Type -> Component+mkComponent cId metaIds cost mName pars term typ = Component+ { compId = cId+ , compName = mName+ , compPars = pars+ , compTerm = term+ , compType = typ+ , compRec = NotRecCall+ , compMetas = metaIds+ , compCost = cost }++mkComponentQ :: CompId -> Cost -> QName -> Nat -> Term -> Type -> Component+mkComponentQ cId cost qname = mkComponent cId [] cost (Just $ qnameName qname)++noName :: Maybe Name+noName = Nothing++addCost :: Cost -> Component -> Component+addCost cost comp = comp { compCost = cost + compCost comp }++deleteCompMeta :: MetaId -> Component -> Component+deleteCompMeta old c = c{ compMetas = List.delete old (compMetas c) }++------------------------------------------------------------------------+-- * SearchOptions+------------------------------------------------------------------------++data SearchOptions = SearchOptions+ { searchBaseComponents :: BaseComponents+ , searchHintMode :: HintMode+ , searchTimeout :: MilliSeconds+ , searchGenProjectionsLocal :: Bool+ , searchGenProjectionsLet :: Bool+ , searchGenProjectionsExternal :: Bool+ , searchGenProjectionsRec :: Bool+ , searchSpeculateProjections :: Bool+ , searchTopMeta :: MetaId+ , searchTopEnv :: TCEnv+ , searchTopCheckpoint :: CheckpointId+ , searchProblem :: ProblemId+ -- ^ Constraints postponed during search are tagged with this problem.+ -- A branch is only a solution once all of them are solved.+ , searchInteractionId :: InteractionId+ , searchFnName :: Maybe QName+ , searchCosts :: Costs+ , searchStats :: IORef MimerStats+ , searchRewrite :: Rewrite+ , searchBuiltinFlat :: Maybe QName+ -- Cache BUILTIN_FLAT for issue #7662 workaround+ }++type Cost = Int+data Costs = Costs+ { costLocal :: Cost+ , costFn :: Cost+ , costDataCon :: Cost+ , costRecordCon :: Cost+ , costSpeculateProj :: Cost+ , costProj :: Cost+ , costAxiom :: Cost+ , costLet :: Cost+ , costLevel :: Cost+ , costSet :: Cost -- Should probably be replaced with multiple different costs+ , costRecCall :: Cost+ , costNewMeta :: Cost -- ^ Cost of a new meta-variable appearing in a non-implicit position+ , costNewHiddenMeta :: Cost -- ^ Cost of a new meta-variable appearing in an implicit position+ , costCompReuse :: Nat -> Cost -- ^ Cost of reusing a component @n@ times. Only counted when @n>1@.+ }++noCost :: Cost+noCost = 0++defaultCosts :: Costs+defaultCosts = Costs+ { costLocal = 3+ , costFn = 10+ , costDataCon = 3+ , costRecordCon = 3+ , costSpeculateProj = 20+ , costProj = 3+ , costAxiom = 10+ , costLet = 5+ , costLevel = 3+ , costSet = 10+ , costRecCall = 8+ , costNewMeta = 10+ , costNewHiddenMeta = 1+ , costCompReuse = \uses -> 10 * (uses - 1) ^ 2+ }++------------------------------------------------------------------------+-- * Measure performance+------------------------------------------------------------------------++data MimerStats = MimerStats+ { statCompHit :: !Int -- ^ Could make use of an already generated component+ , statCompGen :: !Int -- ^ Could use a generator for a component+ , statCompRegen :: !Int -- ^ Had to regenerate the cache (new context)+ , statCompNoRegen :: !Int -- ^ Did not have to regenerate the cache+ , statMetasCreated :: !Int -- ^ Total number of meta-variables created explicitly (not through unification)+ , statTypeEqChecks :: !Int -- ^ Number of times type equality is tested (with unification)+ , statRefineSuccess :: !Int -- ^ Number of times a refinement has been successful+ , statRefineFail :: !Int -- ^ Number of times a refinement has failed+ } deriving (Show, Eq, Generic)+instance NFData MimerStats++emptyMimerStats :: MimerStats+emptyMimerStats = MimerStats+ { statCompHit = 0, statCompGen = 0, statCompRegen = 0 , statCompNoRegen = 0 , statMetasCreated = 0, statTypeEqChecks = 0, statRefineSuccess = 0 , statRefineFail = 0}++incCompHit, incCompGen, incCompRegen, incCompNoRegen, incMetasCreated, incTypeEqChecks, incRefineSuccess, incRefineFail :: MimerStats -> MimerStats+incCompHit stats = stats {statCompHit = succ $ statCompHit stats}+incCompGen stats = stats {statCompGen = succ $ statCompGen stats}+incCompRegen stats = stats {statCompRegen = succ $ statCompRegen stats}+incCompNoRegen stats = stats {statCompNoRegen = succ $ statCompNoRegen stats}+incMetasCreated stats = stats {statMetasCreated = succ $ statMetasCreated stats}+incTypeEqChecks stats = stats {statTypeEqChecks = succ $ statTypeEqChecks stats}+incRefineSuccess stats = stats {statRefineSuccess = succ $ statRefineSuccess stats}+incRefineFail stats = stats {statRefineFail = succ $ statRefineFail stats}++------------------------------------------------------------------------+-- * Pretty printing+------------------------------------------------------------------------++haskellRecord :: Doc -> [(Doc, Doc)] -> Doc+haskellRecord name fields = P.sep [ name, P.nest 2 $ P.braces (P.sep $ P.punctuate "," [ P.hang (k P.<+> "=") 2 v | (k, v) <- fields ]) ]++keyValueList :: [(Doc, Doc)] -> Doc+keyValueList kvs = P.braces $ P.sep $ P.punctuate "," [ P.hang (k <> ":") 2 v | (k, v) <- kvs ]++instance Pretty Goal where+ pretty goal = P.pretty $ goalMeta goal++instance Pretty SearchBranch where+ pretty branch = keyValueList+ [ ("sbTCState", "[...]")+ , ("sbGoals", P.pretty $ sbGoals branch)+ , ("sbCost", P.pretty $ sbCost branch)+ , ("sbComponentsUsed", P.pretty $ sbComponentsUsed branch)+ ]++instance PrettyTCM BaseComponents where+ prettyTCM comps = do+ let thisFn = case hintThisFn comps of+ Nothing -> "(nothing)"+ Just comp -> prettyComp comp+ vcat [ "Base components:"+ , nest 2 $ vcat+ [ f "hintFns" (hintFns comps)+ , f "hintDataTypes" (hintDataTypes comps)+ , f "hintRecordTypes" (hintRecordTypes comps)+ , f "hintAxioms" (hintAxioms comps)+ , f "hintLevel" (hintLevel comps)+ , f "hintProjections" (hintProjections comps)+ , "hintThisFn:" <+> thisFn+ , f "hintMutualFns" (hintMutualFns comps)+ , g prettyOpenComp "hintLetVars" (hintLetVars comps)+ , "hintRecVars: Open" <+> pretty (second unNoSubst <$> openThing (hintRecVars comps))+ ]+ ]+ where+ prettyComp comp = pretty (compTerm comp) <+> ":" <+> pretty (compType comp)+ prettyOpenComp openComp = "Open" <+> parens (prettyComp $ openThing openComp)+ prettyTCMComp comp = prettyTCM (compTerm comp) <+> ":" <+> prettyTCM (compType comp)+ f = g prettyTCMComp+ g p n [] = n <> ": []"+ g p n xs = (n <> ":") $+$ nest 2 (vcat $ map p xs)++instance Pretty BaseComponents where+ pretty comps = P.vcat+ [ f "hintFns" (hintFns comps)+ , f "hintDataTypes" (hintDataTypes comps)+ , f "hintRecordTypes" (hintRecordTypes comps)+ , f "hintAxioms" (hintAxioms comps)+ , f "hintLevel" (hintLevel comps)+ , f "hintProjections" (hintProjections comps)+ ]+ where+ f n [] = n <> ": []"+ f n xs = (n <> ":") P.$$ P.nest 2 (P.pretty xs)++instance Pretty SearchOptions where+ pretty opts = P.vcat+ [ "searchBaseComponents:"+ , P.nest 2 $ P.pretty $ searchBaseComponents opts+ , keyValueList+ [ ("searchHintMode", P.pretty $ searchHintMode opts)+ , ("searchTimeout", P.pretty $ searchTimeout opts)+ , ("searchTopMeta", P.pretty $ searchTopMeta opts)+ , ("searchTopEnv", "[...]")+ ]+ , "searchCosts:"+ , P.nest 2 (P.pretty $ searchCosts opts)+ ]++instance PrettyTCM SearchOptions where+ prettyTCM opts = vcat+ [ "searchBaseComponents:"+ , nest 2 $ prettyTCM $ searchBaseComponents opts+ , vcat+ [ "searchHintMode:" <+> pretty (searchHintMode opts)+ , "searchTimeout:" <+> pretty (searchTimeout opts)+ , "searchTopMeta:" <+> prettyTCM (searchTopMeta opts)+ , "searchTopEnv: [...]"+ , "searchTopCheckpoint:" <+> prettyTCM (searchTopCheckpoint opts)+ , "searchInteractionId:" <+> pretty (searchInteractionId opts)+ , "searchFnName:" <+> pretty (searchFnName opts)+ , "searchStats: [...]"+ ]+ , "searchCosts:"+ , nest 2 $ pretty $ searchCosts opts+ ]++instance Pretty Component where+ pretty comp = haskellRecord "Component"+ [ ("compId", P.pretty $ compId comp)+ , ("compTerm", P.pretty $ compTerm comp)+ , ("compType", P.pretty $ compType comp)+ , ("compMetas", P.pretty $ compMetas comp)+ , ("compCost", P.pretty $ compCost comp)+ ]++instance Pretty Costs where+ pretty costs = P.align 20 entries+ where+ entries =+ [ ("costLocal:" , P.pretty $ costLocal costs)+ , ("costFn:" , P.pretty $ costFn costs)+ , ("costDataCon:" , P.pretty $ costDataCon costs)+ , ("costRecordCon:" , P.pretty $ costRecordCon costs)+ , ("costSpeculateProj:" , P.pretty $ costSpeculateProj costs)+ , ("costProj:" , P.pretty $ costProj costs)+ , ("costAxiom:" , P.pretty $ costAxiom costs)+ , ("costLet:" , P.pretty $ costLet costs)+ , ("costLevel:" , P.pretty $ costLevel costs)+ , ("costSet:" , P.pretty $ costSet costs)+ , ("costRecCall:" , P.pretty $ costRecCall costs)+ , ("costNewMeta:" , P.pretty $ costNewMeta costs)+ , ("costNewHiddenMeta:" , P.pretty $ costNewHiddenMeta costs)+ , ("costCompReuse:" , "{function}")+ ]++instance PrettyTCM Component where+ prettyTCM Component{ compId, compTerm, compType, compCost, compMetas } =+ parens (prettyTCM compId) <+> sep+ [ sep [ prettyTCM compTerm+ , ":" <+> prettyTCM compType ]+ , parens $ fsep $ punctuate ","+ [ "cost:" <+> prettyTCM compCost+ , "metas:" <+> prettyTCM compMetas+ ]+ ]++instance PrettyTCM MimerResult where+ prettyTCM = \case+ MimerExpr expr -> pretty expr+ MimerNoResult -> "MimerNoResult"+ MimerList sols -> "MimerList" <+> pretty sols+
src/full/Agda/Syntax/Abstract.hs view
@@ -1,3 +1,7 @@+{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-}+{-# LANGUAGE StrictData #-} {-| The abstract syntax. This is what you get after desugaring and scope analysis of the concrete syntax. The type checker works on abstract syntax,@@ -30,6 +34,7 @@ import Agda.Syntax.Abstract.Name import qualified Agda.Syntax.Internal as I import Agda.Syntax.Common+import Agda.Syntax.Common.Aspect (Aspects) import Agda.Syntax.Common.Pretty import Agda.Syntax.Info import Agda.Syntax.Literal@@ -110,11 +115,19 @@ -- ^ Record construction. The 'KwRange' is for the @record@ kewyword. | RecUpdate KwRange ExprInfo Expr Assigns -- ^ Record update. The 'KwRange' is for the @record@ kewyword.- | ScopedExpr ScopeInfo Expr -- ^ Scope annotation.+ | Quote ExprInfo -- ^ Quote an identifier 'QName'. | QuoteTerm ExprInfo -- ^ Quote a term. | Unquote ExprInfo -- ^ The splicing construct: unquote ...- | DontCare Expr -- ^ For printing @DontCare@ from @Syntax.Internal@.++ -- Wrappers generated by scope checking to remember information that+ -- does not essentially affect type checking:+ | ScopedExpr ScopeInfo Expr -- ^ Scope annotation.+ | Qualified ModuleName Expr -- ^ For remembering the module name of a qualified @do@ block.++ -- Wrappers for internal syntax:+ | Highlighted Aspects Expr -- ^ For printing annotated terms produced by the type checker.+ | DontCare Expr -- ^ For printing @DontCare@ from @Agda.Syntax.Internal@. deriving (Show, Generic) -- | Pattern synonym for regular 'Def'.@@ -134,20 +147,25 @@ -- | Renaming (generic). type Ren a = Map a (List1 a) -data ScopeCopyInfo = ScopeCopyInfo- { renModules :: Ren ModuleName- , renNames :: Ren QName }- deriving (Eq, Show, Generic)+-- | Size of the range of the renaming.+renamingSize :: Ren a -> Int+renamingSize = Map.foldl' (\n xs -> n + length xs) 0 -initCopyInfo :: ScopeCopyInfo-initCopyInfo = ScopeCopyInfo- { renModules = mempty- , renNames = mempty+-- | Information created by the scope checker necessary for+-- type-checking a module copy.+data ScopeCopyInfo = ScopeCopyInfo+ { renModules :: Ren ModuleName+ -- ^ Associates to each (original) module name the list of copies+ -- that should be created.+ , renNames :: Ren QName+ -- ^ Same as for 'renModules', but for definitions. }+ deriving (Eq, Show, Generic) instance Pretty ScopeCopyInfo where pretty i = vcat [ prRen "renModules =" (renModules i)- , prRen "renNames =" (renNames i) ]+ , prRen "renNames =" (renNames i)+ ] where prRen s r = sep [ text s, nest 2 $ vcat (map pr xs) ] where@@ -175,7 +193,7 @@ -- ^ The first argument is the (possibly empty) set of generalizable variables used in the type. | Field DefInfo QName (Arg Type) -- ^ record field | Primitive DefInfo QName (Arg Type) -- ^ primitive function- | Mutual MutualInfo [Declaration] -- ^ a bunch of mutually recursive definitions+ | Mutual MutualInfo (List1 Declaration) -- ^ a bunch of mutually recursive definitions | Section Range Erased ModuleName GeneralizeTelescope [Declaration] | Apply ModuleInfo Erased ModuleName ModuleApplication ScopeCopyInfo ImportDirective@@ -184,11 +202,11 @@ -- ^ The @ImportDirective@ is for highlighting purposes. | Pragma Range Pragma | Open ModuleInfo ModuleName ImportDirective- | FunDef DefInfo QName [Clause] -- ^ sequence of function clauses+ | FunDef DefInfo QName (List1 Clause) -- ^ sequence of function clauses | DataSig DefInfo Erased QName GeneralizeTelescope Type -- ^ lone data signature- | DataDef DefInfo QName UniverseCheck DataDefParams [Constructor]+ | DataDef DefInfo QName PositivityCheck UniverseCheck DataDefParams [Constructor] | RecSig DefInfo Erased QName GeneralizeTelescope Type -- ^ lone record signature- | RecDef DefInfo QName UniverseCheck RecordDirectives DataDefParams Type [Declaration]+ | RecDef DefInfo QName PositivityCheck UniverseCheck ForceRecordEta RecordDirectives DataDefParams Type [Declaration] -- ^ The 'Type' gives the constructor type telescope, @(x1 : A1)..(xn : An) -> Dummy@, -- and the optional name is the constructor's name. -- The optional 'Range' is for the @pattern@ attribute.@@ -197,7 +215,7 @@ | UnquoteDecl MutualInfo [DefInfo] [QName] Expr | UnquoteDef [DefInfo] [QName] Expr | UnquoteData [DefInfo] QName UniverseCheck [DefInfo] [QName] Expr- | ScopedDecl ScopeInfo [Declaration] -- ^ scope annotation+ | ScopedDecl ScopeInfo (List1 Declaration) -- ^ scope annotation | UnfoldingDecl Range [QName] -- ^ Only for highlighting the unfolded names deriving (Show, Generic)@@ -226,10 +244,8 @@ | RewritePragma Range [QName] -- ^ Range is range of REWRITE keyword. | CompilePragma (Ranged BackendName) QName String+ | ForeignPragma (Ranged BackendName) String | StaticPragma QName- | EtaPragma QName- -- ^ For coinductive records, use pragma instead of regular- -- @eta-equality@ definition (as it is might make Agda loop). | InjectivePragma QName | InjectiveForInferencePragma QName | InlinePragma Bool QName -- INLINE or NOINLINE@@ -246,7 +262,7 @@ -- ^ @LetBind info rel name type defn@ | LetAxiom LetInfo ArgInfo BindName Type -- ^ Function declarations in a let with no matching body.- | LetPatBind LetInfo Pattern Expr+ | LetPatBind LetInfo ArgInfo Pattern Expr -- ^ Irrefutable pattern binding. | LetApply ModuleInfo Erased ModuleName ModuleApplication ScopeCopyInfo ImportDirective@@ -348,7 +364,7 @@ type Telescope = [TypedBinding] mkPi :: ExprInfo -> Telescope -> Type -> Type-mkPi i [] e = e+mkPi _ [] e = e mkPi i (x:xs) e = Pi i (x :| xs) e data GeneralizeTelescope = GeneralizeTel@@ -619,9 +635,9 @@ Open a1 b1 c1 == Open a2 b2 c2 = (a1, b1, c1) == (a2, b2, c2) FunDef a1 b1 c1 == FunDef a2 b2 c2 = (a1, b1, c1) == (a2, b2, c2) DataSig a1 b1 c1 d1 e1 == DataSig a2 b2 c2 d2 e2 = (a1, b1, c1, d1, e1) == (a2, b2, c2, d2, e2)- DataDef a1 b1 c1 d1 e1 == DataDef a2 b2 c2 d2 e2 = (a1, b1, c1, d1, e1) == (a2, b2, c2, d2, e2)+ DataDef a1 b1 c1 d1 e1 f1 == DataDef a2 b2 c2 d2 e2 f2 = (a1, b1, c1, d1, e1, f1) == (a2, b2, c2, d2, e2, f2) RecSig a1 b1 c1 d1 e1 == RecSig a2 b2 c2 d2 e2 = (a1, b1, c1, d1, e1) == (a2, b2, c2, d2, e2)- RecDef a1 b1 c1 d1 e1 f1 g1 == RecDef a2 b2 c2 d2 e2 f2 g2 = (a1, b1, c1, d1, e1, f1, g1) == (a2, b2, c2, d2, e2, f2, g2)+ RecDef a1 b1 c1 d1 e1 f1 g1 h1 i1 == RecDef a2 b2 c2 d2 e2 f2 g2 h2 i2 = (a1, b1, c1, d1, e1, f1, g1, h1, i1) == (a2, b2, c2, d2, e2, f2, g2, h2, i2) PatternSynDef a1 b1 c1 == PatternSynDef a2 b2 c2 = (a1, b1, c1) == (a2, b2, c2) UnquoteDecl a1 b1 c1 d1 == UnquoteDecl a2 b2 c2 d2 = (a1, b1, c1, d1) == (a2, b2, c2, d2) UnquoteDef a1 b1 c1 == UnquoteDef a2 b2 c2 = (a1, b1, c1) == (a2, b2, c2)@@ -645,7 +661,7 @@ getHiding (TBind _ _ (x :| _) _) = getHiding x -- Slightly dubious getHiding TLet{} = mempty mapHiding f (TBind r t xs e) = TBind r t ((fmap . mapHiding) f xs) e- mapHiding f b@TLet{} = b+ mapHiding _ b@TLet{} = b instance HasRange a => HasRange (Binder' a) where getRange (Binder p _ n) = fuseRange p n@@ -659,32 +675,34 @@ getRange (TLet r _) = r instance HasRange Expr where- getRange (Var x) = getRange x- getRange (Def' x _) = getRange x- getRange (Proj _ x) = getRange x- getRange (Con x) = getRange x- getRange (Lit i _) = getRange i- getRange (QuestionMark i _) = getRange i- getRange (Underscore i) = getRange i- getRange (Dot i _) = getRange i- getRange (App i _ _) = getRange i- getRange (WithApp i _ _) = getRange i- getRange (Lam i _ _) = getRange i- getRange (AbsurdLam i _) = getRange i- getRange (ExtendedLam i _ _ _ _) = getRange i- getRange (Pi i _ _) = getRange i- getRange (Generalized _ x) = getRange x- getRange (Fun i _ _) = getRange i- getRange (Let i _ _) = getRange i- getRange (Rec _ i _) = getRange i- getRange (RecUpdate _ i _ _) = getRange i- getRange (ScopedExpr _ e) = getRange e- getRange (Quote i) = getRange i- getRange (QuoteTerm i) = getRange i- getRange (Unquote i) = getRange i- getRange (DontCare{}) = noRange- getRange (PatternSyn x) = getRange x- getRange (Macro x) = getRange x+ getRange (Var x) = getRange x+ getRange (Def' x _) = getRange x+ getRange (Proj _ x) = getRange x+ getRange (Con x) = getRange x+ getRange (Lit i _) = getRange i+ getRange (QuestionMark i _) = getRange i+ getRange (Underscore i) = getRange i+ getRange (Dot i _) = getRange i+ getRange (App i _ _) = getRange i+ getRange (WithApp i _ _) = getRange i+ getRange (Lam i _ _) = getRange i+ getRange (AbsurdLam i _) = getRange i+ getRange (ExtendedLam i _ _ _ _) = getRange i+ getRange (Pi i _ _) = getRange i+ getRange (Generalized _ x) = getRange x+ getRange (Fun i _ _) = getRange i+ getRange (Let i _ _) = getRange i+ getRange (Rec _ i _) = getRange i+ getRange (RecUpdate _ i _ _) = getRange i+ getRange (ScopedExpr _ e) = getRange e+ getRange (Quote i) = getRange i+ getRange (QuoteTerm i) = getRange i+ getRange (Unquote i) = getRange i+ getRange (DontCare{}) = noRange+ getRange (PatternSyn x) = getRange x+ getRange (Macro x) = getRange x+ getRange (Qualified _ e) = getRange e+ getRange (Highlighted _ e) = getRange e instance HasRange Declaration where getRange (Axiom _ i _ _ _ _ ) = getRange i@@ -700,9 +718,9 @@ getRange (ScopedDecl _ d ) = getRange d getRange (FunDef i _ _ ) = getRange i getRange (DataSig i _ _ _ _ ) = getRange i- getRange (DataDef i _ _ _ _ ) = getRange i+ getRange (DataDef i _ _ _ _ _) = getRange i getRange (RecSig i _ _ _ _ ) = getRange i- getRange (RecDef i _ _ _ _ _ _) = getRange i+ getRange (RecDef i _ _ _ _ _ _ _ _)= getRange i getRange (PatternSynDef x _ _ ) = getRange x getRange (UnquoteDecl _ i _ _) = getRange i getRange (UnquoteDef i _ _) = getRange i@@ -718,7 +736,7 @@ getRange (AsP i _ _) = getRange i getRange (DotP i _) = getRange i getRange (AbsurdP i) = getRange i- getRange (LitP i l) = getRange i+ getRange (LitP i _) = getRange i getRange (PatternSynP i _ _) = getRange i getRange (RecP _kwr i _) = getRange i getRange (EqualP i _) = getRange i@@ -736,7 +754,7 @@ getRange (LHSWith h wps ps) = h `fuseRange` wps `fuseRange` ps instance HasRange a => HasRange (Clause' a) where- getRange (Clause lhs _ rhs ds catchall) = getRange (lhs, rhs, ds)+ getRange (Clause lhs _ rhs ds _catchall) = getRange (lhs, rhs, ds) instance HasRange RHS where getRange AbsurdRHS = noRange@@ -750,7 +768,7 @@ instance HasRange LetBinding where getRange (LetBind i _ _ _ _) = getRange i getRange (LetAxiom i _ _ _) = getRange i- getRange (LetPatBind i _ _) = getRange i+ getRange (LetPatBind i _ _ _) = getRange i getRange (LetApply i _ _ _ _ _) = getRange i getRange (LetOpen i _ _) = getRange i @@ -792,32 +810,34 @@ killRange (TLet r lbs) = killRangeN TLet r lbs instance KillRange Expr where- killRange (Var x) = killRangeN Var x- killRange (Def' x v) = killRangeN Def' x v- killRange (Proj o x) = killRangeN (Proj o) x- killRange (Con x) = killRangeN Con x- killRange (Lit i l) = killRangeN Lit i l- killRange (QuestionMark i ii) = killRangeN QuestionMark i ii- killRange (Underscore i) = killRangeN Underscore i- killRange (Dot i e) = killRangeN Dot i e- killRange (App i e1 e2) = killRangeN App i e1 e2- killRange (WithApp i e es) = killRangeN WithApp i e es- killRange (Lam i b e) = killRangeN Lam i b e- killRange (AbsurdLam i h) = killRangeN AbsurdLam i h- killRange (ExtendedLam i n e d ps) = killRangeN ExtendedLam i n e d ps- killRange (Pi i a b) = killRangeN Pi i a b- killRange (Generalized s x) = killRangeN (Generalized s) x- killRange (Fun i a b) = killRangeN Fun i a b- killRange (Let i ds e) = killRangeN Let i ds e- killRange (Rec kwr i fs) = killRangeN Rec kwr i fs- killRange (RecUpdate kwr i e fs) = killRangeN RecUpdate kwr i e fs- killRange (ScopedExpr s e) = killRangeN (ScopedExpr s) e- killRange (Quote i) = killRangeN Quote i- killRange (QuoteTerm i) = killRangeN QuoteTerm i- killRange (Unquote i) = killRangeN Unquote i- killRange (DontCare e) = killRangeN DontCare e- killRange (PatternSyn x) = killRangeN PatternSyn x- killRange (Macro x) = killRangeN Macro x+ killRange (Var x) = killRangeN Var x+ killRange (Def' x v) = killRangeN Def' x v+ killRange (Proj o x) = killRangeN (Proj o) x+ killRange (Con x) = killRangeN Con x+ killRange (Lit i l) = killRangeN Lit i l+ killRange (QuestionMark i ii) = killRangeN QuestionMark i ii+ killRange (Underscore i) = killRangeN Underscore i+ killRange (Dot i e) = killRangeN Dot i e+ killRange (App i e1 e2) = killRangeN App i e1 e2+ killRange (WithApp i e es) = killRangeN WithApp i e es+ killRange (Lam i b e) = killRangeN Lam i b e+ killRange (AbsurdLam i h) = killRangeN AbsurdLam i h+ killRange (ExtendedLam i n e d ps) = killRangeN ExtendedLam i n e d ps+ killRange (Pi i a b) = killRangeN Pi i a b+ killRange (Generalized s x) = killRangeN (Generalized s) x+ killRange (Fun i a b) = killRangeN Fun i a b+ killRange (Let i ds e) = killRangeN Let i ds e+ killRange (Rec kwr i fs) = killRangeN Rec kwr i fs+ killRange (RecUpdate kwr i e fs) = killRangeN RecUpdate kwr i e fs+ killRange (ScopedExpr s e) = killRangeN (ScopedExpr s) e+ killRange (Quote i) = killRangeN Quote i+ killRange (QuoteTerm i) = killRangeN QuoteTerm i+ killRange (Unquote i) = killRangeN Unquote i+ killRange (DontCare e) = killRangeN DontCare e+ killRange (PatternSyn x) = killRangeN PatternSyn x+ killRange (Macro x) = killRangeN Macro x+ killRange (Qualified a b) = killRangeN Qualified a b+ killRange (Highlighted a b) = killRangeN (Highlighted a) b instance KillRange Suffix where killRange = id@@ -836,9 +856,9 @@ killRange (ScopedDecl a d ) = killRangeN (ScopedDecl a) d killRange (FunDef i a b ) = killRangeN FunDef i a b killRange (DataSig i a b c d ) = killRangeN DataSig i a b c d- killRange (DataDef i a b c d ) = killRangeN DataDef i a b c d+ killRange (DataDef i a b c d e ) = killRangeN DataDef i a b c d e killRange (RecSig i a b c d ) = killRangeN RecSig i a b c d- killRange (RecDef i a b c d e f ) = killRangeN RecDef i a b c d e f+ killRange (RecDef i a b c d e f g h) = killRangeN RecDef i a b c d e f g h killRange (PatternSynDef x xs p ) = killRangeN PatternSynDef x xs p killRange (UnquoteDecl mi i x e ) = killRangeN UnquoteDecl mi i x e killRange (UnquoteDef i x e ) = killRangeN UnquoteDef i x e@@ -900,7 +920,7 @@ instance KillRange LetBinding where killRange (LetBind i info a b c) = killRangeN LetBind i info a b c killRange (LetAxiom i a b c) = killRangeN LetAxiom i a b c- killRange (LetPatBind i a b) = killRangeN LetPatBind i a b+ killRange (LetPatBind i ai a b) = killRangeN LetPatBind i ai a b killRange (LetApply i a b c d e) = killRangeN LetApply i a b c d e killRange (LetOpen i x dir) = killRangeN LetOpen i x dir @@ -937,19 +957,23 @@ -- Precondition: The declaration has to be a (scoped) 'Axiom'. axiomName :: Declaration -> QName-axiomName (Axiom _ _ _ _ q _) = q-axiomName (ScopedDecl _ (d:_)) = axiomName d-axiomName _ = __IMPOSSIBLE__+axiomName (Axiom _ _ _ _ q _) = q+axiomName (ScopedDecl _ (d :| _)) = axiomName d+axiomName _ = __IMPOSSIBLE__ -- | Are we in an abstract block? -- -- In that case some definition is abstract. class AnyAbstract a where anyAbstract :: a -> Bool--instance AnyAbstract a => AnyAbstract [a] where+ default anyAbstract+ :: (Foldable t, AnyAbstract b, t b ~ a)+ => a -> Bool anyAbstract = Fold.any anyAbstract +instance AnyAbstract a => AnyAbstract [a]+instance AnyAbstract a => AnyAbstract (List1 a)+ instance AnyAbstract Declaration where anyAbstract (Axiom _ i _ _ _ _) = defAbstract i == AbstractDef anyAbstract (Field i _ _) = defAbstract i == AbstractDef@@ -957,8 +981,8 @@ anyAbstract (ScopedDecl _ ds) = anyAbstract ds anyAbstract (Section _ _ _ _ ds) = anyAbstract ds anyAbstract (FunDef i _ _) = defAbstract i == AbstractDef- anyAbstract (DataDef i _ _ _ _) = defAbstract i == AbstractDef- anyAbstract (RecDef i _ _ _ _ _ _) = defAbstract i == AbstractDef+ anyAbstract (DataDef i _ _ _ _ _) = defAbstract i == AbstractDef+ anyAbstract (RecDef i _ _ _ _ _ _ _ _) = defAbstract i == AbstractDef anyAbstract (DataSig i _ _ _ _) = defAbstract i == AbstractDef anyAbstract (RecSig i _ _ _ _) = defAbstract i == AbstractDef anyAbstract _ = __IMPOSSIBLE__@@ -1001,9 +1025,9 @@ nameToExpr = \case VarName x _ -> Var x DefinedName _ x s -> withSuffix s $ nameToExpr x -- Can be 'isDefName', 'MacroName', 'QuotableName'.- FieldName xs -> Proj ProjSystem . AmbQ . fmap anameName $ xs- ConstructorName _ xs -> Con . AmbQ . fmap anameName $ xs- PatternSynResName xs -> PatternSyn . AmbQ . fmap anameName $ xs+ FieldName xs -> Proj ProjSystem . ambigName $ xs+ ConstructorName _ xs -> Con . ambigName $ xs+ PatternSynResName xs -> PatternSyn . ambigName $ xs UnknownName -> __IMPOSSIBLE__ where withSuffix NoSuffix e = e@@ -1017,7 +1041,14 @@ mkLet _ [] e = e mkLet i (d:ds) e = Let i (d :| ds) e -type PatternSynDefn = ([WithHiding Name], Pattern' Void)+-- | The definition of a pattern synonym (excluding its name).+data PatternSynDefn = PatternSynDefn+ { patSynParams :: ![WithHiding Name]+ -- ^ The parameters of the pattern synonym.+ , patSynPat :: !(Pattern' Void)+ -- ^ The definiting pattern of the pattern synonym.+ } deriving (Show, Generic)+ type PatternSynDefns = Map QName PatternSynDefn lambdaLiftExpr :: [WithHiding Name] -> Expr -> Expr@@ -1068,23 +1099,29 @@ App i e e' -> App i (substExpr s e) (substExpr s e') Rec kwr i nes -> Rec kwr i (substExpr s nes) ScopedExpr si e -> ScopedExpr si (substExpr s e)++ -- At the moment we only generate this for @do@, so it can't appear+ -- in a pattern synonym right-hand side, but this is future-proof.+ Qualified q e -> Qualified q (substExpr s e)+ -- The below cannot appear in pattern synonym right-hand sides- QuestionMark{} -> __IMPOSSIBLE__- Dot{} -> __IMPOSSIBLE__- WithApp{} -> __IMPOSSIBLE__- Lam{} -> __IMPOSSIBLE__- AbsurdLam{} -> __IMPOSSIBLE__- ExtendedLam{} -> __IMPOSSIBLE__- Pi{} -> __IMPOSSIBLE__- Generalized{} -> __IMPOSSIBLE__- Fun{} -> __IMPOSSIBLE__- Let{} -> __IMPOSSIBLE__- RecUpdate{} -> __IMPOSSIBLE__- Quote{} -> __IMPOSSIBLE__- QuoteTerm{} -> __IMPOSSIBLE__- Unquote{} -> __IMPOSSIBLE__- DontCare{} -> __IMPOSSIBLE__- Macro{} -> __IMPOSSIBLE__+ QuestionMark{} -> __IMPOSSIBLE__+ Dot{} -> __IMPOSSIBLE__+ WithApp{} -> __IMPOSSIBLE__+ Lam{} -> __IMPOSSIBLE__+ AbsurdLam{} -> __IMPOSSIBLE__+ ExtendedLam{} -> __IMPOSSIBLE__+ Pi{} -> __IMPOSSIBLE__+ Generalized{} -> __IMPOSSIBLE__+ Fun{} -> __IMPOSSIBLE__+ Let{} -> __IMPOSSIBLE__+ RecUpdate{} -> __IMPOSSIBLE__+ Quote{} -> __IMPOSSIBLE__+ QuoteTerm{} -> __IMPOSSIBLE__+ Unquote{} -> __IMPOSSIBLE__+ DontCare{} -> __IMPOSSIBLE__+ Macro{} -> __IMPOSSIBLE__+ Highlighted{} -> __IMPOSSIBLE__ -- TODO: more informative failure insertImplicitPatSynArgs :: forall a. HasRange a@@ -1120,9 +1157,9 @@ -> [WithHiding Name] -> [NamedArg a] -> Maybe ([(Name, a)], [WithHiding Name])- matchArgs r [] [] = return ([], [])- matchArgs r [] as = Nothing- matchArgs r (n:ns) [] | visible n = return ([], n : ns) -- under-applied+ matchArgs _ [] [] = return ([], [])+ matchArgs _ [] (_:_) = Nothing+ matchArgs _ (n:ns) [] | visible n = return ([], n : ns) -- under-applied matchArgs r (n:ns) as = do (p, as) <- matchNextArg r n as first ((whThing n, p) :) <$> matchArgs (getRange p) ns as@@ -1139,13 +1176,13 @@ | GeneralizeS | FieldS | PrimitiveS- | MutualS [DeclarationSpine]+ | MutualS (List1 DeclarationSpine) | SectionS [DeclarationSpine] | ApplyS | ImportS | PragmaS | OpenS- | FunDefS [ClauseSpine]+ | FunDefS (List1 ClauseSpine) | DataSigS | DataDefS | RecSigS@@ -1154,7 +1191,7 @@ | UnquoteDeclS | UnquoteDefS | UnquoteDataS- | ScopedDeclS [DeclarationSpine]+ | ScopedDeclS (List1 DeclarationSpine) | UnfoldingDeclS deriving Show @@ -1185,22 +1222,22 @@ Generalize _ _ _ _ _ -> GeneralizeS Field _ _ _ -> FieldS Primitive _ _ _ -> PrimitiveS- Mutual _ ds -> MutualS (map declarationSpine ds)+ Mutual _ ds -> MutualS (fmap declarationSpine ds) Section _ _ _ _ ds -> SectionS (map declarationSpine ds) Apply _ _ _ _ _ _ -> ApplyS Import _ _ _ -> ImportS Pragma _ _ -> PragmaS Open _ _ _ -> OpenS- FunDef _ _ cs -> FunDefS (map clauseSpine cs)+ FunDef _ _ cs -> FunDefS (fmap clauseSpine cs) DataSig _ _ _ _ _ -> DataSigS- DataDef _ _ _ _ _ -> DataDefS+ DataDef _ _ _ _ _ _ -> DataDefS RecSig _ _ _ _ _ -> RecSigS- RecDef _ _ _ _ _ _ ds -> RecDefS (map declarationSpine ds)+ RecDef _ _ _ _ _ _ _ _ ds -> RecDefS (map declarationSpine ds) PatternSynDef _ _ _ -> PatternSynDefS UnquoteDecl _ _ _ _ -> UnquoteDeclS UnquoteDef _ _ _ -> UnquoteDefS UnquoteData _ _ _ _ _ _ -> UnquoteDataS- ScopedDecl _ ds -> ScopedDeclS (map declarationSpine ds)+ ScopedDecl _ ds -> ScopedDeclS (fmap declarationSpine ds) UnfoldingDecl _ _ -> UnquoteDeclS -- | The clause spine corresponding to a clause.@@ -1224,3 +1261,10 @@ whereDeclarationsSpine :: WhereDeclarations -> WhereDeclarationsSpine whereDeclarationsSpine (WhereDecls _ _ md) = WhereDeclsS (fmap declarationSpine md)++-- Instances++instance KillRange PatternSynDefn where+ killRange (PatternSynDefn a b) = killRangeN PatternSynDefn a b++instance NFData PatternSynDefn
src/full/Agda/Syntax/Abstract/Name.hs view
@@ -16,41 +16,60 @@ import Data.Hashable (Hashable(..)) import qualified Data.List as List import Data.Maybe+import Data.Map (Map) import Data.Void +import GHC.Generics (Generic)+ import Agda.Syntax.Position import Agda.Syntax.Common import Agda.Syntax.Common.Pretty import Agda.Syntax.Concrete.Name (IsNoName(..), NumHoles(..), NameInScope(..), LensInScope(..), FreshNameMode(..)) import qualified Agda.Syntax.Concrete.Name as C +import Data.Set (Set)+import Data.Set qualified as Set+import Data.Map (Map)+import Data.Map qualified as Map+ import Agda.Utils.Functor import Agda.Utils.Lens-import qualified Agda.Utils.List as L+import Agda.Utils.List qualified as List import Agda.Utils.List1 (List1, pattern (:|), (<|))-import qualified Agda.Utils.List1 as List1+import Agda.Utils.List1 qualified as List1+import Agda.Utils.Map1 (Map1)+import Agda.Utils.Map1 qualified as Map1+import Agda.Utils.Maybe ( unionMaybeWith ) import Agda.Utils.Null+import Agda.Utils.Singleton import Agda.Utils.Size +import qualified Agda.Syntax.Common.Aspect as Asp import Agda.Utils.Impossible +---------------------------------------------------------------------------+-- * Types+---------------------------------------------------------------------------+ -- | A name is a unique identifier and a suggestion for a concrete name. The -- concrete name contains the source location (if any) of the name. The -- source location of the binding site is also recorded. data Name = Name- { nameId :: !NameId+ { _nameId :: {-# UNPACK #-} !NameId , nameConcrete :: C.Name -- ^ The concrete name used for this instance , nameCanonical :: C.Name -- ^ The concrete name in the original definition (needed by primShowQName, see #4735)- , nameBindingSite :: Range+ , _nameBindingSite :: Range -- ^ Range of the name in its /defining/ occurrence. , nameFixity :: Fixity' , nameIsRecordName :: Bool -- ^ Is this the name of the invisible record variable `self`? -- Should not be printed or displayed in the context, see issue #3584. } --- | Useful for debugging scoping problems-uglyShowName :: Name -> String-uglyShowName x = show (nameId x, nameConcrete x)+-- | A name suffix.+data Suffix+ = NoSuffix+ | Suffix !Integer+ deriving (Show, Eq, Ord) -- | Qualified names are non-empty lists of names. Equality on qualified names -- are just equality on the last name, i.e. the module part is just@@ -58,10 +77,21 @@ -- -- The 'SetRange' instance for qualified names sets all individual -- ranges (including those of the module prefix) to the given one.-data QName = QName { qnameModule :: ModuleName- , qnameName :: Name- }+data QName = QName+ { qnameModule :: ModuleName+ , qnameName :: Name+ } deriving (Generic) +{-# SPECIALIZE Set.insert :: QName -> Set QName -> Set QName #-}+{-# SPECIALIZE Set.delete :: QName -> Set QName -> Set QName #-}+{-# SPECIALIZE Set.member :: QName -> Set QName -> Bool #-}+{-# SPECIALIZE Set.fromList :: [QName] -> Set QName #-}++{-# SPECIALIZE Map.insert :: QName -> v -> Map QName v -> Map QName v #-}+{-# SPECIALIZE Map.lookup :: QName -> Map QName v -> Maybe v #-}+{-# SPECIALIZE Map.delete :: QName -> Map QName v -> Map QName v #-}+{-# SPECIALIZE Map.fromList :: [(QName, v)] -> Map QName v #-}+ -- | Something preceeded by a qualified name. data QNamed a = QNamed { qname :: QName@@ -74,45 +104,136 @@ -- The 'SetRange' instance for module names sets all individual ranges -- to the given one. newtype ModuleName = MName { mnameToList :: [Name] }- deriving (Eq, Ord, NFData, Null)+ deriving (Eq, Ord, NFData, Null, Hashable) -- | Ambiguous qualified names. Used for overloaded constructors. ----- Invariant: All the names in the list must have the same concrete,+-- A 'QName' in this collection might be equipped with lineage information+-- in form of an associated 'AbstractName' (which must contain the same 'QName').+--+-- Invariant: All the names in the map 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, NFData)+--+-- Don't use the constructor 'AmbQ' directly, use the smart constructors below!+newtype AmbiguousQName = AmbQ { unAmbQ :: Map1 NameId AmbQNameEntry }+ deriving (Eq, Ord, NFData, Sized) --- | A singleton "ambiguous" name.-unambiguous :: QName -> AmbiguousQName-unambiguous x = AmbQ (x :| [])+-- | Alternative in 'AmbiguousQName'.+data AmbQNameEntry+ = AmbQName QName+ -- ^ 'QName' without lineage information.+ | AmbAbstractName AbstractName+ -- ^ 'QName' with lineage information, for error reporting.+ deriving (Eq, Ord, Show, Generic) --- | Get the first of the ambiguous names.-headAmbQ :: AmbiguousQName -> QName-headAmbQ (AmbQ xs) = List1.head xs+-- | A decoration of 'Agda.Syntax.Abstract.Name.QName'.+data AbstractName = AbsName+ { anameName :: QName+ -- ^ The resolved qualified name.+ , anameKind :: KindOfName+ -- ^ The kind (definition, constructor, record field etc.).+ , anameLineage :: WhyInScope+ -- ^ Explanation where this name came from.+ , anameMetadata :: NameMetadata+ -- ^ Additional information needed during scope checking. Currently used+ -- for generalized data/record params.+ }+ deriving (Show, Generic) --- | Is a name ambiguous.-isAmbiguous :: AmbiguousQName -> Bool-isAmbiguous (AmbQ (_ :| xs)) = not (null xs)+-- | A decoration of abstract syntax module names.+data AbstractModule = AbsModule+ { amodName :: ModuleName+ -- ^ The resolved module name.+ , amodLineage :: WhyInScope+ -- ^ Explanation where this name came from.+ }+ deriving (Show, Generic) --- | Get the name if unambiguous.-getUnambiguous :: AmbiguousQName -> Maybe QName-getUnambiguous (AmbQ (x :| [])) = Just x-getUnambiguous _ = Nothing+-- | For the sake of parsing left-hand sides, we distinguish+-- constructor and record field names from defined names. --- | A name suffix-data Suffix- = NoSuffix- | Suffix !Integer- deriving (Show, Eq, Ord)+-- Note: order does matter in this enumeration, see 'isDefName'.+data KindOfName+ = ConName -- ^ Constructor name ('Inductive' or don't know).+ | CoConName -- ^ Constructor name (definitely 'CoInductive').+ | FldName -- ^ Record field name.+ | PatternSynName -- ^ Name of a pattern synonym.+ | GeneralizeName -- ^ Name to be generalized+ | DisallowedGeneralizeName -- ^ Generalizable variable from a let open+ | MacroName -- ^ Name of a macro+ | QuotableName -- ^ A name that can only be quoted.+ -- Previous category @DefName@:+ -- (Refined in a flat manner as Enum and Bounded are not hereditary.)+ | DataName -- ^ Name of a @data@.+ | RecName -- ^ Name of a @record@.+ | FunName -- ^ Name of a defined function.+ | AxiomName -- ^ Name of a @postulate@.+ | 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, Enum, Bounded, Generic) -instance Null Suffix where- empty = NoSuffix+-- | Where does a name come from?+--+-- This information is solely for reporting to the user,+-- see 'Agda.Interaction.InteractionTop.whyInScope'.+data WhyInScope+ = Defined+ -- ^ Defined in this module.+ | Opened C.QName WhyInScope+ -- ^ Imported from another module.+ | Applied C.QName WhyInScope+ -- ^ Imported by a module application.+ deriving (Show, Generic) -instance NFData Suffix where- rnf NoSuffix = ()- rnf (Suffix _) = ()+data NameMetadata = NameMetadata+ { nameDataGeneralizedVars :: Map QName Name+ , nameDataIsInstance :: IsInstance+ }+ deriving (Show, Generic) +---------------------------------------------------------------------------+-- * Overloaded 'nameId'+---------------------------------------------------------------------------++class HasNameId a where+ nameId :: a -> NameId++instance HasNameId Name where+ nameId = _nameId++instance HasNameId QName where+ nameId = nameId . qnameName++instance HasNameId AbstractName where+ nameId = nameId . anameName++---------------------------------------------------------------------------+-- * Overloaded 'nameBindingSite'+---------------------------------------------------------------------------++class HasNameBindingSite a where+ nameBindingSite :: a -> Range++instance HasNameBindingSite Name where+ nameBindingSite = _nameBindingSite++instance HasNameBindingSite QName where+ nameBindingSite = nameBindingSite . qnameName++instance HasNameBindingSite ModuleName where+ nameBindingSite = nameBindingSite . mnameToQName++instance HasNameBindingSite AbstractName where+ nameBindingSite = nameBindingSite . anameName++instance HasNameBindingSite AbstractModule where+ nameBindingSite = nameBindingSite . amodName++---------------------------------------------------------------------------+-- * Class 'IsProjP'+---------------------------------------------------------------------------+ -- | Check whether we are a projection pattern. class IsProjP a where isProjP :: a -> Maybe (ProjOrigin, AmbiguousQName)@@ -129,9 +250,41 @@ instance IsProjP Void where isProjP _ = __IMPOSSIBLE__ +---------------------------------------------------------------------------+-- * 'Name'+---------------------------------------------------------------------------++-- | Make a 'Name' from some kind of string.+class MkName a where+ -- | The 'Range' sets the /definition site/ of the name, not the use site.+ mkName :: Range -> NameId -> a -> Name++ mkName_ :: NameId -> a -> Name+ mkName_ = mkName noRange++instance MkName String where+ mkName r i s = makeName i (C.Name noRange InScope (C.stringNameParts s)) r noFixity' False++makeName :: NameId -> C.Name -> Range -> Fixity' -> Bool -> Name+makeName i c r f rec = Name i c c r f rec++nameToArgName :: Name -> ArgName+nameToArgName = stringToArgName . prettyShow++namedArgName :: NamedArg Name -> ArgName+namedArgName x = fromMaybe (nameToArgName $ namedArg x) $ bareNameOf x++-- | Ignoring the suffix.+sameRoot :: Name -> Name -> Bool+sameRoot = C.sameRoot `on` nameConcrete++---------------------------------------------------------------------------+-- * 'ModuleName'+---------------------------------------------------------------------------+ -- | A module is anonymous if the qualification path ends in an underscore. isAnonymousModuleName :: ModuleName -> Bool-isAnonymousModuleName (MName mms) = maybe False isNoName $ L.lastMaybe mms+isAnonymousModuleName (MName mms) = maybe False isNoName $ List.lastMaybe mms -- | Sets the ranges of the individual names in the module name to -- match those of the corresponding concrete names. If the concrete@@ -177,22 +330,42 @@ commonParentModule :: ModuleName -> ModuleName -> ModuleName commonParentModule m1 m2 =- mnameFromList $ L.commonPrefix (mnameToList m1) (mnameToList m2)+ mnameFromList $ List.commonPrefix (mnameToList m1) (mnameToList m2) --- | Make a 'Name' from some kind of string.-class MkName a where- -- | The 'Range' sets the /definition site/ of the name, not the use site.- mkName :: Range -> NameId -> a -> Name+mnameToConcrete :: ModuleName -> C.QName+mnameToConcrete (MName []) = __IMPOSSIBLE__ -- C.QName C.noName_ -- should never happen?+mnameToConcrete (MName (x:xs)) = foldr C.Qual (C.QName $ List1.last cs) $ List1.init cs+ where+ cs = fmap nameConcrete (x :| xs) - mkName_ :: NameId -> a -> Name- mkName_ = mkName noRange+qualifyM :: ModuleName -> ModuleName -> ModuleName+qualifyM m1 m2 = mnameFromList $ mnameToList m1 ++ mnameToList m2 -instance MkName String where- mkName r i s = makeName i (C.Name noRange InScope (C.stringNameParts s)) r noFixity' False+-- | Is the first module a weak parent of the second?+isLeParentModuleOf :: ModuleName -> ModuleName -> Bool+isLeParentModuleOf = List.isPrefixOf `on` mnameToList -makeName :: NameId -> C.Name -> Range -> Fixity' -> Bool -> Name-makeName i c r f rec = Name i c c r f rec+-- | Is the first module a proper parent of the second?+isLtParentModuleOf :: ModuleName -> ModuleName -> Bool+isLtParentModuleOf x y =+ isJust $ (List.stripPrefixBy (==) `on` mnameToList) x y +-- | Is the first module a weak child of the second?+isLeChildModuleOf :: ModuleName -> ModuleName -> Bool+isLeChildModuleOf = flip isLeParentModuleOf++-- | Is the first module a proper child of the second?+isLtChildModuleOf :: ModuleName -> ModuleName -> Bool+isLtChildModuleOf = flip isLtParentModuleOf++-- | Drop anonymous modules at the end of the module name+dropAnonymousModules :: ModuleName -> ModuleName+dropAnonymousModules (MName ms) = MName $ List.dropWhileEnd isNoName ms++---------------------------------------------------------------------------+-- * 'QName'+---------------------------------------------------------------------------+ qnameToList0 :: QName -> [Name] qnameToList0 = List1.toList . qnameToList @@ -220,15 +393,6 @@ qnameToConcrete (QName m x) = -- Use the canonical name here (#5048) foldr (C.Qual . nameConcrete) (C.QName $ nameCanonical x) (mnameToList m) -mnameToConcrete :: ModuleName -> C.QName-mnameToConcrete (MName []) = __IMPOSSIBLE__ -- C.QName C.noName_ -- should never happen?-mnameToConcrete (MName (x:xs)) = foldr C.Qual (C.QName $ List1.last cs) $ List1.init cs- where- cs = fmap nameConcrete (x :| xs)--qualifyM :: ModuleName -> ModuleName -> ModuleName-qualifyM m1 m2 = mnameFromList $ mnameToList m1 ++ mnameToList m2- qualifyQ :: ModuleName -> QName -> QName qualifyQ m x = qnameFromList $ mnameToList m `List1.prependList` qnameToList x @@ -244,23 +408,6 @@ isOperator :: QName -> Bool isOperator = C.isOperator . nameConcrete . qnameName --- | Is the first module a weak parent of the second?-isLeParentModuleOf :: ModuleName -> ModuleName -> Bool-isLeParentModuleOf = List.isPrefixOf `on` mnameToList---- | Is the first module a proper parent of the second?-isLtParentModuleOf :: ModuleName -> ModuleName -> Bool-isLtParentModuleOf x y =- isJust $ (L.stripPrefixBy (==) `on` mnameToList) x y---- | Is the first module a weak child of the second?-isLeChildModuleOf :: ModuleName -> ModuleName -> Bool-isLeChildModuleOf = flip isLeParentModuleOf---- | Is the first module a proper child of the second?-isLtChildModuleOf :: ModuleName -> ModuleName -> Bool-isLtChildModuleOf = flip isLtParentModuleOf- isInModule :: QName -> ModuleName -> Bool isInModule q m = mnameToList m `List.isPrefixOf` qnameToList0 q @@ -269,14 +416,90 @@ nextName :: C.FreshNameMode -> Name -> Name nextName freshNameMode x = x { nameConcrete = C.nextName freshNameMode (nameConcrete x) } -sameRoot :: Name -> Name -> Bool-sameRoot = C.sameRoot `on` nameConcrete+---------------------------------------------------------------------------+-- * 'AmbiguousQName'+--------------------------------------------------------------------------- ---------------------------------------------------------------------------- * Important instances: Eq, Ord, Hashable+fromAmbQName :: AmbQNameEntry -> QName+fromAmbQName = \case+ AmbQName x -> x+ AmbAbstractName x -> anameName x++-- | A singleton "ambiguous" name.+unambiguous :: QName -> AmbiguousQName+unambiguous = ambiguous . singleton++ambiguous :: List1 QName -> AmbiguousQName+ambiguous = AmbQ . Map1.fromList . fmap \ x -> (nameId x, AmbQName x)++-- | Get the first of the ambiguous names.+headAmbQ :: AmbiguousQName -> QName+headAmbQ = List1.head . getAmbiguous++-- | Is a name ambiguous.+isAmbiguous :: AmbiguousQName -> Bool+isAmbiguous (AmbQ m) = size m > 1++-- | Get the name if unambiguous.+getUnambiguous :: AmbiguousQName -> Maybe QName+getUnambiguous m+ | size m == 1 = Just $ headAmbQ m+ | otherwise = Nothing++getAmbiguous :: AmbiguousQName -> List1 QName+getAmbiguous = fmap fromAmbQName . Map1.elems . unAmbQ++ambAbstractNames :: AmbiguousQName -> [AbstractName]+ambAbstractNames (AmbQ xs) = (`List1.mapMaybe` Map1.elems xs) \case+ AmbQName{} -> Nothing+ AmbAbstractName x -> Just x++unambigName :: AbstractName -> AmbiguousQName+unambigName = ambigName . singleton++ambigName :: List1 AbstractName -> AmbiguousQName+ambigName = AmbQ . Map1.fromList . fmap \ x -> (nameId x, AmbAbstractName x)++-- | Preserve lineage information from both maps, left-biased.+mergeAmbQ :: AmbiguousQName -> AmbiguousQName -> AmbiguousQName+mergeAmbQ (AmbQ xs) (AmbQ ys) = AmbQ (Map1.unionWith (<>) xs ys)++-- | Prefer 'AmbAbstractName' over 'AmbQName', left-biased.+instance Semigroup AmbQNameEntry where+ x@AmbAbstractName{} <> _ = x+ _ <> y@AmbAbstractName{} = y+ x <> _ = x++---------------------------------------------------------------------------+-- * 'AbstractName'+---------------------------------------------------------------------------++---------------------------------------------------------------------------+-- * 'NameMetadata'+---------------------------------------------------------------------------++noMetadata :: NameMetadata+noMetadata = empty++generalizedVarsMetadata :: Map QName Name -> NameMetadata+generalizedVarsMetadata m = NameMetadata m empty++instanceMetadata :: IsInstance -> NameMetadata+instanceMetadata i = NameMetadata empty i++instance IsInstanceDef NameMetadata where+ isInstanceDef = isInstanceDef . nameDataIsInstance++instance IsInstanceDef AbstractName where+ isInstanceDef = isInstanceDef . anameMetadata++---------------------------------------------------------------------------+-- * Instances+---------------------------------------------------------------------------++-- | Important instances: 'Eq', 'Ord', 'Hashable' -- -- For the identity and comparing of names, only the 'NameId' matters!------------------------------------------------------------------------- instance Eq Name where (==) = (==) `on` nameId@@ -288,6 +511,8 @@ {-# INLINE hashWithSalt #-} hashWithSalt salt = hashWithSalt salt . nameId +-- QName+ instance Eq QName where (==) = (==) `on` qnameName @@ -298,8 +523,27 @@ {-# INLINE hashWithSalt #-} hashWithSalt salt = hashWithSalt salt . qnameName +-- AbstractName++instance Eq AbstractName where+ (==) = (==) `on` anameName++instance Ord AbstractName where+ compare = compare `on` anameName++instance Hashable AbstractName where+ hashWithSalt salt = hashWithSalt salt . anameName++-- AbstractModule++instance Eq AbstractModule where+ (==) = (==) `on` amodName++instance Ord AbstractModule where+ compare = compare `on` amodName+ --------------------------------------------------------------------------- * IsNoName instances (checking for "_")+-- 'IsNoName' and 'Null' instances (checking for "_") ------------------------------------------------------------------------ -- | An abstract name is empty if its concrete name is empty.@@ -309,6 +553,25 @@ instance IsNoName ModuleName where isNoName (MName xs) = all isNoName xs +instance Null Name where+ empty = Name empty empty empty empty empty empty+ null = isNoName++instance Null QName where+ empty = QName empty empty+ null (QName m x) = null m && null x++instance Null Suffix where+ empty = NoSuffix++instance Null NameMetadata where+ empty = NameMetadata empty empty+ null (NameMetadata m i) = null m && null i++------------------------------------------------------------------------+-- 'NumHoles' instances+------------------------------------------------------------------------+ instance NumHoles Name where numHoles = numHoles . nameConcrete @@ -320,14 +583,22 @@ numHoles = numHoles . headAmbQ --------------------------------------------------------------------------- * name lenses+-- Name lenses ------------------------------------------------------------------------ lensQNameName :: Lens' QName Name lensQNameName f (QName m n) = QName m <$> f n +-- | Van Laarhoven lens on 'anameName'.+lensAnameName :: Lens' AbstractName QName+lensAnameName f am = f (anameName am) <&> \ m -> am { anameName = m }++-- | Van Laarhoven lens on 'amodName'.+lensAmodName :: Lens' AbstractModule ModuleName+lensAmodName f am = f (amodName am) <&> \ m -> am { amodName = m }+ --------------------------------------------------------------------------- * LensFixity' instances+-- LensFixity' instances ------------------------------------------------------------------------ instance LensFixity' Name where@@ -337,7 +608,7 @@ lensFixity' = lensQNameName . lensFixity' --------------------------------------------------------------------------- * LensFixity instances+-- LensFixity instances ------------------------------------------------------------------------ instance LensFixity Name where@@ -346,8 +617,11 @@ instance LensFixity QName where lensFixity = lensFixity' . lensFixity +instance LensFixity AbstractName where+ lensFixity = lensAnameName . lensFixity+ --------------------------------------------------------------------------- * LensInScope instances+-- LensInScope instances ------------------------------------------------------------------------ instance LensInScope Name where@@ -359,9 +633,9 @@ (\n' -> q { qnameName = n' }) <$> lensInScope f n --------------------------------------------------------------------------- * Show instances (only for debug printing!)+-- | Show instances (only for debug printing!) ----- | Use 'prettyShow' to print names to the user.+-- Use 'prettyShow' to print names to the user. ------------------------------------------------------------------------ deriving instance Show Name@@ -370,18 +644,16 @@ deriving instance Show a => Show (QNamed a) deriving instance Show AmbiguousQName -nameToArgName :: Name -> ArgName-nameToArgName = stringToArgName . prettyShow--namedArgName :: NamedArg Name -> ArgName-namedArgName x = fromMaybe (nameToArgName $ namedArg x) $ bareNameOf x+-- | Useful for debugging scoping problems+uglyShowName :: Name -> String+uglyShowName x = show (nameId x, nameConcrete x) --------------------------------------------------------------------------- * Pretty instances+-- Pretty instances ------------------------------------------------------------------------ instance Pretty Name where- pretty = pretty . nameConcrete+ pretty n = pretty (nameConcrete n) `definedAt` (nameBindingSite n) instance Pretty ModuleName where pretty = hcat . punctuate "." . map pretty . mnameToList@@ -394,16 +666,26 @@ useCanonical q = q { qnameName = (qnameName q) { nameConcrete = nameCanonical (qnameName q) } } instance Pretty AmbiguousQName where- pretty (AmbQ qs) = hcat $ punctuate " | " $ map pretty $ List1.toList qs+ pretty qs = hcat $ punctuate " | " $ fmap pretty $ getAmbiguous qs instance Pretty a => Pretty (QNamed a) where pretty (QNamed a b) = pretty a <> "." <> pretty b +instance Pretty Suffix where+ pretty NoSuffix = mempty+ pretty (Suffix i) = text (show i)++instance Pretty AbstractName where+ pretty = pretty . anameName++instance Pretty AbstractModule where+ pretty = pretty . amodName+ --------------------------------------------------------------------------- * Range instances+-- Range instances ------------------------------------------------------------------------ --- ** HasRange+-- HasRange instance HasRange Name where getRange = getRange . nameConcrete@@ -418,10 +700,15 @@ -- | The range of an @AmbiguousQName@ is the range of any of its -- disambiguations (they are the same concrete name). instance HasRange AmbiguousQName where- getRange (AmbQ (c :| _)) = getRange c+ getRange = getRange . headAmbQ --- ** SetRange+instance HasRange AmbQNameEntry where+ getRange = \case+ AmbQName x -> getRange x+ AmbAbstractName x -> getRange x +-- SetRange+ instance SetRange Name where setRange r x = x { nameConcrete = setRange r $ nameConcrete x } @@ -438,11 +725,11 @@ -- the parts (See #2666). rs = replicate (length ns - 1) noRange ++ [r] --- ** KillRange+-- KillRange instance KillRange Name where killRange (Name a b c d e f) =- (killRangeN Name a b c d e f) { nameBindingSite = d }+ (killRangeN Name a b c d e f) { _nameBindingSite = d } -- Andreas, 2017-07-25, issue #2649 -- Preserve the nameBindingSite for error message. --@@ -468,8 +755,38 @@ instance KillRange AmbiguousQName where killRange (AmbQ xs) = AmbQ $ killRange xs +instance KillRange AmbQNameEntry where+ killRange = \case+ AmbQName x -> killRangeN AmbQName x+ AmbAbstractName x -> killRangeN AmbAbstractName x++instance KillRange AbstractName where+ killRange (AbsName a b c d) = killRangeN AbsName a b c d++instance KillRange KindOfName where+ killRange = id++instance KillRange WhyInScope where+ killRange = \case+ Defined -> Defined+ Opened a b -> killRangeN Opened a b+ Applied a b -> killRangeN Applied a b++instance KillRange NameMetadata where+ killRange = \case+ NameMetadata a b -> killRangeN NameMetadata a b+++-- AbstractName++instance HasRange AbstractName where+ getRange = getRange . anameName++instance SetRange AbstractName where+ setRange r x = x { anameName = setRange r $ anameName x }+ --------------------------------------------------------------------------- * Sized instances+-- Sized instances ------------------------------------------------------------------------ instance Sized QName where@@ -481,7 +798,7 @@ natSize = natSize . mnameToList --------------------------------------------------------------------------- * NFData instances+-- NFData instances ------------------------------------------------------------------------ -- | The range is not forced.@@ -489,5 +806,14 @@ instance NFData Name where rnf (Name _ a b _ c d) = rnf (a, b, c, d) -instance NFData QName where- rnf (QName a b) = rnf a `seq` rnf b+instance NFData Suffix where+ rnf NoSuffix = ()+ rnf (Suffix _) = ()++instance NFData AbstractModule+instance NFData AbstractName+instance NFData AmbQNameEntry+instance NFData KindOfName+instance NFData NameMetadata+instance NFData QName+instance NFData WhyInScope
src/full/Agda/Syntax/Abstract/Pattern.hs view
@@ -7,7 +7,6 @@ import Prelude hiding (null) -import Control.Arrow ( (***), second ) import Control.Monad ( (>=>) ) import Control.Monad.Identity ( Identity(..), runIdentity ) import Control.Monad.Reader ( Reader, runReader, asks, local )@@ -31,6 +30,7 @@ import qualified Agda.Utils.List1 as List1 import Agda.Utils.Null import Agda.Utils.Singleton+import Agda.Utils.Tuple ( (***), second ) import Agda.Utils.Impossible @@ -397,7 +397,7 @@ -- -- Return the view and the remaining patterns. -lhsPatternView :: IsProjP e => NAPs e -> Maybe (LHSPatternView e, NAPs e)+lhsPatternView :: NAPs e -> Maybe (LHSPatternView e, NAPs e) lhsPatternView [] = Nothing lhsPatternView (p0 : ps) = case namedArg p0 of@@ -458,7 +458,7 @@ lhsCoreWith (LHSWith core wps []) wps' = LHSWith core (wps <> wps') [] lhsCoreWith core wps' = LHSWith core wps' [] -lhsCoreAddChunk :: IsProjP e => LHSCore' e -> LHSPatternView e -> LHSCore' e+lhsCoreAddChunk :: LHSCore' e -> LHSPatternView e -> LHSCore' e lhsCoreAddChunk core = \case LHSAppP ps -> lhsCoreApp core $ List1.toList ps LHSWithP wps -> lhsCoreWith core (defaultArg <$> wps)
src/full/Agda/Syntax/Abstract/PatternSynonyms.hs view
@@ -23,7 +23,6 @@ import Agda.Syntax.Abstract.Views import Agda.Utils.List1 (List1, pattern (:|))-import qualified Agda.Utils.List1 as List1 -- | Merge a list of pattern synonym definitions. Fails unless all definitions -- have the same shape (i.e. equal up to renaming of variables and constructor@@ -32,31 +31,36 @@ mergePatternSynDefs (def :| defs) = foldM mergeDef def defs mergeDef :: PatternSynDefn -> PatternSynDefn -> Maybe PatternSynDefn-mergeDef (xs, p) (ys, q) = do+mergeDef (PatternSynDefn xs p) (PatternSynDefn ys q) = do+ -- Ensure that the parameter lists are equal up to renaming. guard $ map whHiding xs == map whHiding ys- let ren = zip (map whThing xs) (map whThing ys)- (xs,) <$> merge ren p q+ PatternSynDefn xs <$> merge p q where- merge ren p@(VarP x) (VarP y) = p <$ guard ((unBind x, unBind y) `elem` ren)- merge ren p@(LitP _ l) (LitP _ l') = p <$ guard (l == l')- merge ren p@(WildP _) (WildP _) = return p- merge ren (ConP i (AmbQ cs) ps) (ConP _ (AmbQ cs') qs) = do+ ren = zip (map whThing xs) (map whThing ys)++ merge :: Pattern' e -> Pattern' e -> Maybe (Pattern' e)+ merge p@(VarP x) (VarP y) = p <$ guard ((unBind x, unBind y) `elem` ren)+ merge p@(LitP _ l) (LitP _ l') = p <$ guard (l == l')+ merge p@(WildP _) (WildP _) = return p+ merge (ConP i ambC ps) (ConP _ ambC' qs) = do guard $ map getArgInfo ps == map getArgInfo qs- ConP i (AmbQ $ List1.union cs cs') <$> zipWithM (mergeArg ren) ps qs- merge _ _ _ = empty+ ConP i (mergeAmbQ ambC ambC') <$> zipWithM mergeArg ps qs+ merge _ _ = empty - mergeArg ren p q = setNamedArg p <$> merge ren (namedArg p) (namedArg q)+ mergeArg :: NamedArg (Pattern' e) -> NamedArg (Pattern' e) -> Maybe (NamedArg (Pattern' e))+ mergeArg p q = setNamedArg p <$> merge (namedArg p) (namedArg q) -- | Match an expression against a pattern synonym. matchPatternSyn :: PatternSynDefn -> Expr -> Maybe [WithHiding Expr] matchPatternSyn = runMatch match where- match (VarP x) e = unBind x ==> e+ match :: Pattern' e -> Expr -> WriterT (Map Name Expr) Maybe ()+ match (VarP x) e = x ==> e match (LitP _ l) (Lit _ l') = guard (l == l')- match (ConP _ (AmbQ cs) ps) e = do- Application (Con (AmbQ cs')) args <- return (appView e)- guard $ all (`elem` cs) cs' -- check all possible constructors appear in the synonym- guard $ map getArgInfo ps == map getArgInfo args -- check that we agree on the hiding (TODO: too strict?)+ match (ConP _ x ps) e = do+ Application (Con x') args <- return (appView e)+ guard $ allPossibleConstructorsAppearInSynonym x x' -- check all possible constructors appear in the synonym+ guard $ map getArgInfo ps == map getArgInfo args -- check that we agree on the hiding (TODO: too strict?) zipWithM_ match (map namedArg ps) (map namedArg args) match _ _ = empty @@ -64,21 +68,24 @@ matchPatternSynP :: PatternSynDefn -> Pattern' e -> Maybe [WithHiding (Pattern' e)] matchPatternSynP = runMatch match where- match (VarP x) q = unBind x ==> q- match (LitP _ l) (LitP _ l') = guard (l == l')- match (WildP _) (WildP _) = return ()- match (ConP _ (AmbQ cs) ps) (ConP _ (AmbQ cs') qs) = do- guard $ all (`elem` cs) cs'+ match (VarP x) q = x ==> q+ match (LitP _ l) (LitP _ l') = guard (l == l')+ match (WildP _) (WildP _) = return ()+ match (ConP _ x ps) (ConP _ x' qs) = do+ guard $ allPossibleConstructorsAppearInSynonym x x' guard $ map getArgInfo ps == map getArgInfo qs zipWithM_ match (map namedArg ps) (map namedArg qs) match _ _ = empty +allPossibleConstructorsAppearInSynonym :: AmbiguousQName -> AmbiguousQName -> Bool+allPossibleConstructorsAppearInSynonym x x' = all (`elem` getAmbiguous x) (getAmbiguous x')+ type Match e = WriterT (Map Name e) Maybe -(==>) :: Name -> e -> Match e ()-x ==> e = tell (Map.singleton x e)+(==>) :: BindName -> e -> Match e ()+x ==> e = tell (Map.singleton (unBind x) e) runMatch :: (Pattern' Void -> e -> Match e ()) -> PatternSynDefn -> e -> Maybe [WithHiding e]-runMatch match (xs, pat) e = do+runMatch match (PatternSynDefn xs pat) e = do sub <- execWriterT (match pat e) forM xs $ \ x -> (<$ x) <$> Map.lookup (whThing x) sub
src/full/Agda/Syntax/Abstract/Pretty.hs view
@@ -13,7 +13,7 @@ prettyA x = pretty <$> abstractToConcrete_ x prettyAs :: (ToConcrete a, ConOfAbs a ~ [ce], Pretty ce, MonadAbsToCon m) => a -> m Doc-prettyAs x = fsep . map pretty <$> abstractToConcrete_ x+prettyAs x = fsep . map pretty <$> abstractToConcreteCtx (ArgumentCtx PreferParen) x -- | Variant of 'showA' which does not insert outermost parentheses.
src/full/Agda/Syntax/Abstract/UsedNames.hs view
@@ -1,10 +1,10 @@ module Agda.Syntax.Abstract.UsedNames ( allUsedNames+ , allBoundNames ) where import Data.Foldable (foldMap)-import Data.Semigroup (Semigroup, (<>)) import Data.Set (Set) import qualified Data.Set as Set @@ -22,6 +22,9 @@ allUsedNames :: Expr -> Set Name allUsedNames = usedNames . boundAndUsed +allBoundNames :: BoundAndUsed a => a -> Set Name+allBoundNames = boundNames . boundAndUsed+ data BoundAndUsedNames = BoundAndUsedNames { boundNames :: Set Name , usedNames :: Set Name }@@ -81,32 +84,34 @@ instance BoundAndUsed Expr where boundAndUsed = noBindings . \ case- Var x -> singleUse x- Def'{} -> mempty- Proj{} -> mempty- Con{} -> mempty- PatternSyn{} -> mempty- Macro{} -> mempty- Lit{} -> mempty- QuestionMark{} -> mempty- Underscore{} -> mempty- Dot _ expr -> boundAndUsed expr- App _ expr arg -> boundAndUsed (expr, arg)- WithApp _ expr exprs -> boundAndUsed (expr, exprs)- Lam _ bind expr -> boundAndUsed (bind, expr)- AbsurdLam{} -> mempty- ExtendedLam _ _ _ _ cs -> boundAndUsed cs- Pi _ tel expr -> boundAndUsed (tel, expr)- Generalized _ expr -> boundAndUsed expr- Fun _ arg expr -> boundAndUsed (arg, expr)- Let _ binds expr -> boundAndUsed (binds, expr)- Rec _ _ as -> boundAndUsed as- RecUpdate _ _ expr as -> boundAndUsed expr <> boundAndUsed as- ScopedExpr _ expr -> boundAndUsed expr- Quote{} -> mempty- QuoteTerm{} -> mempty- Unquote{} -> mempty- DontCare expr -> boundAndUsed expr+ Var x -> singleUse x+ Def'{} -> mempty+ Proj{} -> mempty+ Con{} -> mempty+ PatternSyn{} -> mempty+ Macro{} -> mempty+ Lit{} -> mempty+ QuestionMark{} -> mempty+ Underscore{} -> mempty+ Dot _ expr -> boundAndUsed expr+ App _ expr arg -> boundAndUsed (expr, arg)+ WithApp _ expr exprs -> boundAndUsed (expr, exprs)+ Lam _ bind expr -> boundAndUsed (bind, expr)+ AbsurdLam{} -> mempty+ ExtendedLam _ _ _ _ cs -> boundAndUsed cs+ Pi _ tel expr -> boundAndUsed (tel, expr)+ Generalized _ expr -> boundAndUsed expr+ Fun _ arg expr -> boundAndUsed (arg, expr)+ Let _ binds expr -> boundAndUsed (binds, expr)+ Rec _ _ as -> boundAndUsed as+ RecUpdate _ _ expr as -> boundAndUsed expr <> boundAndUsed as+ ScopedExpr _ expr -> boundAndUsed expr+ Quote{} -> mempty+ QuoteTerm{} -> mempty+ Unquote{} -> mempty+ DontCare expr -> boundAndUsed expr+ Qualified _ b -> boundAndUsed b+ Highlighted _ b -> boundAndUsed b instance BoundAndUsed lhs => BoundAndUsed (Clause' lhs) where -- Note: where declarations are ignored. We use this only on expressions coming from@@ -139,7 +144,7 @@ boundAndUsed = \ case -- Note: binder last since it's not recursive LetBind _ _ x ty e -> boundAndUsed ((ty, e), x) LetAxiom _ _ x ty -> boundAndUsed (ty, x)- LetPatBind _ p e -> boundAndUsed (e, p)+ LetPatBind _ _ p e -> boundAndUsed (e, p) LetApply _ _ _ app _ _ -> boundAndUsed app LetOpen{} -> mempty
src/full/Agda/Syntax/Abstract/Views.hs view
@@ -6,25 +6,26 @@ import Control.Applicative ( Const(Const), getConst ) import Control.Monad.Identity +import Data.Bifunctor (second) import Data.Foldable (foldMap)-import qualified Data.DList as DL-import Data.Semigroup ((<>))+import Data.DList qualified as DL import Data.Void import Agda.Syntax.Common import Agda.Syntax.Abstract as A import Agda.Syntax.Concrete (FieldAssignment', exprFieldA, TacticAttribute') import Agda.Syntax.Info-import Agda.Syntax.Scope.Base (KindOfName(..), conKindOfName, WithKind(..))+import Agda.Syntax.Scope.Base (conKindOfName, WithKind(..)) import Agda.Utils.Either import Agda.Utils.List1 (List1)+import Agda.Utils.List1 qualified as List1 import Agda.Utils.Null import Agda.Utils.Singleton import Agda.Utils.Impossible -+-- | An 'Expr' viewed as application. data AppView' arg = Application Expr [NamedArg arg] deriving (Functor) @@ -32,31 +33,39 @@ -- | Gather applications to expose head and spine. ----- Note: everything is an application, possibly of itself to 0 arguments+-- Note:+--+-- 1. Everything is an application, possibly of itself to 0 arguments.+--+-- 2. If the returned head is a projection originating from a post-fix+-- projection, the 'ArgInfo' of the first argument might be incorrect.+-- (See issue #8300.)+-- For instance @x .f@ is valid postfix syntax for @f {{x}}@,+-- but 'appView' turns the former into @f x@.+-- The correct @f {{x}}@ is produced by 'Agda.TypeChecking.Rules.Term.appViewM'. appView :: Expr -> AppView appView = fmap snd . appView' appView' :: Expr -> AppView' (AppInfo, Expr) appView' e = f (DL.toList es) where- (f, es) = appView'' e-- appView'' = \case+ (f, es) = go e+ go = \case App i e1 e2 | Dot _ e2' <- unScope $ namedArg e2- , Just f <- maybeProjTurnPostfix e2'+ , Just (_, f) <- maybeProjTurnPostfix e2' , getHiding e2 == NotHidden -- Jesper, 2018-12-13: postfix projections shouldn't be hidden -> (Application f, singleton (defaultNamedArg (i, e1)))- App i e1 arg | (f, es) <- appView'' e1 ->+ App i e1 arg | (f, es) <- go e1 -> (f, es `DL.snoc` (fmap . fmap) (i,) arg)- ScopedExpr _ e -> appView'' e- e -> (Application e, mempty)+ ScopedExpr _ e -> go e+ e -> (Application e, mempty) -maybeProjTurnPostfix :: Expr -> Maybe Expr+maybeProjTurnPostfix :: Expr -> Maybe (AmbiguousQName, Expr) maybeProjTurnPostfix e = case e of- ScopedExpr i e' -> ScopedExpr i <$> maybeProjTurnPostfix e'- Proj _ x -> return $ Proj ProjPostfix x+ ScopedExpr i e' -> second (ScopedExpr i) <$> maybeProjTurnPostfix e'+ Proj _ x -> return (x, Proj ProjPostfix x) _ -> Nothing unAppView :: AppView -> Expr@@ -103,20 +112,34 @@ deepUnscope :: ExprLike a => a -> a deepUnscope = mapExpr unScope -deepUnscopeDecls :: [A.Declaration] -> [A.Declaration]-deepUnscopeDecls = concatMap deepUnscopeDecl+class DeepUnscopeDecls t where+ deepUnscopeDecls :: t A.Declaration -> t A.Declaration -deepUnscopeDecl :: A.Declaration -> [A.Declaration]+instance DeepUnscopeDecls [] where+ deepUnscopeDecls :: [A.Declaration] -> [A.Declaration]+ deepUnscopeDecls = foldMap (List1.toList . deepUnscopeDecl)++instance DeepUnscopeDecls List1 where+ deepUnscopeDecls :: List1 A.Declaration -> List1 A.Declaration+ deepUnscopeDecls = List1.concatMap1 deepUnscopeDecl+ -- Want to use foldMap1 here, but it requires base >= 4.18 (GHC 9.6)++deepUnscopeDecl :: A.Declaration -> List1 A.Declaration deepUnscopeDecl = \case- A.ScopedDecl _ ds -> deepUnscopeDecls ds- A.Mutual i ds -> [A.Mutual i (deepUnscopeDecls ds)]- A.Section i e m tel ds -> [A.Section i e m (deepUnscope tel)- (deepUnscopeDecls ds)]- A.RecDef i x uc dir bs e ds -> [ A.RecDef i x uc dir (deepUnscope bs)- (deepUnscope e)- (deepUnscopeDecls ds) ]- d -> [deepUnscope d]+ A.ScopedDecl _ ds ->+ deepUnscopeDecls ds + A.Mutual i ds -> singleton $+ A.Mutual i (deepUnscopeDecls ds)++ A.Section i e m tel ds -> singleton $+ A.Section i e m (deepUnscope tel) (deepUnscopeDecls ds)++ A.RecDef i x pc uc eta dir bs e ds -> singleton $+ A.RecDef i x pc uc eta dir (deepUnscope bs) (deepUnscope e) (deepUnscopeDecls ds)++ d -> singleton $ deepUnscope d+ -- * Traversal --------------------------------------------------------------------------- @@ -128,7 +151,7 @@ type FoldExprFn m a = Monoid m => (Expr -> m) -> a -> m type FoldExprRecFn m = forall a. ExprLike a => a -> m -type TraverseExprFn m a = (Applicative m, Monad m) => (Expr -> m Expr) -> a -> m a+type TraverseExprFn m a = (Monad m) => (Expr -> m Expr) -> a -> m a type TraverseExprRecFn m = forall a. ExprLike a => a -> m a -- | Apply an expression rewriting to every subexpression, inside-out.@@ -182,36 +205,40 @@ DontCare e -> DontCare <$> recurse e PatternSyn{} -> pure e0 Macro{} -> pure e0+ Qualified q e -> Qualified q <$> recurse e+ Highlighted q e -> Highlighted q <$> recurse e foldExpr :: forall m. FoldExprFn m Expr foldExpr f e = case e of- Var{} -> m- Def'{} -> m- Proj{} -> m- Con{} -> m- PatternSyn{} -> m- Macro{} -> m- Lit{} -> m- QuestionMark{} -> m- Underscore{} -> m- Dot _ e -> m `mappend` fold e- App _ e e' -> m `mappend` fold e `mappend` fold e'- WithApp _ e es -> m `mappend` fold e `mappend` fold es- Lam _ b e -> m `mappend` fold b `mappend` fold e- AbsurdLam{} -> m- ExtendedLam _ _ _ _ cs -> m `mappend` fold cs- Pi _ tel e -> m `mappend` fold tel `mappend` fold e- 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- Rec _ _ as -> m `mappend` fold as- RecUpdate _ _ e as -> m `mappend` fold e `mappend` fold as- ScopedExpr _ e -> m `mappend` fold e- Quote{} -> m- QuoteTerm{} -> m- Unquote{} -> m- DontCare e -> m `mappend` fold e+ Var{} -> m+ Def'{} -> m+ Proj{} -> m+ Con{} -> m+ PatternSyn{} -> m+ Macro{} -> m+ Lit{} -> m+ QuestionMark{} -> m+ Underscore{} -> m+ Dot _ e -> m `mappend` fold e+ App _ e e' -> m `mappend` fold e `mappend` fold e'+ WithApp _ e es -> m `mappend` fold e `mappend` fold es+ Lam _ b e -> m `mappend` fold b `mappend` fold e+ AbsurdLam{} -> m+ ExtendedLam _ _ _ _ cs -> m `mappend` fold cs+ Pi _ tel e -> m `mappend` fold tel `mappend` fold e+ 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+ Rec _ _ as -> m `mappend` fold as+ RecUpdate _ _ e as -> m `mappend` fold e `mappend` fold as+ ScopedExpr _ e -> m `mappend` fold e+ Quote{} -> m+ QuoteTerm{} -> m+ Unquote{} -> m+ DontCare e -> m `mappend` fold e+ Qualified _ e -> m `mappend` fold e+ Highlighted _ e -> m `mappend` fold e where m = f e fold :: FoldExprRecFn m@@ -249,6 +276,8 @@ DontCare e -> f =<< DontCare <$> trav e PatternSyn{} -> f e Macro{} -> f e+ Qualified m e -> f =<< Qualified m <$> trav e+ Highlighted q e -> f =<< Highlighted q <$> trav e instance ExprLike a => ExprLike (Arg a) instance ExprLike a => ExprLike (Maybe a)@@ -332,7 +361,7 @@ case e of LetBind li ai x e e' -> LetBind li ai x <$> recurse e <*> recurse e' LetAxiom li ai x e -> LetAxiom li ai x <$> recurse e- LetPatBind li p e -> LetPatBind li <$> recurse p <*> recurse e+ LetPatBind li ai p e -> LetPatBind li ai <$> recurse p <*> recurse e LetApply{} -> pure e LetOpen{} -> pure e @@ -341,7 +370,7 @@ case e of LetBind _ _ _ e e' -> fold e `mappend` fold e' LetAxiom _ _ _ e -> fold e- LetPatBind _ p e -> fold p `mappend` fold e+ LetPatBind _ _ p e -> fold p `mappend` fold e LetApply{} -> mempty LetOpen{} -> mempty where@@ -356,7 +385,7 @@ case e of LetBind li ai x e e' -> LetBind li ai x <$> trav e <*> trav e' LetAxiom li ai x e -> LetAxiom li ai x <$> trav e- LetPatBind li p e -> LetPatBind li <$> trav p <*> trav e+ LetPatBind li ai p e -> LetPatBind li ai <$> trav p <*> trav e LetApply{} -> pure e LetOpen{} -> pure e @@ -381,7 +410,7 @@ rec :: RecurseExprRecFn m rec e = recurseExpr f e -instance (ExprLike qn, ExprLike nm, ExprLike p, ExprLike e) => ExprLike (RewriteEqn' qn nm p e) where+instance (ExprLike qn, ExprLike p, ExprLike e) => ExprLike (RewriteEqn' qn nm p e) where recurseExpr f = \case Rewrite es -> Rewrite <$> recurseExpr f es Invert qn pes -> Invert <$> recurseExpr f qn <*> recurseExpr f pes@@ -409,11 +438,11 @@ BuiltinNoDefPragma{} -> pure p RewritePragma{} -> pure p CompilePragma{} -> pure p+ ForeignPragma{} -> pure p StaticPragma{} -> pure p InjectivePragma{} -> pure p InjectiveForInferencePragma{} -> pure p InlinePragma{} -> pure p- EtaPragma{} -> pure p NotProjectionLikePragma{} -> pure p OverlapPragma{} -> pure p DisplayPragma f xs e -> DisplayPragma f <$> rec xs <*> rec e@@ -446,9 +475,9 @@ Open{} -> pure d FunDef i f cs -> FunDef i f <$> rec cs DataSig i er d tel e -> DataSig i er d <$> rec tel <*> rec e- DataDef i d uc bs cs -> DataDef i d uc <$> rec bs <*> rec cs+ DataDef i d pc uc bs cs -> DataDef i d pc uc <$> rec bs <*> rec cs RecSig i er r tel e -> RecSig i er r <$> rec tel <*> rec e- RecDef i r uc dir bs e ds -> RecDef i r uc dir <$> rec bs <*> rec e <*> rec ds+ RecDef i r pc uc eta dir bs e ds -> RecDef i r pc uc eta dir <$> rec bs <*> rec e <*> rec ds 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@@ -512,9 +541,9 @@ Primitive _ q _ -> singleton (WithKind PrimName q) Mutual _ decls -> declaredNames decls DataSig _ _ q _ _ -> singleton (WithKind DataName q)- DataDef _ q _ _ decls -> singleton (WithKind DataName q) <> foldMap con decls+ DataDef _ q _ _ _ decls -> singleton (WithKind DataName q) <> foldMap con decls RecSig _ _ q _ _ -> singleton (WithKind RecName q)- RecDef _ q _ dir _ _ decls -> singleton (WithKind RecName q) <> declaredNames dir <> declaredNames decls+ RecDef _ q _ _ _ dir _ _ decls -> singleton (WithKind RecName q) <> declaredNames dir <> declaredNames decls 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@@ -537,9 +566,9 @@ BuiltinNoDefPragma _b kind x -> singleton $ WithKind kind x BuiltinPragma{} -> mempty CompilePragma{} -> mempty+ ForeignPragma{} -> mempty RewritePragma{} -> mempty StaticPragma{} -> mempty- EtaPragma{} -> mempty InjectivePragma{} -> mempty InjectiveForInferencePragma{} -> mempty InlinePragma{} -> mempty
src/full/Agda/Syntax/Builtin.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-} -- | This module defines the names of all builtin and primitives used in Agda. --@@ -120,6 +121,7 @@ | BuiltinFromNat | BuiltinFromNeg | BuiltinFromString+ | BuiltinQuotientConstructor | BuiltinQName | BuiltinAgdaSort | BuiltinAgdaSortSet@@ -340,6 +342,7 @@ BuiltinFromNat -> "FROMNAT" BuiltinFromNeg -> "FROMNEG" BuiltinFromString -> "FROMSTRING"+ BuiltinQuotientConstructor -> "QUOTIENTCONSTRUCTOR" BuiltinQName -> "QNAME" BuiltinAgdaSort -> "AGDASORT" BuiltinAgdaSortSet -> "AGDASORTSET"@@ -536,6 +539,7 @@ builtinLevelUniv, builtinIntervalUniv, builtinFromNat, builtinFromNeg, builtinFromString,+ builtinQuotientConstructor, builtinQName, builtinAgdaSort, builtinAgdaSortSet, builtinAgdaSortLit, builtinAgdaSortProp, builtinAgdaSortPropLit, builtinAgdaSortInf, builtinAgdaSortUnsupported,@@ -664,6 +668,7 @@ builtinFromNat = BuiltinFromNat builtinFromNeg = BuiltinFromNeg builtinFromString = BuiltinFromString+builtinQuotientConstructor = BuiltinQuotientConstructor builtinQName = BuiltinQName builtinAgdaSort = BuiltinAgdaSort builtinAgdaSortSet = BuiltinAgdaSortSet@@ -904,6 +909,8 @@ | PrimStringEquality | PrimShowString | PrimStringUncons+ -- Quotients+ | PrimQrec -- "Other stuff" | PrimErase | PrimEraseEquality@@ -921,6 +928,7 @@ | PrimMetaToNat | PrimMetaToNatInjective | PrimLockUniv+ | PrimRewriteNoMatch deriving (Show, Eq, Ord, Bounded, Enum, Generic) instance NFData PrimitiveId@@ -1041,6 +1049,8 @@ PrimStringEquality -> "primStringEquality" PrimShowString -> "primShowString" PrimStringUncons -> "primStringUncons"+ -- Quotients+ PrimQrec -> "qrec" -- "Other stuff" PrimErase -> "primErase" PrimEraseEquality -> "primEraseEquality"@@ -1058,12 +1068,13 @@ PrimMetaToNat -> "primMetaToNat" PrimMetaToNatInjective -> "primMetaToNatInjective" PrimLockUniv -> "primLockUniv"+ PrimRewriteNoMatch -> "primRewriteNoMatch" builtinSubOut, builtinIMin, builtinIMax, builtinINeg, builtinGlue, builtin_glue, builtin_unglue, builtin_glueU, builtin_unglueU, builtinFaceForall, builtinComp, builtinPOr,- builtinTrans, builtinHComp, builtinLockUniv+ builtinTrans, builtinHComp, builtinLockUniv, builtinRewriteNoMatch :: PrimitiveId builtinIMin = PrimIMin builtinIMax = PrimIMax@@ -1080,6 +1091,7 @@ builtinTrans = PrimTrans builtinHComp = PrimHComp builtinLockUniv = PrimLockUniv+builtinRewriteNoMatch = PrimRewriteNoMatch -- | Lookup a primitive by its identifier. primitiveById :: String -> Maybe PrimitiveId
src/full/Agda/Syntax/Common.hs view
@@ -1,3 +1,6 @@+-- {-# OPTIONS_GHC -Wunused-imports #-} -- does not work because of liftA2+{-# OPTIONS_GHC -Wunused-matches #-}+ {-| Some common syntactic entities are defined in this module. -} module Agda.Syntax.Common@@ -13,9 +16,9 @@ import Prelude hiding (null) import Control.DeepSeq-import Control.Arrow ((&&&)) import Control.Applicative ((<|>), liftA2) +import Data.Array (Ix) import Data.Bifunctor import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as ByteString@@ -38,11 +41,11 @@ import Agda.Syntax.Concrete.Glyph import Agda.Syntax.Position -import Agda.Utils.BiMap (HasTag(..)) import Agda.Utils.Boolean (Boolean(fromBool), IsBool(toBool)) import Agda.Utils.Float (toStringWithoutDotZero) import Agda.Utils.Functor import Agda.Utils.Lens+import Agda.Utils.Hash (combineWord) import Agda.Utils.List ( lastMaybe ) import Agda.Utils.List1 ( List1, pattern (:|), (<|) ) import qualified Agda.Utils.List1 as List1@@ -50,6 +53,10 @@ import Agda.Utils.Null import Agda.Utils.PartialOrd import Agda.Utils.POMonoid+import Agda.Utils.Singleton+import Agda.Utils.SmallSet (SmallSetElement)+import Agda.Utils.VarSet (VarSet)+import qualified Agda.Utils.VarSet as VarSet import Agda.Utils.Impossible @@ -102,15 +109,16 @@ -- | Variants of Cubical Agda. -data Cubical = CErased | CFull+data Cubical = CWithoutGlue | CErased | CFull deriving (Eq, Show, Generic) instance NFData Cubical cubicalOptionString :: Cubical -> String cubicalOptionString = \case- CErased -> "--erased-cubical"- CFull -> "--cubical"+ CWithoutGlue -> "--cubical=no-glue"+ CErased -> "--cubical=erased"+ CFull -> "--cubical[=full]" -- | Agda variants. --@@ -127,6 +135,98 @@ instance NFData Language +------------------------------------------------------------------------+-- Erased matches++-- | What kinds of erased matches are allowed for indexed,+-- single-constructor data types?++data AllowedErasedMatchesIndexed+ = Restricted+ -- ^ @[]-cong@ is allowed.+ | Unrestricted+ -- ^ All erased matches are allowed.+ deriving (Eq, Ord, Show, Generic)++instance NFData AllowedErasedMatchesIndexed++instance Semigroup AllowedErasedMatchesIndexed where+ Restricted <> a2 = a2+ a1 <> _ = a1++instance Monoid AllowedErasedMatchesIndexed where+ mempty = Restricted++-- | What kinds of erased matches are allowed?++data AllowedErasedMatches = AllowedErasedMatches+ { emEmpty :: !Bool+ -- ^ Erased matches are allowed for the empty type.+ , emNonDependent :: !Bool+ -- ^ Erased matches are allowed for single-constructor,+ -- non-indexed data types.+ , emDependent :: !(Strict.Maybe AllowedErasedMatchesIndexed)+ -- ^ What kinds of erased matches, if any, are allowed for+ -- single-constructor, indexed data types?+ }+ deriving (Eq, Ord, Show, Generic)++instance NFData AllowedErasedMatches++instance Semigroup AllowedErasedMatches where+ AllowedErasedMatches e1 n1 d1 <> AllowedErasedMatches e2 n2 d2 =+ AllowedErasedMatches (e1 || e2) (n1 || n2) (d1 <> d2)++instance Monoid AllowedErasedMatches where+ mempty = AllowedErasedMatches+ { emEmpty = False+ , emNonDependent = False+ , emDependent = Strict.Nothing+ }++-- | Is @[]-cong@ allowed?++emRestricted :: AllowedErasedMatches -> Bool+emRestricted = Strict.isJust . emDependent++-- | Are unrestricted erased matches allowed for indexed types?++emUnrestricted :: AllowedErasedMatches -> Bool+emUnrestricted = (Strict.Just Unrestricted ==) . emDependent++-- | A variant of 'AllowedErasedMatches' that supports default values+-- that depend on other flags.++data AllowedErasedMatchesWithDefaults+ = ErasedMatchesDefault+ -- ^ No flag has been given, the default is used. (The default+ -- depends on whether the K rule is allowed or not.)+ | ErasedMatchesDefaultOn+ -- ^ The flag @--erased-matches@ has been given without any+ -- options, the \"default on\" value is used. (The default depends+ -- on whether the K rule is allowed or not.)+ | ErasedMatches AllowedErasedMatches+ -- ^ The flag @--erased-matches@ has been given with (valid)+ -- options.+ deriving (Eq, Show, Generic)++instance NFData AllowedErasedMatchesWithDefaults++instance Semigroup AllowedErasedMatchesWithDefaults where+ ErasedMatches m1 <> ErasedMatches m2 =+ ErasedMatches (m1 <> m2)+ m@ErasedMatches{} <> _ =+ m+ _ <> m@ErasedMatches{} =+ m+ m@ErasedMatchesDefaultOn <> _ =+ m+ ErasedMatchesDefault <> m =+ m++instance Monoid AllowedErasedMatchesWithDefaults where+ mempty = ErasedMatchesDefault+ --------------------------------------------------------------------------- -- * Backends ---------------------------------------------------------------------------@@ -166,9 +266,13 @@ -- | Expression kinds: Expressions or patterns. -data ExprKind = IsExpr | IsPattern+data ExprKind = IsExpr | IsPattern DisplayLHS deriving (Eq, Show) +isKindPattern :: ExprKind -> Bool+isKindPattern (IsPattern _) = True+isKindPattern IsExpr = False+ --------------------------------------------------------------------------- -- * Record Directives ---------------------------------------------------------------------------@@ -269,9 +373,67 @@ NoEta p -> copatternMatchingAllowed p ---------------------------------------------------------------------------+-- * Data or record+---------------------------------------------------------------------------++data DataOrRecord' p+ = IsData+ | IsRecord p+ deriving (Show, Eq, Generic)++instance KillRange a => KillRange (DataOrRecord' a) where+ killRange = \case+ IsData -> IsData+ IsRecord a -> killRangeN IsRecord a++type DataOrRecord = DataOrRecord' PatternOrCopattern+type DataOrRecord_ = DataOrRecord' ()+type DataOrRecordEta = DataOrRecord' ForceRecordEta++pattern IsRecord_ :: DataOrRecord_+pattern IsRecord_ = IsRecord ()++{-# COMPLETE IsData, IsRecord_ #-}++instance Boolean DataOrRecord_ where+ fromBool True = IsData+ fromBool False = IsRecord_++instance IsBool DataOrRecord_ where+ toBool IsData = True+ toBool IsRecord_ = False++instance PatternMatchingAllowed DataOrRecord where+ patternMatchingAllowed = \case+ IsData -> True+ IsRecord patCopat -> patternMatchingAllowed patCopat++instance CopatternMatchingAllowed DataOrRecord where+ copatternMatchingAllowed = \case+ IsData -> False+ IsRecord patCopat -> copatternMatchingAllowed patCopat++--------------------------------------------------------------------------- -- * Induction --------------------------------------------------------------------------- +-- | Does a datatype have path constructors, i.e. is it a HIT?+data IsHIT = YesHIT | NotHIT+ deriving (Eq, Ord, Show, Generic)++instance Boolean IsHIT where+ fromBool True = YesHIT+ fromBool False = NotHIT++instance IsBool IsHIT where+ toBool YesHIT = True+ toBool NotHIT = False++instance KillRange IsHIT where+ killRange = id++instance NFData IsHIT+ instance Pretty Induction where pretty Inductive = "inductive" pretty CoInductive = "coinductive"@@ -543,6 +705,9 @@ instance Pretty a => Pretty (WithHiding a) where pretty w = prettyHiding w id $ pretty $ dget w +unArgKeepHiding :: Arg a -> WithHiding a+unArgKeepHiding (Arg i a) = WithHiding (getHiding i) a+ --------------------------------------------------------------------------- -- * Modalities ---------------------------------------------------------------------------@@ -564,21 +729,27 @@ -- | We have a tuple of modalities, which might not be fully orthogonal. -- For example, irrelevant stuff is also run-time irrelevant. data Modality = Modality- { modRelevance :: Relevance+ { modRelevance :: !Relevance -- ^ Legacy irrelevance. -- See Pfenning, LiCS 2001; Abel, Vezzosi and Winterhalter, ICFP 2017.- , modQuantity :: Quantity+ , modQuantity :: !Quantity -- ^ Cardinality / runtime erasure. -- See Conor McBride, I got plenty o' nutting, Wadlerfest 2016. -- See Bob Atkey, Syntax and Semantics of Quantitative Type Theory, LiCS 2018.- , modCohesion :: Cohesion+ , modCohesion :: !Cohesion -- ^ 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.- , modPolarity :: PolarityModality+ , modPolarity :: !PolarityModality -- ^ Polarity annotations (strictly positive, ...) } deriving (Eq, Ord, Show, Generic) +{-# NOINLINE noinlineEqModality #-}+-- | Non-inlined equality that's sometimes useful to prevent GHC from ballooning code size.+noinlineEqModality :: Modality -> Modality -> Bool+noinlineEqModality (Modality a b c d) (Modality a' b' c' d') =+ a == a' && b == b' && c == c' && d == d'+ -- | Dominance ordering. instance PartialOrd Modality where comparable (Modality r q c p) (Modality r' q' c' p') = comparable (r, (q, (c, p))) (r', (q', (c', p')))@@ -694,10 +865,11 @@ defaultCheckModality :: Modality defaultCheckModality = defaultModality { modPolarity = withStandardLock StrictlyPositive } --- | Extract the positional modality component for checks regarding only them.+-- | Extract the positional modality components (cohesion and polarity)+-- for checks regarding only them. positionalModalityComponent :: Modality -> Modality positionalModalityComponent m =- defaultModality {modCohesion = modCohesion m}+ defaultModality {modCohesion = modCohesion m, modPolarity = modPolarity m} -- | Equality ignoring origin. @@ -1136,7 +1308,7 @@ inverseComposeQuantity :: Quantity -> Quantity -> Quantity inverseComposeQuantity = curry $ \case (Quantity1{} , x) -> x -- going to linear arg: nothing changes- (Quantity0{} , x) -> topQuantity -- going to erased arg: every thing usable+ (Quantity0{} , _) -> topQuantity -- going to erased arg: every thing usable (Quantityω{} , x@Quantityω{}) -> x (Quantityω{} , _) -> zeroQuantity -- linear resources are unusable as arguments to unrestricted functions @@ -1147,21 +1319,21 @@ inverseApplyQuantity q = mapQuantity (q `inverseComposeQuantity`) -- | Check for 'Quantity0'.-+{-# INLINE hasQuantity0 #-} hasQuantity0 :: LensQuantity a => a -> Bool hasQuantity0 a | Quantity0{} <- getQuantity a = True | otherwise = False -- | Check for 'Quantity1'.-+{-# INLINE hasQuantity1 #-} hasQuantity1 :: LensQuantity a => a -> Bool hasQuantity1 a | Quantity1{} <- getQuantity a = True | otherwise = False -- | Check for 'Quantityω'.-+{-# INLINE hasQuantityω #-} hasQuantityω :: LensQuantity a => a -> Bool hasQuantityω a | Quantityω{} <- getQuantity a = True@@ -1494,9 +1666,9 @@ -- | A function argument can be relevant or irrelevant. -- See "Agda.TypeChecking.Irrelevance". data Relevance- = Relevant OriginRelevant+ = Relevant !OriginRelevant -- ^ The argument is (possibly) relevant at compile-time.- | ShapeIrrelevant OriginShapeIrrelevant+ | ShapeIrrelevant !OriginShapeIrrelevant -- ^ Like 'Quantity0', the argument may never flow into evaluation position. -- So it is irrelevant at run-time, -- yet treated relevantly during equality checking.@@ -1509,7 +1681,7 @@ -- (Not enforcing shape-irrelevant codomains can break subject reduction!) -- - <https://dl.acm.org/doi/10.1145/3110277> -- - <https://doi.org/10.1145/3209108.3209119>- | Irrelevant OriginIrrelevant+ | Irrelevant !OriginIrrelevant -- ^ The argument is irrelevant at compile- and runtime. deriving (Show, Generic) @@ -1543,14 +1715,17 @@ getRelevance :: a -> Relevance + {-# inline setRelevance #-} setRelevance :: Relevance -> a -> a setRelevance h = mapRelevance (const h) mapRelevance :: (Relevance -> Relevance) -> a -> a + {-# INLINE getRelevance #-} default getRelevance :: LensModality a => a -> Relevance getRelevance = modRelevance . getModality + {-# INLINE mapRelevance #-} default mapRelevance :: LensModality a => (Relevance -> Relevance) -> a -> a mapRelevance f = mapModality $ \ ai -> ai { modRelevance = f $ modRelevance ai } @@ -1568,16 +1743,19 @@ shapeIrrelevant :: Relevance shapeIrrelevant = ShapeIrrelevant empty +{-# INLINE isRelevant #-} isRelevant :: LensRelevance a => a -> Bool isRelevant a = case getRelevance a of Relevant{} -> True _ -> False +{-# INLINE isIrrelevant #-} isIrrelevant :: LensRelevance a => a -> Bool isIrrelevant a = case getRelevance a of Irrelevant{} -> True _ -> False +{-# INLINE isShapeIrrelevant #-} isShapeIrrelevant :: LensRelevance a => a -> Bool isShapeIrrelevant a = case getRelevance a of ShapeIrrelevant{} -> True@@ -1648,7 +1826,7 @@ (_ , Relevant o ) -> Relevant o -- can't get more relevant (Relevant{} , x ) -> x -- going to relevant arg.: nothing changes -- because Relevant is comp.-neutral- (Irrelevant{} , x ) -> relevant -- going irrelevant: every thing usable+ (Irrelevant{} , _ ) -> relevant -- going irrelevant: every thing usable (ShapeIrrelevant{} , Irrelevant o ) -> Irrelevant o -- otherwise: irrelevant things remain unusable (ShapeIrrelevant{} , ShapeIrrelevant{}) -> relevant -- but @ShapeIrrelevant@s become usable @@ -1745,6 +1923,7 @@ { annLock :: Lock -- ^ Fitch-style dependent right adjoints. -- See Modal Dependent Type Theory and Dependent Right Adjoints, arXiv:1804.05236.+ , annRewrite :: RewriteAnn } deriving (Eq, Ord, Show, Generic) instance HasRange Annotation where@@ -1754,14 +1933,14 @@ killRange = id defaultAnnotation :: Annotation-defaultAnnotation = Annotation defaultLock+defaultAnnotation = Annotation defaultLock defaultRewrite instance Null Annotation where empty = defaultAnnotation- null (Annotation lock) = null lock+ null (Annotation lock rew) = null lock && null rew instance NFData Annotation where- rnf (Annotation l) = rnf l+ rnf (Annotation l r) = rnf (l, r) class LensAnnotation a where @@ -1825,6 +2004,8 @@ mapLock :: (Lock -> Lock) -> a -> a mapLock f a = setLock (f $ getLock a) a + {-# MINIMAL getLock , (setLock | mapLock) #-}+ instance LensLock Lock where getLock = id setLock = const@@ -1848,6 +2029,89 @@ prettyLock a = (pretty (getLock a) <+>) ---------------------------------------------------------------------------+-- * Rewrite arguments+---------------------------------------------------------------------------++data RewriteAnn+ = IsNotRewrite+ | IsRewrite Range+ deriving (Show, Generic)++defaultRewrite :: RewriteAnn+defaultRewrite = IsNotRewrite++instance HasRange RewriteAnn where+ getRange = \case+ IsRewrite r -> r+ IsNotRewrite -> noRange++instance SetRange RewriteAnn where+ setRange r = \case+ IsRewrite _ -> IsRewrite r+ IsNotRewrite -> IsNotRewrite++instance KillRange RewriteAnn where+ killRange = setRange noRange++instance Eq RewriteAnn where+ (==) = (==) `on` isRewrite++instance Ord RewriteAnn where+ compare = compare `on` isRewrite++instance Null RewriteAnn where+ empty = defaultRewrite++instance NFData RewriteAnn where+ rnf IsNotRewrite = ()+ rnf (IsRewrite _) = ()++instance Pretty RewriteAnn where+ pretty = \case+ (IsRewrite _) -> "@rewrite"+ IsNotRewrite -> empty++class LensRewriteAnn a where++ getRewriteAnn :: a -> RewriteAnn++ setRewriteAnn :: RewriteAnn -> a -> a+ setRewriteAnn = mapRewriteAnn . const++ mapRewriteAnn :: (RewriteAnn -> RewriteAnn) -> a -> a+ mapRewriteAnn f a = setRewriteAnn (f $ getRewriteAnn a) a++ {-# MINIMAL getRewriteAnn , (setRewriteAnn | mapRewriteAnn) #-}++instance LensRewriteAnn RewriteAnn where+ getRewriteAnn = id+ setRewriteAnn = const+ mapRewriteAnn = id++instance LensRewriteAnn ArgInfo where+ getRewriteAnn = annRewrite . argInfoAnnotation+ setRewriteAnn r info = info { argInfoAnnotation = (argInfoAnnotation info){ annRewrite = r } }++instance LensRewriteAnn (Arg t) where+ getRewriteAnn = getRewriteAnn . getArgInfo+ setRewriteAnn = mapArgInfo . setRewriteAnn++isRewrite :: LensRewriteAnn a => a -> Bool+isRewrite a = case getRewriteAnn a of+ IsRewrite _ -> True+ IsNotRewrite -> False++ignoreRew :: Monad m => LensRewriteAnn a => (RewriteAnn -> m ()) -> a -> m a+ignoreRew warn info+ | isRewrite info = do+ warn $ getRewriteAnn info+ return $ setRewriteAnn IsNotRewrite info+ | otherwise = return info++prettyRewriteAnn :: LensRewriteAnn a => a -> Doc -> Doc+prettyRewriteAnn a = (pretty (getRewriteAnn a) <+>)++--------------------------------------------------------------------------- -- * Cohesion --------------------------------------------------------------------------- @@ -1857,7 +2121,7 @@ data Cohesion = Flat -- ^ same points, discrete topology, idempotent comonad, box-like. | Continuous -- ^ identity modality.- -- | Sharp -- ^ same points, codiscrete topology, idempotent monad, diamond-like.+ | Sharp -- ^ same points, codiscrete topology, idempotent monad, diamond-like. | Squash -- ^ single point space, artificially added for Flat left-composition. deriving (Show, Eq, Enum, Bounded, Generic) @@ -1876,11 +2140,13 @@ instance NFData Cohesion where rnf Flat = () rnf Continuous = ()+ rnf Sharp = () rnf Squash = () instance Pretty Cohesion where pretty Flat = "@♭" pretty Continuous = mempty+ pretty Sharp = "@♯" pretty Squash = "@⊤" -- | A lens to access the 'Cohesion' attribute in data structures.@@ -1916,7 +2182,7 @@ moreCohesion :: Cohesion -> Cohesion -> Bool moreCohesion = (<=) --- | Equality ignoring origin.+-- | Equality ignoring origin. TODO: add origin to 'Cohesion'. sameCohesion :: Cohesion -> Cohesion -> Bool sameCohesion = (==) @@ -1927,11 +2193,15 @@ -- top (_, Squash) -> LT (Squash, _) -> GT+ -- id < ♯+ (Sharp,Continuous) -> GT+ (Continuous,Sharp) -> LT -- bottom (Flat, _) -> LT (_, Flat) -> GT- -- redundant case+ -- redundant cases (Continuous,Continuous) -> EQ+ (Sharp,Sharp) -> EQ -- | Flatter is smaller. instance PartialOrd Cohesion where@@ -1948,8 +2218,10 @@ case (r, r') of (Squash, _) -> Squash (_, Squash) -> Squash- (Flat, _) -> Flat- (_, Flat) -> Flat+ (Sharp, _) -> Sharp+ (Flat, _) -> Flat+ (_, Flat) -> Flat+ (_, Sharp) -> Sharp (Continuous, Continuous) -> Continuous -- | Compose with cohesion flag from the left.@@ -1969,9 +2241,11 @@ case (r, x) of (Continuous , x) -> x -- going to continous arg.: nothing changes -- because Continuous is comp.-neutral- (Squash, x) -> Flat -- in squash position everything is usable+ (Squash, _) -> Flat -- in squash position everything is usable (Flat , Flat) -> Flat -- otherwise: Flat things remain Flat (Flat , _) -> Squash -- but everything else becomes unusable.+ (Sharp, Squash) -> Squash -- in sharp everything is usable apart from+ (Sharp, _) -> Flat -- squash -- | Left division by a 'Cohesion'. -- Used e.g. to modify context when going into a @rel@ argument.@@ -2146,7 +2420,7 @@ } deriving (Show, Ord, Bounded, Generic) instance Eq PolarityModality where- (PolarityModality p o l) == (PolarityModality p' o' l') = p == p'+ (PolarityModality p _o _l) == (PolarityModality p' _o' _l') = p == p' withStandardLock :: ModalPolarity -> PolarityModality withStandardLock p = PolarityModality p p StrictlyPositive@@ -2161,7 +2435,7 @@ killRange rel = rel -- no range to kill instance NFData PolarityModality where- rnf (PolarityModality p o l) = ()+ rnf (PolarityModality _p _o _l) = () instance Pretty PolarityModality where pretty (PolarityModality p _ _) = pretty p@@ -2207,7 +2481,7 @@ -- | 'PolarityModality' composition. -- composePolarity :: PolarityModality -> PolarityModality -> PolarityModality-composePolarity (PolarityModality p o l) (PolarityModality p' o' l') =+composePolarity (PolarityModality p _o _l) (PolarityModality p' o' l') = PolarityModality (composePolarity' p p') o' l' -- | Compose with polarity flag from the left.@@ -2222,7 +2496,7 @@ -- iff -- @(r \`inverseComposePolarity\` x) \`morePolarity'\` y@ (Galois connection). inverseComposePolarity :: PolarityModality -> PolarityModality -> PolarityModality-inverseComposePolarity (PolarityModality p o l) (PolarityModality p' o' l') =+inverseComposePolarity (PolarityModality p _o _l) (PolarityModality p' o' l') = PolarityModality (inverseComposePolarity' p p') o' (composePolarity' l' p) -- | Left division by a 'PolarityModality'.@@ -2260,7 +2534,7 @@ -- | Combine inferred 'PolarityModality'. -- addPolarity :: PolarityModality -> PolarityModality -> PolarityModality-addPolarity (PolarityModality p o l) (PolarityModality p' o' l') =+addPolarity (PolarityModality p _o _l) (PolarityModality p' o' l') = PolarityModality (addPolarity' p p') o' l' -- | 'ModalPolarity' forms a monoid under addition, and even a semiring.@@ -2306,8 +2580,20 @@ | Substitution -- ^ Named application produced to represent a substitution. E.g. "?0 (x = n)" instead of "?0 n" | ExpandedPun -- ^ An expanded hidden argument pun. | Generalization -- ^ Inserted by the generalization process- deriving (Show, Eq, Ord)+ | ConversionFail+ -- ^ Inserted by the conversion checker in an argument spine at the+ -- position where they differ.+ --+ -- Indicates that the argument at this position should always be+ -- reified, even if the visibility/modality would be skipped with+ -- the current flags.+ | RecordSelf+ -- ^ Inserted to stand for the record "self" variable when checking a+ -- declaration inside a record module.+ deriving (Show, Eq, Ord, Enum, Bounded, Ix) +instance SmallSetElement Origin+ instance HasRange Origin where getRange _ = noRange @@ -2315,13 +2601,15 @@ killRange = id instance NFData Origin where- rnf UserWritten = ()- rnf Inserted = ()- rnf Reflected = ()- rnf CaseSplit = ()- rnf Substitution = ()- rnf ExpandedPun = ()+ rnf UserWritten = ()+ rnf Inserted = ()+ rnf Reflected = ()+ rnf CaseSplit = ()+ rnf Substitution = ()+ rnf ExpandedPun = () rnf Generalization = ()+ rnf ConversionFail = ()+ rnf RecordSelf = () -- | Decorating something with 'Origin' information. data WithOrigin a = WithOrigin@@ -2396,16 +2684,16 @@ -- * Free variable annotations ----------------------------------------------------------------------------- -data FreeVariables = UnknownFVs | KnownFVs IntSet+data FreeVariables = UnknownFVs | KnownFVs !VarSet deriving (Eq, Ord, Show) instance Semigroup FreeVariables where UnknownFVs <> _ = UnknownFVs _ <> UnknownFVs = UnknownFVs- KnownFVs vs1 <> KnownFVs vs2 = KnownFVs (IntSet.union vs1 vs2)+ KnownFVs vs1 <> KnownFVs vs2 = KnownFVs (VarSet.union vs1 vs2) instance Monoid FreeVariables where- mempty = KnownFVs IntSet.empty+ mempty = KnownFVs empty mappend = (<>) instance KillRange FreeVariables where@@ -2422,7 +2710,7 @@ noFreeVariables = mempty oneFreeVariable :: Int -> FreeVariables-oneFreeVariable = KnownFVs . IntSet.singleton+oneFreeVariable = KnownFVs . singleton freeVariablesFromList :: [Int] -> FreeVariables freeVariablesFromList = mconcat . map oneFreeVariable@@ -2453,7 +2741,7 @@ hasNoFreeVariables x = case getFreeVariables x of UnknownFVs -> False- KnownFVs fv -> IntSet.null fv+ KnownFVs fv -> null fv --------------------------------------------------------------------------- -- * Argument decoration@@ -2615,8 +2903,11 @@ data Arg e = Arg { argInfo :: ArgInfo , unArg :: e- } deriving (Eq, Ord, Show, Functor, Foldable, Traversable)+ } deriving (Eq, Ord, Show, Foldable, Traversable) +instance Functor Arg where+ fmap f = \(Arg x y) -> Arg x $! f y+ instance Decoration Arg where traverseF f (Arg ai a) = Arg ai <$> f a @@ -2730,6 +3021,7 @@ setModalPolarity = setPolarityMod mapModalPolarity = mapPolarityMod +{-# INLINE defaultArg #-} defaultArg :: a -> Arg a defaultArg = Arg defaultArgInfo @@ -2791,7 +3083,7 @@ isUnnamed :: Named name a -> Maybe a isUnnamed = \case Named Nothing a -> Just a- Named Just{} a -> Nothing+ Named Just{} _ -> Nothing named :: name -> a -> Named name a named = Named . Just@@ -3123,6 +3415,9 @@ | NotInstanceDef deriving (Show, Eq, Ord) +instance Null IsInstance where+ empty = NotInstanceDef+ instance KillRange IsInstance where killRange = \case InstanceDef _ -> InstanceDef empty@@ -3137,6 +3432,14 @@ rnf (InstanceDef _) = () rnf NotInstanceDef = () +class IsInstanceDef a where+ isInstanceDef :: a -> Maybe KwRange++instance IsInstanceDef IsInstance where+ isInstanceDef = \case+ InstanceDef r -> Just r+ NotInstanceDef -> Nothing+ -- ** macro blocks -- | Is this a macro definition?@@ -3218,6 +3521,10 @@ data NameId = NameId {-# UNPACK #-} !Word64 {-# UNPACK #-} !ModuleNameHash deriving (Eq, Ord, Generic, Show) +instance Null NameId where+ empty = NameId empty empty+ null (NameId n m) = null n && null m+ instance KillRange NameId where killRange = id @@ -3227,7 +3534,7 @@ instance Enum NameId where succ (NameId n m) = NameId (n + 1) m pred (NameId n m) = NameId (n - 1) m- toEnum n = __IMPOSSIBLE__ -- should not be used+ toEnum _ = __IMPOSSIBLE__ -- should not be used fromEnum (NameId n _) = fromIntegral n instance NFData NameId where@@ -3235,7 +3542,9 @@ instance Hashable NameId where {-# INLINE hashWithSalt #-}- hashWithSalt salt (NameId n (ModuleNameHash m)) = hashWithSalt salt (n, m)+ hashWithSalt salt (NameId n (ModuleNameHash m)) =+ fromIntegral+ (fromIntegral salt `combineWord` fromIntegral n `combineWord` fromIntegral m) --------------------------------------------------------------------------- -- * Meta variables@@ -3254,8 +3563,8 @@ text $ "_" ++ show n ++ "@" ++ show (moduleNameHash m) instance Enum MetaId where- succ MetaId{..} = MetaId { metaId = succ metaId, .. }- pred MetaId{..} = MetaId { metaId = pred metaId, .. }+ succ m@MetaId{ metaId } = m { metaId = succ metaId }+ pred m@MetaId{ metaId } = m { metaId = pred metaId } -- The following functions should not be used. toEnum = __IMPOSSIBLE__@@ -3285,7 +3594,7 @@ -- | A "problem" consists of a set of constraints and the same constraint can be part of multiple -- problems.-newtype ProblemId = ProblemId Nat+newtype ProblemId = ProblemId Word64 deriving (Eq, Ord, Enum, Real, Integral, Num, NFData) -- This particular Show instance is ok because of the Num instance.@@ -3306,7 +3615,7 @@ instance Enum OpaqueId where succ (OpaqueId n m) = OpaqueId (n + 1) m pred (OpaqueId n m) = OpaqueId (n - 1) m- toEnum n = __IMPOSSIBLE__ -- should not be used+ toEnum _ = __IMPOSSIBLE__ -- should not be used fromEnum (OpaqueId n _) = fromIntegral n instance NFData OpaqueId where@@ -3488,9 +3797,20 @@ instance NFData Fixity' where rnf (Fixity' _ a _) = rnf a +-- Note that there are ranges also in 'Fixity' and 'Notation',+-- but we are biased here on the range for the error reporting.+instance HasRange Fixity' where+ getRange = theNameRange++-- Kills all ranges, not just 'theNameRange'. instance KillRange Fixity' where killRange (Fixity' f n r) = killRangeN Fixity' f n r +instance Pretty Fixity' where+ pretty (Fixity' fix nota _range)+ | null nota = pretty fix+ | otherwise = hlKeyword "syntax" <+> pretty nota+ -- lenses _fixityAssoc :: Lens' Fixity Associativity@@ -3546,7 +3866,7 @@ _ -> False empty = defaultImportDir -instance (HasRange n, HasRange m) => Semigroup (ImportDirective' n m) where+instance Semigroup (ImportDirective' n m) where i1 <> i2 = ImportDirective { importDirRange = fuseRange i1 i2 , using = using i1 <> using i2@@ -3555,7 +3875,7 @@ , publicOpen = publicOpen i1 <|> publicOpen i2 } -instance (HasRange n, HasRange m) => Monoid (ImportDirective' n m) where+instance Monoid (ImportDirective' n m) where mempty = empty mappend = (<>) @@ -3604,8 +3924,8 @@ ImportedName x -> x setImportedName :: ImportedName' a a -> a -> ImportedName' a a-setImportedName (ImportedName x) y = ImportedName y-setImportedName (ImportedModule x) y = ImportedModule y+setImportedName (ImportedName _) y = ImportedName y+setImportedName (ImportedModule _) y = ImportedModule y -- | Like 'partitionEithers'. partitionImportedNames :: [ImportedName' n m] -> ([n], [m])@@ -3636,7 +3956,7 @@ -- ** HasRange instances -instance (HasRange a, HasRange b) => HasRange (ImportDirective' a b) where+instance HasRange (ImportDirective' a b) where getRange = importDirRange instance (HasRange a, HasRange b) => HasRange (Using' a b) where@@ -3773,9 +4093,11 @@ _ <> NoPositivityCheck = NoPositivityCheck _ <> _ = YesPositivityCheck +instance Null PositivityCheck where+ empty = YesPositivityCheck+ instance Monoid PositivityCheck where- mempty = YesPositivityCheck- mappend = (<>)+ mempty = empty instance NFData PositivityCheck @@ -3792,7 +4114,40 @@ instance NFData UniverseCheck +instance Null UniverseCheck where+ empty = YesUniverseCheck++instance Semigroup UniverseCheck where+ NoUniverseCheck <> _ = NoUniverseCheck+ YesUniverseCheck <> uc = uc++instance Monoid UniverseCheck where+ mempty = empty+ -----------------------------------------------------------------------------+-- * Force record to have eta equality+-----------------------------------------------------------------------------++-- | Force record type to have eta equality? (Default is no).+data ForceRecordEta = YesForceRecordEta | NoForceRecordEta+ deriving (Eq, Ord, Show, Bounded, Enum, Generic)++instance KillRange ForceRecordEta where+ killRange = id++instance NFData ForceRecordEta++instance Null ForceRecordEta where+ empty = NoForceRecordEta++instance Semigroup ForceRecordEta where+ YesForceRecordEta <> _ = YesForceRecordEta+ NoForceRecordEta <> eta = eta++instance Monoid ForceRecordEta where+ mempty = empty++----------------------------------------------------------------------------- -- * Coverage ----------------------------------------------------------------------------- @@ -3805,7 +4160,7 @@ instance Semigroup Catchall where NoCatchall <> c = c c <> NoCatchall = c- c1@(YesCatchall r) <> c2@(YesCatchall r') = if null r then c2 else c1+ c1@(YesCatchall r) <> c2@(YesCatchall _r) = if null r then c2 else c1 instance Monoid Catchall where mempty = empty@@ -3869,7 +4224,7 @@ pretty = \case Rewrite es -> prefixedThings (text "rewrite") $ List1.toList (pretty . snd <$> es) LeftLet pes -> prefixedThings (text "using") [pretty p <+> "<-" <+> pretty e | (p, e) <- List1.toList pes]- Invert _ pes -> prefixedThings (text "invert") $ List1.toList (namedWith <$> pes) where+ Invert _ pes -> prefixedThings (text "with") $ List1.toList (namedWith <$> pes) where namedWith (Named nm (p, e)) = let patexp = pretty p <+> "<-" <+> pretty e in@@ -3877,7 +4232,7 @@ Nothing -> patexp Just nm -> pretty nm <+> ":" <+> patexp -instance (HasRange qn, HasRange nm, HasRange p, HasRange e) => HasRange (RewriteEqn' qn nm p e) where+instance (HasRange qn, HasRange p, HasRange e) => HasRange (RewriteEqn' qn nm p e) where getRange = \case Rewrite es -> getRange es Invert qn pes -> getRange (qn, pes)@@ -4020,3 +4375,11 @@ rnf (HolePart _ a) = rnf a rnf (WildPart a) = rnf a rnf (IdPart a) = rnf a++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/Common/Aspect.hs view
@@ -1,16 +1,19 @@ module Agda.Syntax.Common.Aspect where -import Agda.Syntax.TopLevelModuleName.Boot (TopLevelModuleName')-import Agda.Syntax.Position (Range)-import Agda.Utils.Maybe-import GHC.Generics+import Prelude hiding (null) +import GHC.Generics ( Generic )+import Control.DeepSeq ( NFData(..) ) import Data.Set (Set)+import Data.Text (Text) -import Control.DeepSeq+import Agda.Syntax.TopLevelModuleName.Boot (TopLevelModuleName')+import Agda.Syntax.Position (Range, rangeModule, rStart, Position'(posPos), HasRange(..))+import Agda.Utils.Maybe ( unionMaybeWith )+import Agda.Utils.Null ( Null(..) ) data Induction = Inductive | CoInductive -- Keep in this order!- deriving (Eq, Ord, Show)+ deriving (Eq, Ord, Generic, Show) data Aspect = Comment@@ -18,17 +21,23 @@ | String | Number | Hole- | Symbol -- ^ Symbols like forall, =, ->, etc.- | PrimitiveType -- ^ Things like Set and Prop.- | Name (Maybe NameKind) Bool -- ^ Is the name an operator part?- | Pragma -- ^ Text occurring in pragmas that- -- does not have a more specific- -- aspect.- | Background -- ^ Non-code contents in literate Agda+ | Symbol+ -- ^ Symbols like @forall@, @=@, @->@, etc.+ | PrimitiveType+ -- ^ Things like @Set@ and @Prop@.+ | Name (Maybe NameKind) Bool+ -- ^ 'Bool': Is the name an operator part?+ | Pragma+ -- ^ Text occurring in pragmas+ -- that does not have a more specific aspect.+ | Background+ -- ^ Non-code contents in literate Agda. | Markup- -- ^ Delimiters used to separate the Agda code blocks from the- -- other contents in literate Agda- deriving (Eq, Show, Generic)+ -- ^ Delimiters used to separate the Agda code blocks+ -- from the other contents in literate Agda.+ | URL Text+ -- ^ Uniform Resource Locator aka clickable link.+ deriving (Eq, Show, Generic) -- | @NameKind@s are figured out during scope checking. @@ -70,9 +79,6 @@ | ShadowingInTelescope -- ^ Used for shadowed repeated variable names in telescopes. | CoverageProblem- | IncompletePattern- -- ^ When this constructor is used it is probably a good idea to- -- include a 'note' explaining why the pattern is incomplete. | TypeChecks -- ^ Code which is being type-checked. | MissingDefinition@@ -155,27 +161,45 @@ -- information from the lexer? data TokenBased = TokenBased | NotOnlyTokenBased- deriving (Eq, Show)+ deriving (Eq, Generic, Show) +instance Null TokenBased where+ empty = TokenBased++instance Null Aspects where+ empty = Aspects Nothing mempty "" Nothing TokenBased+ null (Aspects a o s d t) = null a && null o && null s && null d && null t+ instance Eq Aspects where Aspects a o _ d t == Aspects a' o' _ d' t' = (a, o, d, t) == (a', o', d', t') -instance NFData Induction where- rnf Inductive = ()- rnf CoInductive = ()+-- | Compute the 'Aspects' which (possibly) contain a 'DefinitionSite'+-- for the given thing-with-range.+rangeDefinitionSite :: HasRange a => a -> Aspects+rangeDefinitionSite thing = do+ let+ r = getRange thing -instance NFData NameKind where- rnf = \case- Bound -> ()- Generalizable -> ()- Constructor c -> rnf c- Datatype -> ()- Field -> ()- Function -> ()- Module -> ()- Postulate -> ()- Primitive -> ()- Record -> ()- Argument -> ()- Macro -> ()+ defs :: Maybe DefinitionSite+ defs = do+ mod <- rangeModule r+ pos <- posPos <$> rStart r+ pure DefinitionSite+ { defSiteModule = mod+ , defSitePos = fromIntegral pos+ , defSiteHere = False+ , defSiteAnchor = Nothing+ }+ empty{ definitionSite = defs }++------------------------------------------------------------------------+-- NFData instances++instance NFData DefinitionSite+instance NFData OtherAspect+instance NFData TokenBased+instance NFData Induction+instance NFData NameKind+instance NFData Aspects+instance NFData Aspect
src/full/Agda/Syntax/Common/Pretty.hs view
@@ -1,15 +1,16 @@+{-# OPTIONS_GHC -Wunused-imports #-} {-| Pretty printing functions. -} module Agda.Syntax.Common.Pretty ( module Agda.Syntax.Common.Pretty , module Text.PrettyPrint.Annotated- -- This re-export can be removed once <GHC-8.4 is dropped.- , module Data.Semigroup ) where import Prelude hiding (null) +import Control.DeepSeq+ import qualified Data.List as List import qualified Data.Foldable as Fold import qualified Data.IntSet as IntSet@@ -21,9 +22,11 @@ import Data.IntMap (IntMap) import Data.Word (Word64, Word32) import Data.Text (Text)+import Data.Text qualified as Text import Data.Int (Int32) import Data.Map (Map) import Data.Set (Set)+import Data.Tree (Tree(Node)) import qualified Text.PrettyPrint.Annotated as P import Text.PrettyPrint.Annotated hiding@@ -33,23 +36,26 @@ , semi, comma, colon, space, equals, lparen, rparen, lbrack, rbrack , lbrace, rbrace+ , annotate ) -import Data.Semigroup ((<>))+import Agda.Syntax.Common.Aspect+import Agda.Syntax.Position +import Agda.Utils.DocTree qualified as DocTree+import Agda.Utils.FileName import Agda.Utils.Float import Agda.Utils.List1 (List1)-import qualified Agda.Utils.List1 as List1-import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.List1 qualified as List1+import Agda.Utils.List2 (List2)+import Agda.Utils.List2 qualified as List2+import Agda.Utils.Maybe.Strict qualified as Strict import Agda.Utils.Null import Agda.Utils.Size -import Agda.Syntax.Common.Aspect-import Agda.Syntax.Position-import Agda.Utils.Impossible-import Agda.Utils.FileName-+type DocTree = DocTree.DocTree Aspects +--------------------------------------------------------------------------- -- * Pretty class -- | The type of documents. We use documents annotated by 'Aspects' to@@ -80,6 +86,7 @@ prettyShow :: Pretty a => a -> String prettyShow = render . pretty +--------------------------------------------------------------------------- -- * Pretty instances instance Pretty Bool where pretty = text . show@@ -102,6 +109,9 @@ instance a ~ Aspects => Pretty (P.Doc a) where pretty = id +instance a ~ Aspects => Pretty (DocTree.DocTree a) where+ pretty = DocTree.prettyDocTree+ instance Pretty () where pretty _ = P.empty @@ -112,12 +122,19 @@ prettyPrec p Nothing = P.empty prettyPrec p (Just x) = prettyPrec p x +instance Pretty a => Pretty (Strict.Maybe a) where+ prettyPrec p Strict.Nothing = P.empty+ prettyPrec p (Strict.Just x) = prettyPrec p x+ instance Pretty a => Pretty [a] where pretty = prettyList instance Pretty a => Pretty (List1 a) where pretty = prettyList . List1.toList +instance Pretty a => Pretty (List2 a) where+ pretty = prettyList . List2.toList+ instance Pretty IntSet where pretty = prettySet . IntSet.toList @@ -149,8 +166,8 @@ instance Pretty PositionWithoutFile where pretty = prettyLineColumn -instance Pretty IntervalWithoutFile where- pretty (Interval () s e)+prettyInterval :: Eq a => Position' a -> Position' a -> Doc+prettyInterval s e | s == e = start | otherwise = start <> "-" <> end where@@ -166,21 +183,18 @@ | sl == el = pretty ec | otherwise = pretty el <> dot <> pretty ec -instance Pretty a => Pretty (Interval' (Strict.Maybe a)) where- pretty i@(Interval f s e) = file <> pretty (Interval () s e)- where- file :: Doc- file = case f of- Strict.Nothing -> empty- Strict.Just f -> pretty f <> colon+instance Pretty a => Pretty (Interval' a) where+ pretty :: Interval' a -> Doc+ pretty i@(Interval f s e) = applyUnlessNull (pretty f) (\ d -> ((d <> colon) <>)) (prettyInterval s e) -instance Pretty a => Pretty (Range' (Strict.Maybe a)) where+instance Pretty a => Pretty (Range' a) where pretty r = maybe empty pretty (rangeToIntervalWithFile r) instance (Pretty a, HasRange a) => Pretty (PrintRange a) where pretty (PrintRange a) = pretty a <+> parens ("at" <+> pretty (getRange a)) +--------------------------------------------------------------------------- -- * Generalizing the original type from list to Foldable sep, fsep, hsep, hcat, vcat :: Foldable t => t Doc -> Doc@@ -193,11 +207,15 @@ punctuate :: Foldable t => Doc -> t Doc -> [Doc] punctuate d = P.punctuate d . Fold.toList +--------------------------------------------------------------------------- -- * 'Doc' utilities vsep :: [Doc] -> Doc vsep = vcat . List.intersperse "" +twords :: Text -> [Doc]+twords = map pretty . Text.words+ pwords :: String -> [Doc] pwords = map text . words @@ -259,6 +277,33 @@ vcat $ map (\(s, d) -> text s $$ nest (maxLen + 1) d) $ rows where maxLen = maximum $ 0 : filter (< max) (map (length . fst) rows) +-- | Glyphs for drawing a tree with 'prettyTree'.+data TreeGlyphs = TreeGlyphs+ { treeBranch :: Doc -- ^ Connector to a child that has siblings below.+ , treeLastBranch :: Doc -- ^ Connector to the last child.+ , treeContinue :: Doc -- ^ Indentation under a child that has siblings below.+ , treeEmpty :: Doc -- ^ Indentation under the last child.+ }++-- | Render a tree, one line per node, e.g.+--+-- @+-- root+-- ├─ child+-- │ └─ grandchild+-- └─ last child+-- @+prettyTree :: Pretty a => TreeGlyphs -> Tree a -> Doc+prettyTree g (Node root ts0) = vcat $ pretty root : children " " ts0+ where+ children :: Pretty a => Doc -> [Tree a] -> [Doc]+ children pre ts = concat $ zipWith (child pre) (map (const False) (drop 1 ts) ++ [True]) ts++ child :: Pretty a => Doc -> Bool -> Tree a -> [Doc]+ child pre lastChild (Node d ts) =+ (pre <> (if lastChild then treeLastBranch g else treeBranch g) <> pretty d) :+ children (pre <> if lastChild then treeEmpty g else treeContinue g) ts+ -- | Handles strings with newlines properly (preserving indentation) multiLineText :: String -> Doc multiLineText = vcat . map text . lines@@ -285,6 +330,15 @@ [] -> P.empty (doc : docs) -> fsep $ (kw <+> doc) : map (hlSymbol "|" <+>) docs +---------------------------------------------------------------------------+-- * Annotations++-- | Only adds an annotation node if the 'Aspects' is non-'null'.+annotate :: Aspects -> Doc -> Doc+annotate a x+ | null a = x+ | otherwise = rnf a `seq` P.annotate a x+ -- | Attach a simple 'Aspect', rather than a full set of 'Aspects', to a -- document. annotateAspect :: Aspect -> Doc -> Doc@@ -297,8 +351,26 @@ , tokenBased = TokenBased } --- * Syntax highlighting helpers+-- * Hyperlink annotations +-- | Attach a link to a document (cf. LaTeX @\href@).+href :: Text -> Doc -> Doc+href = annotateAspect . URL++-- | A URL formatted as link (cf. LaTeX @\url@).+url :: String -> Doc+url s = href (Text.pack s) (text s)++-- | Link to an issue on the Agda bug tracker.+githubIssue :: Int -> Doc+githubIssue = url . ("https://github.com/agda/agda/issues/" ++) . show++-- | Attach the position of something as the "binding site" of a 'Doc'.+definedAt :: HasRange a => Doc -> a -> Doc+definedAt doc p = annotate (rangeDefinitionSite p) doc++-- ** Basic syntax highlighting helpers+ hlComment, hlSymbol, hlKeyword, hlString, hlNumber, hlHole, hlPrimitiveType, hlPragma :: Doc -> Doc @@ -311,6 +383,31 @@ hlPrimitiveType = annotateAspect PrimitiveType hlPragma = annotateAspect Pragma +-- ** Helpers introducing 'NameKind's++hlNameKind :: NameKind -> Doc -> Doc+hlNameKind k = annotateAspect (Name (Just k) False)++hlBound, hlGeneralizable, hlDatatype, hlField,+ hlFunction, hlModule, hlPostulate, hlPrimitive, hlRecord, hlArgument,+ hlMacro :: Doc -> Doc++hlBound = hlNameKind Bound+hlGeneralizable = hlNameKind Generalizable+hlDatatype = hlNameKind Datatype+hlField = hlNameKind Field+hlFunction = hlNameKind Function+hlModule = hlNameKind Module+hlPostulate = hlNameKind Postulate+hlPrimitive = hlNameKind Primitive+hlRecord = hlNameKind Record+hlArgument = hlNameKind Argument+hlMacro = hlNameKind Macro++hlConstructor :: Induction -> Doc -> Doc+hlConstructor = hlNameKind . Constructor++--------------------------------------------------------------------------- -- * Delimiter wrappers -- -- These use the 'Symbol' highlight for the punctuation characters.@@ -326,12 +423,12 @@ brackets p = lbrack <> p <> rbrack braces p = lbrace <> p <> rbrace -semi, comma, colon, dot, space, equals, lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc+semi, comma, colon, dot, pipe, equals, lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc semi = hlSymbol $ char ';' comma = hlSymbol $ char ',' colon = hlSymbol $ char ':' dot = hlSymbol $ char '.'-space = hlSymbol $ char ' '+pipe = hlSymbol $ char '|' equals = hlSymbol $ char '=' lparen = hlSymbol $ char '(' rparen = hlSymbol $ char ')'
src/full/Agda/Syntax/Common/Pretty/ANSI.hs view
@@ -1,30 +1,60 @@-module Agda.Syntax.Common.Pretty.ANSI where-import Control.Monad.IO.Class-import Control.Monad+{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-} -import Text.PrettyPrint.Annotated.HughesPJ (renderDecoratedM)+module Agda.Syntax.Common.Pretty.ANSI ( printTreeAnsi, putDocLn, putDocTree, putDocTreeLn ) where -import Agda.Interaction.Options.HasOptions-import Agda.Interaction.Options.Base-import Agda.Syntax.Common.Aspect-import Agda.Syntax.Common.Pretty-import Agda.Utils.Monad+import Control.Monad.IO.Class ( MonadIO(..) )+import Data.Functor ( (<&>) )+import Data.Text qualified as Text+import Data.Text.IO qualified as Text import System.Console.ANSI-import System.IO+import System.Console.ANSI.Codes ( osc ) --- | Render an annotated, pretty-printing 'Doc'ument into a string--- suitable for printing on VT100-compatible terminals.-renderAnsiIO :: Doc -> IO ()-renderAnsiIO = renderDecoratedM start end putStr (putStr "\n") where- start = maybe mempty (setSGR . aspSGR) . aspect- end _ = setSGR [Reset]+-- UNUSED:+-- import Text.PrettyPrint.Annotated.HughesPJ ( renderDecoratedM ) - aspSGR :: Aspect -> [SGR]- aspSGR String = [SetColor Foreground Dull Red]- aspSGR Number = [SetColor Foreground Dull Magenta]- aspSGR PrimitiveType = [SetColor Foreground Dull Blue]- aspSGR (Name (Just nk) _) = case nk of+import Agda.Interaction.Options.HasOptions ( HasOptions(commandLineOptions) )+import Agda.Interaction.Options.Base++import Agda.Syntax.Common.Aspect as Aspect+import Agda.Syntax.Common.Pretty ( Doc, DocTree )++import Agda.Utils.DocTree ( renderTree', renderToTree, treeToTextNoAnn )+import Agda.Utils.IO.Terminal ( stdoutSupportsANSI )++-- | Print an annotated, pretty-printing 'DocTree' onto a VT100-compatible terminal.+printTreeAnsi :: DocTree -> IO ()+printTreeAnsi = renderTree' Text.putStr \ ann t -> startAnn ann <> t <> endAnn ann++startAnn :: Aspects -> IO ()+startAnn ann = maybe mempty (\ a -> setSGR (aspSGR a) <> startIO a) $ aspect ann++endAnn :: Aspects -> IO ()+endAnn ann = maybe mempty endIO (aspect ann) <> setSGR [Reset]++-- Andreas, 2025-07-28+-- ansi-terminal has no good interface for hyperlinks in the start/end style,+-- so we have to implement this manually here, breaking the abstraction.+startIO :: Aspect -> IO ()+startIO = \case+ URL ref -> putStr $ osc "8" (";" ++ Text.unpack ref)+ _ -> return ()++endIO :: Aspect -> IO ()+endIO = \case+ URL _ -> putStr $ osc "8" ";"+ _ -> return ()++aspSGR :: Aspect -> [SGR]+aspSGR = \case+ URL _url -> [SetUnderlining SingleUnderline]+ String -> [SetColor Foreground Dull Red]+ Number -> [SetColor Foreground Dull Magenta]+ PrimitiveType -> [SetColor Foreground Dull Blue]+ Name Nothing _ -> []+ Name (Just nk) _ -> case nk of Bound -> [] Generalizable -> [] Argument -> []@@ -43,18 +73,40 @@ Primitive -> [SetColor Foreground Dull Blue] Macro -> [SetColor Foreground Dull Cyan]- aspSGR _ = []+ Aspect.Background -> []+ Comment -> []+ Hole -> []+ Keyword -> []+ Markup -> []+ Pragma -> []+ Symbol -> [] +-- UNUSED:+-- -- | Render an annotated, pretty-printing 'Doc'ument to a VT100-compatible terminal.+-- renderAnsiIO :: Doc -> IO ()+-- renderAnsiIO = renderDecoratedM startAnn endAnn putStr (putStr "\n")++putDocTree :: (MonadIO m, HasOptions m) => DocTree -> m ()+putDocTree doc = do+ col <- commandLineOptions <&> optDiagnosticsColour >>= \case+ AutoColour -> liftIO stdoutSupportsANSI+ AlwaysColour -> pure True+ NeverColour -> pure False++ liftIO do+ if col+ then printTreeAnsi doc+ else Text.putStr (treeToTextNoAnn doc)++putDocTreeLn :: (MonadIO m, HasOptions m) => DocTree -> m ()+putDocTreeLn doc = do+ putDocTree doc+ liftIO $ putStr "\n"+ putDoc :: (MonadIO m, HasOptions m) => Doc -> m ()-putDoc doc = do- outputcol <- liftIO (hSupportsANSI stdout)- wantscol <- commandLineOptions- let- col = case optDiagnosticsColour wantscol of- AutoColour -> outputcol- AlwaysColour -> True- NeverColour -> False+putDoc = putDocTree . renderToTree - liftIO $ if col- then renderAnsiIO doc- else putStrLn (render doc)+putDocLn :: (MonadIO m, HasOptions m) => Doc -> m ()+putDocLn doc = do+ putDoc doc+ liftIO $ putStr "\n"
src/full/Agda/Syntax/Concrete.hs view
@@ -17,6 +17,7 @@ , rawApp, rawAppP , isSingleIdentifierP, removeParenP , isPattern, isAbsurdP, isBinderP+ , PossiblyProjectionPattern(..) , observeHiding , observeRelevance , observeModifiers@@ -29,7 +30,7 @@ , mkBinder , LamBinding , LamBinding'(..)- , dropTypeAndModality+ , DefParameters, parametersToDefParameters, defParametersToParameters , TypedBinding , TypedBinding'(..) , RecordAssignment@@ -40,7 +41,7 @@ , TacticAttribute , TacticAttribute'(..) , Telescope, Telescope1- , lamBindingsToTelescope+ , Parameters, parametersToTelescope , makePi , mkLam, mkLet, mkTLet -- * Declarations@@ -53,8 +54,9 @@ , TypeSignatureOrInstanceBlock , ImportDirective, Using, ImportedName , Renaming, RenamingDirective, HidingDirective- , AsName'(..), AsName- , OpenShortHand(..), RewriteEqn, WithExpr+ , AsName'(..), AsName, RawOpenArgs+ , OpenShortHand(..)+ , RewriteEqn, WithExpr , LHS(..), Pattern(..), LHSCore(..) , LamClause(..) , RHS, RHS'(..)@@ -87,7 +89,7 @@ import Agda.Syntax.Position import Agda.Syntax.Common-import Agda.Syntax.Common.Aspect (NameKind)+import Agda.Syntax.Common.Aspect (Aspects) import Agda.Syntax.Fixity import Agda.Syntax.Literal @@ -178,8 +180,10 @@ -- The 'KwRange' is for the @record@ keyword. | Let Range (List1 Declaration) (Maybe Expr) -- ^ ex: @let Ds in e@, missing body when parsing do-notation let | Paren Range Expr -- ^ ex: @(e)@- | IdiomBrackets Range [Expr] -- ^ ex: @(| e1 | e2 | .. | en |)@ or @(|)@- | DoBlock Range (List1 DoStmt) -- ^ ex: @do x <- m1; m2@+ | IdiomBrackets Range (Maybe QName) [Expr] -- ^ ex: @(| e1 | e2 | .. | en |)@ or @(|)@+ | DoBlock KwRange (Maybe QName) (List1 DoStmt)+ -- ^ ex: @do x <- m1; m2@+ -- The 'KwRange' is for the @do@ keyword. | Absurd Range -- ^ ex: @()@ or @{}@, only in patterns | As Range Name Expr -- ^ ex: @x\@p@, only in patterns | Dot KwRange Expr -- ^ ex: @.p@, only in patterns@@ -191,13 +195,16 @@ | DontCare Expr -- ^ to print irrelevant things | Equal Range Expr Expr -- ^ ex: @a = b@, used internally in the parser | Ellipsis Range -- ^ @...@, used internally to parse patterns.- | KnownIdent NameKind QName+ | KnownIdent Aspects QName -- ^ An identifier coming from abstract syntax, for which we know a -- precise syntactic highlighting class (used in printing).- | KnownOpApp NameKind Range QName (Set1 A.Name) OpAppArgs+ | KnownOpApp Aspects Range QName (Set1 A.Name) OpAppArgs -- ^ An operator application coming from abstract syntax, for which -- we know a precise syntactic highlighting class (used in -- printing).+ | Highlighted Aspects Expr+ -- ^ An arbitrary expression bundled with highlighting information+ -- from abstract (or internal) syntax | Generalized Expr deriving Eq @@ -232,8 +239,9 @@ | WildP Range -- ^ @_@ | AbsurdP Range -- ^ @()@ | AsP Range Name Pattern -- ^ @x\@p@- | DotP KwRange Range Expr -- ^ @.e@, the 'KwRange' is for the dot,- -- the 'Range' for the whole thing (including the dot).+ | DotP KwRange Range !PossiblyProjectionPattern Expr+ -- ^ @.e@, the 'KwRange' is for the dot, the 'Range' for the whole thing (including the dot).+ -- If the dot pattern came from parsing e.g. @.{e}@ it cannot be a projection pattern. | LitP Range Literal -- ^ @0@, @1@, etc. | RecP KwRange Range [FieldAssignment' Pattern] -- ^ @record {x = p; y = q}@. The 'KwRange' is for the @record@ keyword.@@ -244,6 +252,12 @@ | WithP Range Pattern -- ^ @| p@, for with-patterns. deriving Eq +-- | Can a dot pattern be interpreted as projection pattern?+data PossiblyProjectionPattern+ = CouldBeProjectionPattern -- ^ Yes.+ | CannotBeProjectionPattern -- ^ No.+ deriving (Eq, Show)+ data DoStmt = DoBind Range Pattern Expr [LamClause] -- ^ @p ← e where cs@ | DoThen Expr@@ -265,8 +279,13 @@ mkBinder :: a -> Binder' a mkBinder = Binder Nothing UserBinderName --- | A lambda binding is either domain free or typed.+-- | Parameters supplied to data and record definitions (as opposed to their signatures)+-- are stripped of their type information.+-- They also cannot contain @let@ or pattern bindings or tactic attributes.+type DefParameters = [WithHiding (Named_ Name)] +-- | A lambda binding is either untyped (domain free) or typed ('TypedBinding').+ type LamBinding = LamBinding' TypedBinding data LamBinding' a = DomainFree (NamedArg Binder)@@ -275,13 +294,26 @@ -- ^ . @(xs : e)@ or @{xs : e}@ deriving (Functor, Foldable, Traversable, Eq) --- | Drop type annotations and lets from bindings.-dropTypeAndModality :: LamBinding -> [LamBinding]-dropTypeAndModality (DomainFull (TBind _ xs _)) =- map (DomainFree . setModality defaultModality) $ List1.toList xs-dropTypeAndModality (DomainFull TLet{}) = []-dropTypeAndModality (DomainFree x) = [DomainFree $ setModality defaultModality x]+-- | Parameters are sequences of typed or untyped bindings.+type Parameters = [LamBinding] +-- | Drop type annotations and modalities from bindings.+-- Also drop let, patterns, fixity, and tactics,+-- but those should not be present in the first place when using this function,+-- because all such cannot occur in data and record parameters.+parametersToDefParameters :: Parameters -> DefParameters+parametersToDefParameters = concatMap \case+ DomainFree x -> [strip x]+ DomainFull (TBind _ xs _) -> map strip $ List1.toList xs+ DomainFull TLet{} -> __IMPOSSIBLE__+ where+ strip :: NamedArg Binder -> WithHiding (Named_ Name)+ strip = unArgKeepHiding . fmap (fmap (boundName . binderName))++defParametersToParameters :: DefParameters -> Parameters+defParametersToParameters = map \ (WithHiding h n) ->+ DomainFree $ setHiding h $ defaultArg $ mkBinder_ <$> n+ data BoundName = BName { boundName :: Name , bnameFixity :: Fixity'@@ -322,11 +354,11 @@ type Telescope1 = List1 TypedBinding type Telescope = [TypedBinding] --- | We can try to get a @Telescope@ from a @[LamBinding]@.+-- | We can get a @Telescope@ from @Parameters@. -- If we have a type annotation already, we're happy. -- Otherwise we manufacture a binder with an underscore for the type.-lamBindingsToTelescope :: Range -> [LamBinding] -> Telescope-lamBindingsToTelescope r = fmap $ \case+parametersToTelescope :: Range -> Parameters -> Telescope+parametersToTelescope r = fmap $ \case DomainFull ty -> ty DomainFree nm -> TBind r (List1.singleton nm) $ Underscore r Nothing @@ -465,7 +497,7 @@ -- | From the parser, we get an expression for the @as@-'Name', which -- we have to parse into a 'Name'.-type AsName = AsName' (Either Expr Name)+type AsName = AsName' Name {-------------------------------------------------------------------------- Declarations@@ -508,18 +540,19 @@ data Declaration = TypeSig ArgInfo TacticAttribute Name Expr- -- ^ Axioms and functions can be irrelevant. (Hiding should be NotHidden)+ -- ^ Axioms and functions can be irrelevant. ('Hiding' should be 'NotHidden')+ -- 'TacticAttribute' makes only sense in 'Generalize' blocks. | FieldSig IsInstance TacticAttribute Name (Arg Expr) | Generalize KwRange [TypeSignature] -- ^ Variables to be generalized, can be hidden and/or irrelevant. | Field KwRange [FieldSignature]- | FunClause LHS RHS WhereClause Catchall- | DataSig Range Erased Name [LamBinding] Expr -- ^ lone data signature in mutual block- | Data Range Erased Name [LamBinding] Expr+ | FunClause ArgInfo LHS RHS WhereClause Catchall -- ^ Only 'Modality' is used in 'ArgInfo'.+ | DataSig Range Erased Name Parameters Expr -- ^ lone data signature in mutual block+ | Data Range Erased Name Parameters Expr [TypeSignatureOrInstanceBlock]- | DataDef Range Name [LamBinding] [TypeSignatureOrInstanceBlock]- | RecordSig Range Erased Name [LamBinding] Expr -- ^ lone record signature in mutual block- | RecordDef Range Name [RecordDirective] [LamBinding] [Declaration]- | Record Range Erased Name [RecordDirective] [LamBinding] Expr+ | DataDef Range Name Parameters [TypeSignatureOrInstanceBlock]+ | RecordSig Range Erased Name Parameters Expr -- ^ lone record signature in mutual block+ | RecordDef Range Name [RecordDirective] Parameters [Declaration]+ | Record Range Erased Name [RecordDirective] Parameters Expr [Declaration] | Infix Fixity (List1 Name) | Syntax Name Notation -- ^ notation declaration for a name@@ -539,8 +572,8 @@ | Macro KwRange [Declaration] | Postulate KwRange [TypeSignatureOrInstanceBlock] | Primitive KwRange [TypeSignature]- | Open Range QName ImportDirective- | Import Range QName (Maybe AsName) !OpenShortHand ImportDirective+ | Open KwRange QName ImportDirective+ | Import OpenShortHand KwRange QName (Either AsName RawOpenArgs) ImportDirective | ModuleMacro Range Erased Name ModuleApplication !OpenShortHand ImportDirective | Module Range Erased QName Telescope [Declaration]@@ -557,6 +590,17 @@ -- ^ @unfolding ...@ deriving Eq +-- | Expressions usually instantiating module parameters as in+-- @+-- open import Monoid Carrier _==_+-- @+-- that might also code an @as@ clause e.g. in+-- @+-- open import File as M+-- @+-- The parser does not distinguish these so we do it in the nicifier.+type RawOpenArgs = [Expr]+ -- | Return 'Pragma' if 'Declaration' is 'Pragma'. {-# SPECIALIZE isPragma :: Declaration -> Maybe Pragma #-} {-# SPECIALIZE isPragma :: Declaration -> [Pragma] #-}@@ -575,7 +619,7 @@ FieldSig _ _ _ _ -> empty Generalize _ _ -> empty Field _ _ -> empty- FunClause _ _ _ _ -> empty+ FunClause _ _ _ _ _ -> empty DataSig _ _ _ _ _ -> empty Data _ _ _ _ _ _ -> empty DataDef _ _ _ _ -> empty@@ -603,7 +647,9 @@ -- ^ @M {{...}}@ deriving Eq -data OpenShortHand = DoOpen | DontOpen+data OpenShortHand+ = DoOpen KwRange -- ^ Range of the @open@ keyword.+ | DontOpen deriving (Eq, Show, Generic) -- Pragmas ----------------------------------------------------------------@@ -621,8 +667,7 @@ -- ^ Throws an internal error in the scope checker. -- The 'String's are words to be displayed with the error. | EtaPragma Range QName- -- ^ For coinductive records, use pragma instead of regular- -- @eta-equality@ definition (as it is might make Agda loop).+ -- ^ Removed, replaced by 'EtaEqualityPragma'. | WarningOnUsage Range QName Text -- ^ Applies to the named function | WarningOnImport Range Text@@ -637,6 +682,9 @@ -- Attached (more or less) pragmas handled in the nicifier (Concrete.Definitions): | CatchallPragma Range -- ^ Applies to the following function clause.+ | EtaEqualityPragma Range+ -- ^ Applies to the following record type.+ -- Force @eta-equality@ for the attached @record@ type for unguarded and @coinductive@ records. | TerminationCheckPragma Range (TerminationCheck Name) -- ^ Applies to the following function (and all that are mutually recursive with it) -- or to the functions in the following mutual block.@@ -660,8 +708,13 @@ -- | Modules: Top-level pragmas plus other top-level declarations. data Module = Mod- { modPragmas :: [Pragma]+ { modName :: QName+ -- ^ The module name as inferred by the parser.+ -- Could be @_@ if the parser inserted a top-level module declaration.+ , modPragmas :: [Pragma]+ -- ^ The top-level OPTIONS pragmas. , modDecls :: [Declaration]+ -- ^ All the other declarations, including the top-level module. } -- | Splits off allowed (= import) declarations before the first@@ -805,8 +858,7 @@ Underscore r _ -> pure $ WildP r Absurd r -> pure $ AbsurdP r As r x e -> pushUnderBracesP r (AsP r x) <$> loop e- e0@(Dot kwr e) -> pure $ pushUnderBracesE r (DotP kwr r) e- where r = getRange e0+ e0@(Dot kwr e) -> pure $ pushDotUnderBraces kwr (getRange e0) e -- Wen, 2020-08-27: We disallow Float patterns, since equality for floating -- point numbers is not stable across architectures and with different -- compiler flags.@@ -837,11 +889,12 @@ InstanceP _ p -> InstanceP r $ fmap f p p -> f p - pushUnderBracesE :: Range -> (Expr -> Pattern) -> (Expr -> Pattern)- pushUnderBracesE r f = \case- HiddenArg _ p -> HiddenP r $ fmap f p- InstanceArg _ p -> InstanceP r $ fmap f p- p -> f p+ pushDotUnderBraces :: KwRange -> Range -> Expr -> Pattern+ pushDotUnderBraces kwr r = \case+ HiddenArg _ e -> HiddenP r $ fmap (DotP kwr r CannotBeProjectionPattern) e+ InstanceArg _ e -> InstanceP r $ fmap (DotP kwr r CannotBeProjectionPattern) e+ Paren _ e -> DotP kwr r CannotBeProjectionPattern e+ e -> DotP kwr r CouldBeProjectionPattern e isAbsurdP :: Pattern -> Maybe (Range, Hiding) isAbsurdP = \case@@ -868,6 +921,9 @@ -- Null ------------------------------------------------------------------------ +instance Null OpenShortHand where+ empty = DontOpen+ -- | A 'WhereClause' is 'null' when the @where@ keyword is absent. -- An empty list of declarations does not count as 'null' here. @@ -907,6 +963,11 @@ -- HasRange instances ------------------------------------------------------------------------ +instance HasRange OpenShortHand where+ getRange = \case+ DoOpen kwr -> getRange kwr+ DontOpen -> empty+ instance HasRange e => HasRange (OpApp e) where getRange = \case Ordinary e -> getRange e@@ -914,41 +975,42 @@ instance HasRange Expr where getRange = \case- Ident x -> getRange x- Lit r _ -> r- QuestionMark r _ -> r- Underscore r _ -> r- App r _ _ -> r- RawApp r _ -> r- OpApp r _ _ _ -> r- WithApp r _ _ -> r- Lam r _ _ -> r- AbsurdLam r _ -> r- ExtendedLam r _ _ -> r- Fun r _ _ -> r- Pi b e -> fuseRange b e- Let r _ _ -> r- Paren r _ -> r- IdiomBrackets r _ -> r- DoBlock r _ -> r- As r _ _ -> r- Dot r e -> getRange (r, e)- DoubleDot r e -> getRange (r, e)- Absurd r -> r- HiddenArg r _ -> r- InstanceArg r _ -> r- Rec _ r _ -> r- RecUpdate _ r _ _ -> r- Quote r -> r- QuoteTerm r -> r- Unquote r -> r- Tactic r _ -> r- DontCare{} -> noRange- Equal r _ _ -> r- Ellipsis r -> r- Generalized e -> getRange e- KnownIdent _ q -> getRange q- KnownOpApp _ r _ _ _ -> r+ Ident x -> getRange x+ Lit r _ -> r+ QuestionMark r _ -> r+ Underscore r _ -> r+ App r _ _ -> r+ RawApp r _ -> r+ OpApp r _ _ _ -> r+ WithApp r _ _ -> r+ Lam r _ _ -> r+ AbsurdLam r _ -> r+ ExtendedLam r _ _ -> r+ Fun r _ _ -> r+ Pi b e -> fuseRange b e+ Let r _ _ -> r+ Paren r _ -> r+ IdiomBrackets r _ _ -> r+ DoBlock r q ds -> getRange (r, q, ds)+ As r _ _ -> r+ Dot r e -> getRange (r, e)+ DoubleDot r e -> getRange (r, e)+ Absurd r -> r+ HiddenArg r _ -> r+ InstanceArg r _ -> r+ Rec _ r _ -> r+ RecUpdate _ r _ _ -> r+ Quote r -> r+ QuoteTerm r -> r+ Unquote r -> r+ Tactic r _ -> r+ DontCare{} -> noRange+ Equal r _ _ -> r+ Ellipsis r -> r+ Generalized e -> getRange e+ KnownIdent _ q -> getRange q+ KnownOpApp _ r _ _ _ -> r+ Highlighted _ e -> getRange e -- instance HasRange Telescope where -- getRange (TeleBind bs) = getRange bs@@ -996,7 +1058,7 @@ getRange (TypeSig _ _ x t) = fuseRange x t getRange (FieldSig _ _ x t) = fuseRange x t getRange (Field kwr ds) = fuseRange kwr ds- getRange (FunClause lhs rhs wh _) = fuseRange lhs rhs `fuseRange` wh+ getRange (FunClause ai lhs rhs wh _) = ai `fuseRange` lhs `fuseRange` rhs `fuseRange` wh getRange (DataSig r _ _ _ _) = r getRange (Data r _ _ _ _ _) = r getRange (DataDef r _ _ _) = r@@ -1008,10 +1070,10 @@ getRange (LoneConstructor kwr ds)= fuseRange kwr ds getRange (Abstract kwr ds) = fuseRange kwr ds getRange (Generalize kwr ds) = fuseRange kwr ds- getRange (Open r _ _) = r+ getRange (Open kwr x dir) = getRange (kwr, x, dir) getRange (ModuleMacro r _ _ _ _ _) = r- getRange (Import r _ _ _ _) = r+ getRange (Import a b c d e) = getRange (a, b, c, d, e) getRange (InstanceB kwr _) = getRange kwr getRange (Macro kwr ds) = fuseRange kwr ds getRange (Private kwr _ ds) = fuseRange kwr ds@@ -1061,6 +1123,7 @@ getRange (InlinePragma r _ _) = r getRange (ImpossiblePragma r _) = r getRange (EtaPragma r _) = r+ getRange (EtaEqualityPragma r) = r getRange (TerminationCheckPragma r _) = r getRange (NoCoverageCheckPragma r) = r getRange (WarningOnUsage r _ _) = r@@ -1089,7 +1152,7 @@ getRange (QuoteP r) = r getRange (HiddenP r _) = r getRange (InstanceP r _) = r- getRange (DotP _kwr r _) = r+ getRange (DotP _kwr r _ _) = r getRange (RecP _kwr r _) = r getRange (EqualP r _) = r getRange (EllipsisP r _) = r@@ -1111,7 +1174,7 @@ setRange r (QuoteP _) = QuoteP r setRange r (HiddenP _ p) = HiddenP r p setRange r (InstanceP _ p) = InstanceP r p- setRange r (DotP _ _ e) = DotP empty r e+ setRange r (DotP _ _ ppp e) = DotP empty r ppp e setRange r (RecP _ _ fs) = RecP empty r fs setRange r (EqualP _ es) = EqualP r es setRange r (EllipsisP _ mp) = EllipsisP r mp@@ -1124,6 +1187,11 @@ -- KillRange instances ------------------------------------------------------------------------ +instance KillRange OpenShortHand where+ killRange = \case+ DoOpen _ -> DoOpen empty+ DontOpen -> DontOpen+ instance KillRange a => KillRange (FieldAssignment' a) where killRange (FieldAssignment a b) = killRangeN FieldAssignment a b @@ -1146,11 +1214,11 @@ killRange (PatternOrCopattern _) = PatternOrCopattern noRange instance KillRange Declaration where- killRange (TypeSig i t n e) = killRangeN (TypeSig i) t n e+ killRange (TypeSig ai t n e) = killRangeN TypeSig ai t n e killRange (FieldSig i t n e) = killRangeN FieldSig i t n e killRange (Generalize r ds ) = killRangeN (Generalize empty) ds killRange (Field r fs) = killRangeN (Field empty) fs- killRange (FunClause l r w ca) = killRangeN FunClause l r w ca+ killRange (FunClause ai l r w ca) = killRangeN FunClause ai l r w ca killRange (DataSig _ er n l e) = killRangeN (DataSig noRange) er n l e killRange (Data _ er n l e c) = killRangeN (Data noRange) er n l e c killRange (DataDef _ n l c) = killRangeN (DataDef noRange) n l c@@ -1170,8 +1238,8 @@ killRange (Macro _ d) = killRangeN (Macro empty) d killRange (Postulate _ t) = killRangeN (Postulate empty) t killRange (Primitive _ t) = killRangeN (Primitive empty) t- killRange (Open _ q i) = killRangeN (Open noRange) q i- killRange (Import _ q a o i) = killRangeN (\q a -> Import noRange q a o) q a i+ killRange (Open _ q i) = killRangeN (Open empty) q i+ killRange (Import a b c d e) = killRangeN Import a b c d e killRange (ModuleMacro _ e n m o i) = killRangeN (\e n m -> ModuleMacro noRange e n m o)@@ -1185,41 +1253,42 @@ killRange (Unfolding r xs) = killRangeN (Unfolding empty) xs instance KillRange Expr where- killRange (Ident q) = killRangeN Ident q- killRange (Lit _ l) = killRangeN (Lit noRange) l- killRange (QuestionMark _ n) = QuestionMark noRange n- killRange (Underscore _ n) = Underscore noRange n- killRange (RawApp _ e) = killRangeN (RawApp noRange) e- killRange (App _ e a) = killRangeN (App noRange) e a- killRange (OpApp _ n ns o) = killRangeN (OpApp noRange) n ns o- killRange (WithApp _ e es) = killRangeN (WithApp noRange) e es- killRange (HiddenArg _ n) = killRangeN (HiddenArg noRange) n- killRange (InstanceArg _ n) = killRangeN (InstanceArg noRange) n- killRange (Lam _ l e) = killRangeN (Lam noRange) l e- killRange (AbsurdLam _ h) = killRangeN (AbsurdLam noRange) h- killRange (ExtendedLam _ e lrw) = killRangeN (ExtendedLam noRange) e lrw- killRange (Fun _ e1 e2) = killRangeN (Fun noRange) e1 e2- killRange (Pi t e) = killRangeN Pi t e- killRange (Rec _ _ ne) = killRangeN (Rec empty noRange) ne- killRange (RecUpdate _ _ e ne) = killRangeN (RecUpdate empty noRange) e ne- killRange (Let _ d e) = killRangeN (Let noRange) d e- killRange (Paren _ e) = killRangeN (Paren noRange) e- killRange (IdiomBrackets _ es) = killRangeN (IdiomBrackets noRange) es- killRange (DoBlock _ ss) = killRangeN (DoBlock noRange) ss- killRange (Absurd _) = Absurd noRange- killRange (As _ n e) = killRangeN (As noRange) n e- killRange (Dot _ e) = killRangeN (Dot empty) e- killRange (DoubleDot _ e) = killRangeN (DoubleDot empty) e- killRange (Quote _) = Quote noRange- killRange (QuoteTerm _) = QuoteTerm noRange- killRange (Unquote _) = Unquote noRange- killRange (Tactic _ t) = killRangeN (Tactic noRange) t- killRange (DontCare e) = killRangeN DontCare e- killRange (Equal _ x y) = Equal noRange x y- killRange (Ellipsis _) = Ellipsis noRange- killRange (Generalized e) = killRangeN Generalized e- killRange (KnownIdent a b) = killRangeN (KnownIdent a) b- killRange (KnownOpApp a b c d e) = killRangeN (KnownOpApp a) b c d e+ killRange (Ident q) = killRangeN Ident q+ killRange (Lit _ l) = killRangeN (Lit noRange) l+ killRange (QuestionMark _ n) = QuestionMark noRange n+ killRange (Underscore _ n) = Underscore noRange n+ killRange (RawApp _ e) = killRangeN (RawApp noRange) e+ killRange (App _ e a) = killRangeN (App noRange) e a+ killRange (OpApp _ n ns o) = killRangeN (OpApp noRange) n ns o+ killRange (WithApp _ e es) = killRangeN (WithApp noRange) e es+ killRange (HiddenArg _ n) = killRangeN (HiddenArg noRange) n+ killRange (InstanceArg _ n) = killRangeN (InstanceArg noRange) n+ killRange (Lam _ l e) = killRangeN (Lam noRange) l e+ killRange (AbsurdLam _ h) = killRangeN (AbsurdLam noRange) h+ killRange (ExtendedLam _ e lrw) = killRangeN (ExtendedLam noRange) e lrw+ killRange (Fun _ e1 e2) = killRangeN (Fun noRange) e1 e2+ killRange (Pi t e) = killRangeN Pi t e+ killRange (Rec _ _ ne) = killRangeN (Rec empty noRange) ne+ killRange (RecUpdate _ _ e ne) = killRangeN (RecUpdate empty noRange) e ne+ killRange (Let _ d e) = killRangeN (Let noRange) d e+ killRange (Paren _ e) = killRangeN (Paren noRange) e+ killRange (IdiomBrackets _ q es) = killRangeN (IdiomBrackets noRange) q es+ killRange (DoBlock _ q ss) = killRangeN (DoBlock empty) q ss+ killRange (Absurd _) = Absurd noRange+ killRange (As _ n e) = killRangeN (As noRange) n e+ killRange (Dot _ e) = killRangeN (Dot empty) e+ killRange (DoubleDot _ e) = killRangeN (DoubleDot empty) e+ killRange (Quote _) = Quote noRange+ killRange (QuoteTerm _) = QuoteTerm noRange+ killRange (Unquote _) = Unquote noRange+ killRange (Tactic _ t) = killRangeN (Tactic noRange) t+ killRange (DontCare e) = killRangeN DontCare e+ killRange (Equal _ x y) = Equal noRange x y+ killRange (Ellipsis _) = Ellipsis noRange+ killRange (Generalized e) = killRangeN Generalized e+ killRange (KnownIdent a b) = killRangeN (KnownIdent a) b+ killRange (KnownOpApp a b c d e) = killRangeN (KnownOpApp a) b c d e+ killRange (Highlighted a b) = killRangeN (Highlighted a) b instance KillRange LamBinding where killRange (DomainFree b) = killRangeN DomainFree b@@ -1255,7 +1324,7 @@ killRange (WildP _) = WildP noRange killRange (AbsurdP _) = AbsurdP noRange killRange (AsP _ n p) = killRangeN (AsP noRange) n p- killRange (DotP _ _ e) = killRangeN (DotP empty noRange) e+ killRange (DotP _ _ ppp e) = killRangeN (DotP empty noRange ppp) e killRange (LitP _ l) = killRangeN (LitP noRange) l killRange (QuoteP _) = QuoteP noRange killRange (RecP _ _ fs) = killRangeN (RecP empty noRange) fs@@ -1281,6 +1350,7 @@ killRange (CatchallPragma _) = CatchallPragma noRange killRange (DisplayPragma _ lhs rhs) = killRangeN (DisplayPragma noRange) lhs rhs killRange (EtaPragma _ q) = killRangeN (EtaPragma noRange) q+ killRange (EtaEqualityPragma _) = EtaEqualityPragma noRange killRange (NoPositivityCheckPragma _) = NoPositivityCheckPragma noRange killRange (PolarityPragma _ q occs) = killRangeN (\q -> PolarityPragma noRange q occs) q killRange (NoUniverseCheckPragma _) = NoUniverseCheckPragma noRange@@ -1307,41 +1377,42 @@ -- | Ranges are not forced. instance NFData Expr where- rnf (Ident a) = rnf a- rnf (Lit _ a) = rnf a- rnf (QuestionMark _ a) = rnf a- rnf (Underscore _ a) = rnf a- rnf (RawApp _ a) = rnf a- rnf (App _ a b) = rnf a `seq` rnf b- rnf (OpApp _ a b c) = rnf a `seq` rnf b `seq` rnf c- rnf (WithApp _ a b) = rnf a `seq` rnf b- rnf (HiddenArg _ a) = rnf a- rnf (InstanceArg _ a) = rnf a- rnf (Lam _ a b) = rnf a `seq` rnf b- rnf (AbsurdLam _ a) = rnf a- rnf (ExtendedLam _ a b) = rnf a `seq` rnf b- rnf (Fun _ a b) = rnf a `seq` rnf b- rnf (Pi a b) = rnf a `seq` rnf b- rnf (Rec _ _ a) = rnf a- rnf (RecUpdate _ _ a b) = rnf a `seq` rnf b- rnf (Let _ a b) = rnf a `seq` rnf b- rnf (Paren _ a) = rnf a- rnf (IdiomBrackets _ a) = rnf a- rnf (DoBlock _ a) = rnf a- rnf (Absurd _) = ()- rnf (As _ a b) = rnf a `seq` rnf b- rnf (Dot _ a) = rnf a- rnf (DoubleDot _ a) = rnf a- rnf (Quote _) = ()- rnf (QuoteTerm _) = ()- rnf (Tactic _ a) = rnf a- rnf (Unquote _) = ()- rnf (DontCare a) = rnf a- rnf (Equal _ a b) = rnf a `seq` rnf b- rnf (Ellipsis _) = ()- rnf (Generalized e) = rnf e- rnf (KnownIdent a b) = rnf b- rnf (KnownOpApp a b c d e) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf c+ rnf (Ident a) = rnf a+ rnf (Lit _ a) = rnf a+ rnf (QuestionMark _ a) = rnf a+ rnf (Underscore _ a) = rnf a+ rnf (RawApp _ a) = rnf a+ rnf (App _ a b) = rnf a `seq` rnf b+ rnf (OpApp _ a b c) = rnf a `seq` rnf b `seq` rnf c+ rnf (WithApp _ a b) = rnf a `seq` rnf b+ rnf (HiddenArg _ a) = rnf a+ rnf (InstanceArg _ a) = rnf a+ rnf (Lam _ a b) = rnf a `seq` rnf b+ rnf (AbsurdLam _ a) = rnf a+ rnf (ExtendedLam _ a b) = rnf a `seq` rnf b+ rnf (Fun _ a b) = rnf a `seq` rnf b+ rnf (Pi a b) = rnf a `seq` rnf b+ rnf (Rec _ _ a) = rnf a+ rnf (RecUpdate _ _ a b) = rnf a `seq` rnf b+ rnf (Let _ a b) = rnf a `seq` rnf b+ rnf (Paren _ a) = rnf a+ rnf (IdiomBrackets _ a b) = rnf a `seq` rnf b+ rnf (DoBlock _ a b) = rnf a `seq` rnf b+ rnf (Absurd _) = ()+ rnf (As _ a b) = rnf a `seq` rnf b+ rnf (Dot _ a) = rnf a+ rnf (DoubleDot _ a) = rnf a+ rnf (Quote _) = ()+ rnf (QuoteTerm _) = ()+ rnf (Tactic _ a) = rnf a+ rnf (Unquote _) = ()+ rnf (DontCare a) = rnf a+ rnf (Equal _ a b) = rnf a `seq` rnf b+ rnf (Ellipsis _) = ()+ rnf (Generalized e) = rnf e+ rnf (KnownIdent a b) = rnf b+ rnf (KnownOpApp a b c d e) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf c+ rnf (Highlighted a b) = rnf a `seq` rnf b -- | Ranges are not forced. @@ -1357,7 +1428,7 @@ rnf (WildP _) = () rnf (AbsurdP _) = () rnf (AsP _ a b) = rnf a `seq` rnf b- rnf (DotP _ _ a) = rnf a+ rnf (DotP _ _ _ a) = rnf a rnf (LitP _ a) = rnf a rnf (RecP _ _ a) = rnf a rnf (EqualP _ es) = rnf es@@ -1377,7 +1448,7 @@ rnf (FieldSig a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d rnf (Generalize _ a) = rnf a rnf (Field _ fs) = rnf fs- rnf (FunClause a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d+ rnf (FunClause a b c d e) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e rnf (DataSig _ a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d rnf (Data _ a b c d e) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e@@ -1425,6 +1496,7 @@ rnf (InlinePragma _ _ a) = rnf a rnf (ImpossiblePragma _ a) = rnf a rnf (EtaPragma _ a) = rnf a+ rnf (EtaEqualityPragma _) = () rnf (TerminationCheckPragma _ a) = rnf a rnf (NoCoverageCheckPragma _) = () rnf (WarningOnUsage _ a b) = rnf a `seq` rnf b
src/full/Agda/Syntax/Concrete/Attribute.hs view
@@ -1,14 +1,21 @@+{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-} +{-# LANGUAGE CPP #-}+ -- | Attributes: concrete syntax for ArgInfo, esp. modalities. module Agda.Syntax.Concrete.Attribute where import Prelude hiding (null) -import Control.Arrow (second) import Control.Monad (foldM) +#if !MIN_VERSION_base(4,20,0) import Data.List (foldl')+#endif+ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe@@ -20,8 +27,8 @@ import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Syntax.Position -import Agda.Utils.List1 (List1, pattern (:|)) import Agda.Utils.Null+import Agda.Utils.Tuple (second) import Agda.Utils.Impossible @@ -34,6 +41,7 @@ | CohesionAttribute Cohesion | PolarityAttribute PolarityModality | LockAttribute Lock+ | RewriteAttribute RewriteAnn deriving (Show) instance HasRange Attribute where@@ -43,7 +51,8 @@ CohesionAttribute c -> getRange c PolarityAttribute p -> getRange p TacticAttribute e -> getRange e- LockAttribute l -> NoRange+ LockAttribute _l -> NoRange+ RewriteAttribute _r -> NoRange instance SetRange Attribute where setRange r = \case@@ -53,6 +62,7 @@ PolarityAttribute p -> PolarityAttribute $ setRange r p TacticAttribute e -> TacticAttribute e -- -- $ setRange r e -- SetRange Expr not yet implemented LockAttribute l -> LockAttribute l+ RewriteAttribute r -> RewriteAttribute r instance KillRange Attribute where killRange = \case@@ -62,6 +72,7 @@ PolarityAttribute p -> PolarityAttribute $ killRange p TacticAttribute e -> TacticAttribute $ killRange e LockAttribute l -> LockAttribute l+ RewriteAttribute r -> RewriteAttribute r -- | Parsed attribute. @@ -82,7 +93,7 @@ -- | (Conjunctive constraint.) -type LensAttribute a = (LensRelevance a, LensQuantity a, LensCohesion a, LensModalPolarity a, LensLock a)+type LensAttribute a = (LensRelevance a, LensQuantity a, LensCohesion a, LensModalPolarity a, LensLock a, LensRewriteAnn a) -- | Modifiers for 'Relevance'. @@ -118,6 +129,8 @@ cohesionAttributeTable = [ ("♭" , Flat) , ("flat" , Flat)+ , ("♯" , Sharp)+ , ("sharp", Sharp) ] -- | Information about attributes (attribute, range, printed@@ -141,7 +154,7 @@ , ("-" , withStandardLock Negative) , ("mixed" , withStandardLock MixedPolarity)] --- | Modifiers for 'Quantity'.+-- | Modifiers for 'Lock'. lockAttributeTable :: [(String, Lock)] lockAttributeTable = concat@@ -150,6 +163,13 @@ , map (, IsLock LockOLock) [ "lock" ] -- @lock ] +-- | Modifiers for @RewriteAnn@+-- I don't think we ever actually hit this because 'rewrite' is a keyword+-- Of course, we might want to add aliases+rewriteAttributeTable :: [(String, RewriteAnn)]+rewriteAttributeTable =+ [ ("rewrite" , IsRewrite noRange)+ ] -- | Concrete syntax for all attributes. @@ -160,6 +180,7 @@ , map (second CohesionAttribute) cohesionAttributeTable , map (second PolarityAttribute) polarityAttributeTable , map (second LockAttribute) lockAttributeTable+ , map (second RewriteAttribute) rewriteAttributeTable ] -- | Parsing a string into an attribute.@@ -171,7 +192,7 @@ exprToAttribute :: Range -> Expr -> Maybe Attribute exprToAttribute r = \case- e@(Paren _ (Tactic _ t)) -> Just $ TacticAttribute $ Ranged r t+ Paren _ (Tactic _ t) -> Just $ TacticAttribute $ Ranged r t e -> setRange r $ stringToAttribute $ prettyShow e -- | Setting an attribute (in e.g. an 'Arg'). Overwrites previous value.@@ -183,7 +204,8 @@ CohesionAttribute c -> setCohesion c PolarityAttribute p -> setModalPolarity p LockAttribute l -> setLock l- TacticAttribute t -> id+ RewriteAttribute r -> setRewriteAnn r+ TacticAttribute _ -> id -- | Setting some attributes in left-to-right order.@@ -232,6 +254,13 @@ | getLock a == defaultLock = Just $ setLock q a | otherwise = Nothing +-- | Setting 'RewriteAnn' if unset.++setPristineRewriteAnn :: (LensRewriteAnn a) => RewriteAnn -> a -> Maybe a+setPristineRewriteAnn q a+ | getRewriteAnn a == defaultRewrite = Just $ setRewriteAnn q a+ | otherwise = Nothing+ -- | Setting an unset attribute (to e.g. an 'Arg'). setPristineAttribute :: (LensAttribute a) => Attribute -> a -> Maybe a@@ -241,6 +270,7 @@ CohesionAttribute c -> setPristineCohesion c PolarityAttribute p -> setPristinePolarity p LockAttribute l -> setPristineLock l+ RewriteAttribute r -> setPristineRewriteAnn r TacticAttribute{} -> Just -- | Setting a list of unset attributes.@@ -267,6 +297,11 @@ TacticAttribute t -> Just t _ -> Nothing +isRewriteAttribute :: Attribute -> Maybe RewriteAnn+isRewriteAttribute = \case+ RewriteAttribute q -> Just q+ _ -> Nothing+ relevanceAttributes :: [Attribute] -> [Attribute] relevanceAttributes = filter $ isJust . isRelevanceAttribute @@ -275,3 +310,6 @@ tacticAttributes :: [Attribute] -> [Attribute] tacticAttributes = filter $ isJust . C.theTacticAttribute . isTacticAttribute++rewAttributes :: [Attribute] -> [Attribute]+rewAttributes = filter $ isJust . isRewriteAttribute
src/full/Agda/Syntax/Concrete/Definitions.hs view
@@ -34,6 +34,9 @@ -- (ConcreteToAbstract), where we are in the TCM and can produce more -- informative error messages. +{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-} module Agda.Syntax.Concrete.Definitions ( NiceDeclaration(..)@@ -54,41 +57,35 @@ import Control.Monad.Except ( ) import Control.Monad.Reader ( asks )-import Control.Monad.State ( MonadState(..), gets, StateT, runStateT )-import Control.Monad.Trans ( lift )+import Control.Monad.State ( MonadState(..), gets, runStateT ) -import Data.Bifunctor-import Data.Either (isLeft, isRight)-import Data.Function (on)-import qualified Data.Map as Map-import Data.Map (Map)+import Data.Either ( isRight )+import Data.Foldable qualified as Fold+import Data.Function ( on )+import Data.List qualified as List+import Data.Map qualified as Map import Data.Maybe-import Data.Semigroup ( Semigroup(..) )-import qualified Data.List as List-import qualified Data.Foldable as Fold-import qualified Data.Traversable as Trav+import Data.Semigroup ( sconcat )+import Data.Set qualified as Set+import Data.Text ( Text ) -import Agda.Syntax.Concrete-import Agda.Syntax.Concrete.Pattern import Agda.Syntax.Common hiding (TerminationCheck())-import qualified Agda.Syntax.Common as Common-import Agda.Syntax.Position-import Agda.Syntax.Notation-import Agda.Syntax.Concrete.Pretty () --instance only-import Agda.Syntax.Concrete.Fixity-import Agda.Syntax.Common.Pretty-+import Agda.Syntax.Concrete import Agda.Syntax.Concrete.Definitions.Errors import Agda.Syntax.Concrete.Definitions.Monad import Agda.Syntax.Concrete.Definitions.Types+import Agda.Syntax.Concrete.Fixity+import Agda.Syntax.Concrete.Pattern+import Agda.Syntax.Notation+import Agda.Syntax.Position import Agda.Utils.AffineHole-import Agda.Utils.CallStack ( CallStack, HasCallStack, withCallerCallStack )+import Agda.Utils.CallStack ( HasCallStack, withCallerCallStack ) import Agda.Utils.Functor import Agda.Utils.Lens-import Agda.Utils.List (spanJust)-import Agda.Utils.List1 (List1, pattern (:|), (<|))-import qualified Agda.Utils.List1 as List1+import Agda.Utils.List ( spanJust )+import Agda.Utils.List1 ( List1, pattern (:|), (<|) )+import Agda.Utils.List1 qualified as List1 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null@@ -147,14 +144,14 @@ deriving (Eq, Show) declKind :: NiceDeclaration -> DeclKind-declKind (FunSig r _ _ _ _ _ tc cc x _) = LoneSigDecl r (FunName tc cc) x-declKind (NiceRecSig r _ _ _ pc uc x _ _) = LoneSigDecl r (RecName pc uc) x+declKind (FunSig r _ _ _ _ ai tc cc x _) = LoneSigDecl r (FunName ai tc cc) x+declKind (NiceRecSig r _ _ _ pc uc eta x _ _)= LoneSigDecl r (RecName pc uc eta) x declKind (NiceDataSig r _ _ _ pc uc x _ _) = 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 (FunDef _r _ _ _ tc cc x (cl :| _)) = LoneDefs (FunName (getArgInfo cl) tc cc) [x]+declKind (NiceDataDef _ _ _ pc uc x _par _) = 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 (NiceRecDef _ _ _ pc uc eta x _ _par _) = LoneDefs (RecName pc uc eta) [x]+declKind (NiceUnquoteDef _ _ _ tc cc xs _) = LoneDefs (FunName empty tc cc) xs declKind Axiom{} = OtherDecl declKind NiceField{} = OtherDecl declKind PrimitiveFunction{} = OtherDecl@@ -171,18 +168,39 @@ declKind NiceLoneConstructor{} = OtherDecl declKind NiceOpaque{} = OtherDecl --- | Replace (Data/Rec/Fun)Sigs with Axioms for postulated names++-- | Ensure that every signature got its definition.+-- Signatures ('FunSig', 'NiceDataSig', 'NiceRecSig'), that are /lone/,+-- i.e., did not get a definition,+-- are replaced by 'Axiom's so that the scope checker will not+-- look for accompanying definitions ('FunDef', 'NiceDataDef', 'NiceRecDef').+-- Throws also a 'MissingDefinitions' warning for the lone names.+turnLoneSignaturesIntoAxioms ::+ [NiceDeclaration]+ -- ^ Containing @(Data/Rec/Fun)Sigs@ for the lone signatures.+ -> LoneSigs+ -- ^ The signatures that are not accompanied by a definition.+ -> Nice [NiceDeclaration]+ -- ^ The indicated lone signatures have been replaced by @Axiom@s.+ -- Length and ordering of the declaration list are not affected.+turnLoneSignaturesIntoAxioms ds ps = do+ -- Clear the lone sigs in the state, throw a warning for @ps@.+ checkLoneSigs ps+ -- Replace in @ds@ as indicated by @ps@.+ return $ replaceSigs ps ds++-- | Replace @(Data/Rec/Fun)Sigs@ with @Axiom@s for postulated names. -- The first argument is a list of axioms only. replaceSigs- :: LoneSigs -- ^ Lone signatures to be turned into Axioms- -> [NiceDeclaration] -- ^ Declarations containing them- -> [NiceDeclaration] -- ^ In the output, everything should be defined+ :: LoneSigs -- ^ Lone signatures to be turned into Axioms.+ -> [NiceDeclaration] -- ^ Declarations containing them.+ -> [NiceDeclaration] -- ^ In the output, everything should be defined. replaceSigs ps = if Map.null ps then id else \case [] -> __IMPOSSIBLE__ (d:ds) -> case replaceable d of -- If declaration d of x is mentioned in the map of lone signatures then replace- -- it with an axiom+ -- it with an axiom. Just (x, axiom) | (Just (LoneSig _ x' _), ps') <- Map.updateLookupWithKey (\ _ _ -> Nothing) x ps , getRange x == getRange x'@@ -197,19 +215,19 @@ -- @Axiom@ out of it. replaceable :: NiceDeclaration -> Maybe (Name, NiceDeclaration) replaceable = \case- FunSig r acc abst inst _ argi _ _ x' e ->+ FunSig r acc abst inst _ argi _ _ x' e -> do -- #4881: Don't use the unique NameId for NoName lookups.- let x = if isNoName x' then noName (nameRange x') else x' in- Just (x, Axiom r acc abst inst (setOrigin Inserted argi) x' e)- NiceRecSig r erased acc abst _ _ x pars t ->- let e = Generalized $ makePi (lamBindingsToTelescope r pars) t in- Just (x, Axiom r acc abst NotInstanceDef- (setOrigin Inserted (setQuantity (asQuantity erased) defaultArgInfo)) x e)- NiceDataSig r erased acc abst _ _ x pars t ->- let e = Generalized $ makePi (lamBindingsToTelescope r pars) t in- Just (x, Axiom r acc abst NotInstanceDef- (setOrigin Inserted (setQuantity (asQuantity erased) defaultArgInfo)) x e)+ let x = if isNoName x' then noName (nameRange x') else x'+ let ai = setOrigin Inserted argi+ Just (x, Axiom r acc abst inst ai x' e)+ NiceRecSig r erased acc abst _ _ _ x pars t -> retAx r erased acc abst x pars t+ NiceDataSig r erased acc abst _ _ x pars t -> retAx r erased acc abst x pars t _ -> Nothing+ where+ retAx r erased acc abst x pars t = do+ let e = Generalized $ makePi (parametersToTelescope r pars) t+ let ai = setOrigin Inserted (setQuantity (asQuantity erased) defaultArgInfo)+ return (x, Axiom r acc abst NotInstanceDef ai x e) -- | Main. Fixities (or more precisely syntax declarations) are needed when -- grouping function clauses.@@ -222,10 +240,12 @@ nds <- nice ds -- Check that every signature got its definition.- ps <- use loneSigs- checkLoneSigs ps- -- We postulate the missing ones and insert them in place of the corresponding @FunSig@- let ds = replaceSigs ps nds+ -- We postulate the missing ones and insert them as @Axiom@s+ -- in place of the corresponding @FunSig@, @NiceDataSig@ or @NiceRecSig@.+ -- This ensures that their names will be in scope but the scope checker+ -- will not search for a corresponding definition (@FunDef@, @NiceDataDef@, @NiceRecDef@).+ -- We also throw a @MissingDefinitions@ warning.+ ds <- turnLoneSignaturesIntoAxioms nds =<< use loneSigs -- Note that loneSigs is ensured to be empty. -- (Important, since inferMutualBlocks also uses loneSigs state).@@ -248,10 +268,10 @@ _ <- addLoneSig r x k InferredMutual checks nds0 ds1 <- untilAllDefined (mutualChecks k) ds -- If we still have lone signatures without any accompanying definition,- -- we postulate the definition and substitute the axiom for the lone signature- ps <- use loneSigs- checkLoneSigs ps- let ds0 = replaceSigs ps (d : nds0) -- NB: don't forget the LoneSig the block started with!+ -- we postulate the definition and substitute the axiom for the lone signature.+ ds0 <- List1.fromListSafe __IMPOSSIBLE__ <$> do+ turnLoneSignaturesIntoAxioms (d : nds0) =<< use loneSigs+ -- NB: don't forget the LoneSig that the block started with! -- We then keep processing the rest of the block tc <- combineTerminationChecks (getRange d) (mutualTermination checks) let cc = combineCoverageChecks (mutualCoverage checks)@@ -290,7 +310,9 @@ case d of - TypeSig info _tac x t -> do+ TypeSig info tac x t -> do+ dropTactic tac+ info <- dropRew info termCheck <- use terminationCheckPragma covCheck <- use coverageCheckPragma -- Andreas, 2020-09-28, issue #4950: take only range of identifier,@@ -298,7 +320,7 @@ -- (like @x y z : A@) into several type signatures (with imprecise ranges). let r = getRange x -- register x as lone type signature, to recognize clauses later- x' <- addLoneSig r x $ FunName termCheck covCheck+ x' <- addLoneSig r x $ FunName info termCheck covCheck return ([FunSig r PublicAccess ConcreteDef NotInstanceDef NotMacroDef info termCheck covCheck x' t] , ds) -- Should not show up: all FieldSig are part of a Field block@@ -312,11 +334,13 @@ -- Warn about @variable {x} : A@ which is equivalent to @variable x : A@. when (getHiding info == Hidden) $ declarationWarning $ HiddenGeneralize $ getRange x+ -- Generalised variables cannot be local rewrite rules+ info <- dropRew info return $ NiceGeneralize (getRange sig) PublicAccess info tac x t _ -> __IMPOSSIBLE__ return (gs, ds) - (FunClause lhs _ _ _) -> do+ FunClause ai lhs _ _ _ -> do termCheck <- use terminationCheckPragma covCheck <- use coverageCheckPragma catchall <- popCatchallPragma@@ -325,11 +349,11 @@ -- if we have some clauses for 'x' case [ (x, (x', fits, rest)) | (x, x') <- xs- , let (fits, rest) =+ , let (fits0, rest) = -- Anonymous declarations only have 1 clause each! if isNoName x then ([d], ds) else span (couldBeFunClauseOf (Map.lookup x fixs) x) (d : ds)- , not (null fits)+ , fits <- maybeToList $ List1.nonEmpty fits0 ] of -- case: clauses match none of the sigs@@ -337,20 +361,20 @@ -- Subcase: The lhs is single identifier (potentially anonymous). -- Treat it as a function clause without a type signature. LHS p [] [] | Just x <- isSingleIdentifierP p -> do- d <- mkFunDef (setOrigin Inserted defaultArgInfo) termCheck covCheck x Nothing $ singleton d -- fun def without type signature is relevant+ d <- mkFunDef (setOrigin Inserted ai) termCheck covCheck x Nothing $ singleton d -- fun def without type signature can have modality return (d , ds) -- Subcase: The lhs is a proper pattern. -- This could be a let-pattern binding. Pass it on.- -- A missing type signature error might be raise in ConcreteToAbstract+ -- A missing type signature error might be raised in ConcreteToAbstract _ -> do return ([NiceFunClause (getRange d) PublicAccess ConcreteDef termCheck covCheck catchall d] , ds) -- case: clauses match exactly one of the sigs- [(x,(x',fits,rest))] -> do+ [(x, (Arg info x', fits, rest))] -> do -- The x'@NoName{} is the unique version of x@NoName{}. removeLoneSig x- ds <- expandEllipsis fits- cs <- mkClauses x' ds empty+ ds <- expandEllipsis1 fits+ cs <- mkClauses1 info x' ds empty return ([FunDef (getRange fits) fits ConcreteDef NotInstanceDef termCheck covCheck x' cs] , rest) -- case: clauses match more than one sigs (ambiguity)@@ -358,28 +382,29 @@ -- "ambiguous function clause; cannot assign it uniquely to one type signature" Field r [] -> justWarning $ EmptyField r- Field _ fs -> (,ds) <$> niceAxioms FieldBlock fs+ Field _ fs -> (,ds) <$> do+ forM fs \case+ d@(FieldSig i tac x argt) -> pure $ NiceField (getRange d) PublicAccess ConcreteDef i tac x argt+ d -> declarationException $ WrongContentBlock FieldBlock $ getRange d DataSig r erased x tel t -> do pc <- use positivityCheckPragma uc <- use universeCheckPragma _ <- addLoneSig r x $ DataName pc uc- (,ds) <$> dataOrRec pc uc NiceDataDef- (flip NiceDataSig erased) (niceAxioms DataBlock) r+ (,ds) <$> dataOrRec pc uc empty+ (\ r o a pc uc _eta x tel cs -> NiceDataDef r o a pc uc x tel cs)+ (\ r p a pc uc _eta x tel t -> NiceDataSig r erased p a pc uc x tel t)+ (niceAxioms DataBlock) r x (Just (tel, t)) Nothing Data r erased x tel t cs -> do pc <- use positivityCheckPragma- -- Andreas, 2018-10-27, issue #3327- -- Propagate {-# NO_UNIVERSE_CHECK #-} pragma from signature to definition.- -- Universe check is performed if both the current value of- -- 'universeCheckPragma' AND the one from the signature say so. uc <- use universeCheckPragma- uc <- if uc == NoUniverseCheck then return uc else getUniverseCheckFromSig x- mt <- defaultTypeSig (DataName pc uc) x (Just t)- (,ds) <$> dataOrRec pc uc NiceDataDef- (flip NiceDataSig erased) (niceAxioms DataBlock) r- x ((tel,) <$> mt) (Just (tel, cs))+ (,ds) <$> dataOrRec pc uc empty+ (\ r o a pc uc _eta x tel cs -> NiceDataDef r o a pc uc x tel cs)+ (\ r p a pc uc _eta x tel t -> NiceDataSig r erased p a pc uc x tel t)+ (niceAxioms DataBlock) r+ x (Just (tel, t)) (Just (parametersToDefParameters tel, cs)) DataDef r x tel cs -> do pc <- use positivityCheckPragma@@ -388,36 +413,35 @@ -- Universe check is performed if both the current value of -- 'universeCheckPragma' AND the one from the signature say so. uc <- use universeCheckPragma- uc <- if uc == NoUniverseCheck then return uc else getUniverseCheckFromSig x- mt <- defaultTypeSig (DataName pc uc) x Nothing- (,ds) <$> dataOrRec pc uc NiceDataDef- (flip NiceDataSig defaultErased)- (niceAxioms DataBlock) r x ((tel,) <$> mt)- (Just (tel, cs))+ (pc, uc) <- retrieveTypeSig (DataName pc uc) x >>= \case+ DataName pc uc -> pure (pc, uc)+ _ -> __IMPOSSIBLE__+ defpars <- niceDefParameters IsData tel+ (,ds) <$> dataOrRec pc uc empty+ (\ r o a pc uc _eta x tel cs -> NiceDataDef r o a pc uc x tel cs)+ (\ r p a pc uc _eta x tel t -> NiceDataSig r defaultErased p a pc uc x tel t)+ (niceAxioms DataBlock) r+ x Nothing (Just (defpars, cs)) RecordSig r erased x tel t -> do pc <- use positivityCheckPragma uc <- use universeCheckPragma- _ <- addLoneSig r x $ RecName pc uc- return ( [NiceRecSig r erased PublicAccess ConcreteDef pc uc x+ eta <- use etaEqualityPragma+ _ <- addLoneSig r x $ RecName pc uc eta+ return ( [NiceRecSig r erased PublicAccess ConcreteDef pc uc eta x tel t] , ds ) Record r erased x dir tel t cs -> do pc <- use positivityCheckPragma- -- Andreas, 2018-10-27, issue #3327- -- Propagate {-# NO_UNIVERSE_CHECK #-} pragma from signature to definition.- -- Universe check is performed if both the current value of- -- 'universeCheckPragma' AND the one from the signature say so. uc <- use universeCheckPragma- uc <- if uc == NoUniverseCheck then return uc else getUniverseCheckFromSig x- mt <- defaultTypeSig (RecName pc uc) x (Just t)- (,ds) <$> dataOrRec pc uc- (\r o a pc uc x tel cs ->- NiceRecDef r o a pc uc x dir tel cs)+ eta <- use etaEqualityPragma+ (,ds) <$> dataOrRec pc uc eta+ (\r o a pc uc eta x tel cs ->+ NiceRecDef r o a pc uc eta x dir tel cs) (flip NiceRecSig erased) return r x- ((tel,) <$> mt) (Just (tel, cs))+ (Just (tel, t)) (Just (parametersToDefParameters tel, cs)) RecordDef r x dir tel cs -> do pc <- use positivityCheckPragma@@ -426,13 +450,16 @@ -- Universe check is performed if both the current value of -- 'universeCheckPragma' AND the one from the signature say so. uc <- use universeCheckPragma- uc <- if uc == NoUniverseCheck then return uc else getUniverseCheckFromSig x- mt <- defaultTypeSig (RecName pc uc) x Nothing- (,ds) <$> dataOrRec pc uc- (\r o a pc uc x tel cs ->- NiceRecDef r o a pc uc x dir tel cs)+ eta <- use etaEqualityPragma+ (pc, uc, eta) <- retrieveTypeSig (RecName pc uc eta) x >>= \case+ RecName pc uc eta -> pure (pc, uc, eta)+ _ -> __IMPOSSIBLE__+ defpars <- niceDefParameters (IsRecord ()) tel+ (,ds) <$> dataOrRec pc uc eta+ (\r o a pc uc eta x tel cs ->+ NiceRecDef r o a pc uc eta x dir tel cs) (flip NiceRecSig defaultErased) return r x- ((tel,) <$> mt) (Just (tel, cs))+ Nothing (Just (defpars, cs)) Mutual r ds' -> do -- The lone signatures encountered so far are not in scope@@ -440,7 +467,7 @@ breakImplicitMutualBlock r "`mutual` blocks" case ds' of [] -> justWarning $ EmptyMutual r- _ -> (,ds) <$> (singleton <$> (mkOldMutual r =<< nice ds'))+ _ -> (,ds) . maybeToList <$> (mkOldMutual r =<< nice ds') InterleavedMutual r ds' -> do -- The lone signatures encountered so far are not in scope@@ -448,12 +475,7 @@ breakImplicitMutualBlock r "`interleaved mutual` blocks" case ds' of [] -> justWarning $ EmptyMutual r- _ -> (,ds) <$> (singleton <$> (mkInterleavedMutual r =<< nice ds'))-- LoneConstructor r [] -> justWarning $ EmptyConstructor r- LoneConstructor r ds' ->- ((,ds) . singleton . NiceLoneConstructor r) <$> niceAxioms ConstructorBlock ds'-+ _ -> (,ds) . maybeToList <$> (mkInterleavedMutual r =<< nice ds') Abstract r [] -> justWarning $ EmptyAbstract r Abstract r ds' ->@@ -471,13 +493,15 @@ Macro r ds' -> (,ds) <$> (macroBlock r =<< nice ds') - Postulate r [] -> justWarning $ EmptyPostulate r- Postulate _ ds' ->- (,ds) <$> niceAxioms PostulateBlock ds'+ LoneConstructor r ds' -> (,ds) <$> do+ constructorBlock r =<< niceAxioms ConstructorBlock ds' - Primitive r [] -> justWarning $ EmptyPrimitive r- Primitive _ ds' -> (,ds) <$> (map toPrim <$> niceAxioms PrimitiveBlock ds')+ Postulate r ds' -> (,ds) <$> do+ postulateBlock r =<< niceAxioms PostulateBlock ds' + Primitive r ds' -> (,ds) <$> do+ primitiveBlock r =<< niceAxioms PrimitiveBlock ds'+ Module r erased x tel ds' -> return $ ([NiceModule r PublicAccess ConcreteDef erased x tel ds'], ds) @@ -491,8 +515,8 @@ PatternSyn r n as p -> do return ([NicePatternSyn r PublicAccess n as p] , ds)- Open r x is -> return ([NiceOpen r x is] , ds)- Import r x as op is -> return ([NiceImport r x as op is] , ds)+ Open kwr x is -> return ([NiceOpen kwr x is] , ds)+ Import opn r x as is-> return ([NiceImport opn r x as is], ds) UnquoteDecl r xs e -> do tc <- use terminationCheckPragma@@ -533,74 +557,95 @@ -- recursion by interleaving type signatures and definitions, -- just like the body of a module. decls0 <- nice body- ps <- use loneSigs- checkLoneSigs ps- let decls = replaceSigs ps decls0+ decls <- turnLoneSignaturesIntoAxioms decls0 =<< use loneSigs body <- inferMutualBlocks decls pure ([NiceOpaque r (concat unfoldings) body], ds) Unfolding r _ -> declarationException $ UnfoldingOutsideOpaque r + -- Some pragmas attach to the following declarations,+ -- handle this situation here.+ nicePragma :: Pragma -> [Declaration] -> Nice ([NiceDeclaration], [Declaration])+ nicePragma p ds = case p of - nicePragma (TerminationCheckPragma r (TerminationMeasure _ x)) ds =+ TerminationCheckPragma r NoTerminationCheck -> do+ -- This PRAGMA has been deprecated in favour of (NON_)TERMINATING+ -- We warn the user about it and then assume the function is NON_TERMINATING.+ declarationWarning $ PragmaNoTerminationCheck r+ nicePragma (TerminationCheckPragma r NonTerminating) ds++ TerminationCheckPragma r (TerminationMeasure _ x) -> if canHaveTerminationMeasure ds then withTerminationCheckPragma (TerminationMeasure r x) $ nice1 ds else do declarationWarning $ InvalidTerminationCheckPragma r nice1 ds - nicePragma (TerminationCheckPragma r NoTerminationCheck) ds = do- -- This PRAGMA has been deprecated in favour of (NON_)TERMINATING- -- We warn the user about it and then assume the function is NON_TERMINATING.- declarationWarning $ PragmaNoTerminationCheck r- nicePragma (TerminationCheckPragma r NonTerminating) ds-- nicePragma (TerminationCheckPragma r tc) ds =+ TerminationCheckPragma r tc -> if canHaveTerminationCheckPragma ds then withTerminationCheckPragma tc $ nice1 ds else do declarationWarning $ InvalidTerminationCheckPragma r nice1 ds - nicePragma (NoCoverageCheckPragma r) ds =+ NoCoverageCheckPragma r -> if canHaveCoverageCheckPragma ds then withCoverageCheckPragma NoCoverageCheck $ nice1 ds else do declarationWarning $ InvalidCoverageCheckPragma r nice1 ds - nicePragma (CatchallPragma r) ds =+ CatchallPragma r -> if canHaveCatchallPragma ds then withCatchallPragma (YesCatchall r) $ nice1 ds else do declarationWarning $ InvalidCatchallPragma r nice1 ds - nicePragma (NoPositivityCheckPragma r) ds =+ NoPositivityCheckPragma r -> if canHaveNoPositivityCheckPragma ds then withPositivityCheckPragma NoPositivityCheck $ nice1 ds else do declarationWarning $ InvalidNoPositivityCheckPragma r nice1 ds - nicePragma (NoUniverseCheckPragma r) ds =+ NoUniverseCheckPragma r -> if canHaveNoUniverseCheckPragma ds then withUniverseCheckPragma NoUniverseCheck $ nice1 ds else do declarationWarning $ InvalidNoUniverseCheckPragma r nice1 ds - nicePragma p@CompilePragma{} ds = do- return ([NicePragma (getRange p) p], ds)+ EtaEqualityPragma r ->+ if canHaveEtaEqualityPragma ds then+ withEtaEqualityPragma YesForceRecordEta $ nice1 ds+ else do+ declarationWarning $ InvalidEtaEqualityPragma r+ nice1 ds - nicePragma (PolarityPragma{}) ds = return ([], ds)+ -- Polarity pragmas have been handled with fixity declarations, can be deleted.+ PolarityPragma{} -> return ([], ds) - nicePragma (BuiltinPragma r str qn@(QName x)) ds = do- return ([NicePragma r (BuiltinPragma r str qn)], ds)+ -- The other pragmas are less context-sensitive, so nothing to do:+ BuiltinPragma{} -> keep+ CompilePragma{} -> keep+ DisplayPragma{} -> keep+ EtaPragma{} -> keep+ ForeignPragma{} -> keep+ ImpossiblePragma{} -> keep+ InjectiveForInferencePragma{} -> keep+ InjectivePragma{} -> keep+ InlinePragma{} -> keep+ NotProjectionLikePragma{} -> keep+ OptionsPragma{} -> keep+ OverlapPragma{} -> keep+ RewritePragma{} -> keep+ StaticPragma{} -> keep+ WarningOnImport{} -> keep+ WarningOnUsage{} -> keep - nicePragma p@RewritePragma{} ds = return ([NicePragma (getRange p) p], ds)- nicePragma p ds = return ([NicePragma (getRange p) p], ds)+ where keep = return ([NicePragma (getRange p) p], ds) canHaveTerminationMeasure :: [Declaration] -> Bool canHaveTerminationMeasure [] = False@@ -651,9 +696,18 @@ Record{} -> True RecordSig{} -> True RecordDef{} -> True- Pragma p | isAttachedPragma p -> canHaveNoPositivityCheckPragma ds+ Pragma p | isAttachedPragma p -> canHaveNoUniverseCheckPragma ds _ -> False + canHaveEtaEqualityPragma :: [Declaration] -> Bool+ canHaveEtaEqualityPragma [] = False+ canHaveEtaEqualityPragma (d:ds) = case d of+ Record{} -> True+ RecordSig{} -> True+ RecordDef{} -> True+ Pragma p | isAttachedPragma p -> canHaveEtaEqualityPragma ds+ _ -> False+ -- Pragma that attaches to the following declaration. isAttachedPragma :: Pragma -> Bool isAttachedPragma = \case@@ -661,33 +715,36 @@ CatchallPragma{} -> True NoPositivityCheckPragma{} -> True NoUniverseCheckPragma{} -> True+ EtaEqualityPragma{} -> True _ -> False - -- We could add a default type signature here, but at the moment we can't- -- infer the type of a record or datatype, so better to just fail here.- defaultTypeSig :: DataRecOrFun -> Name -> Maybe Expr -> Nice (Maybe Expr)- defaultTypeSig k x t@Just{} = return t- defaultTypeSig k x Nothing = do- caseMaybeM (getSig x) (return Nothing) $ \ k' -> do- unless (sameKind k k') $ declarationException $ WrongDefinition x k' k- Nothing <$ removeLoneSig x+ -- Remove the data or record type signature,+ -- using its positivity check / universe check information+ -- to refine the given one.+ retrieveTypeSig :: DataRecOrFun -> Name -> Nice DataRecOrFun+ retrieveTypeSig k x = do+ caseMaybeM (getSig x) (return k) $ \ k' -> do+ removeLoneSig x+ case mergeDataRecOrFun k k' of+ Just k -> return k+ Nothing -> declarationException $ WrongDefinition x k' k - dataOrRec- :: forall a decl- . PositivityCheck+ dataOrRec :: forall a decl.+ PositivityCheck -> UniverseCheck- -> (Range -> Origin -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [LamBinding] -> [decl] -> NiceDeclaration)+ -> ForceRecordEta+ -> (Range -> Origin -> IsAbstract -> PositivityCheck -> UniverseCheck -> ForceRecordEta -> Name -> DefParameters -> [decl] -> NiceDeclaration) -- Construct definition.- -> (Range -> Access -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [LamBinding] -> Expr -> NiceDeclaration)+ -> (Range -> Access -> IsAbstract -> PositivityCheck -> UniverseCheck -> ForceRecordEta -> Name -> Parameters -> Expr -> NiceDeclaration) -- Construct signature. -> ([a] -> Nice [decl]) -- Constructor checking. -> Range -> Name -- Data/record type name.- -> Maybe ([LamBinding], Expr) -- Parameters and type. If not @Nothing@ a signature is created.- -> Maybe ([LamBinding], [a]) -- Parameters and constructors. If not @Nothing@, a definition body is created.+ -> Maybe (Parameters, Expr) -- Parameters and type. If not @Nothing@ a signature is created.+ -> Maybe (DefParameters, [a]) -- Parameters and constructors. If not @Nothing@, a definition body is created. -> Nice [NiceDeclaration]- dataOrRec pc uc mkDef mkSig niceD r x mt mcs = do- mds <- Trav.forM mcs $ \ (tel, cs) -> (tel,) <$> niceD cs+ dataOrRec pc uc eta mkDef mkSig niceD r x mt mcs = do+ mds <- mapM (secondM niceD) mcs -- We set origin to UserWritten if the user split the data/rec herself, -- and to Inserted if the she wrote a single declaration that we're -- splitting up here. We distinguish these because the scoping rules for@@ -695,37 +752,71 @@ let o | isJust mt && isJust mcs = Inserted | otherwise = UserWritten return $ catMaybes $- [ mt <&> \ (tel, t) -> mkSig (fuseRange x t) PublicAccess ConcreteDef pc uc x tel t- , mds <&> \ (tel, ds) -> mkDef r o ConcreteDef pc uc x (caseMaybe mt tel $ const $ concatMap dropTypeAndModality tel) ds+ [ mt <&> \ (tel, t) -> mkSig (fuseRange x t) PublicAccess ConcreteDef pc uc eta x tel t+ , mds <&> \ (tel, ds) -> mkDef r o ConcreteDef pc uc eta x tel ds -- If a type is given (mt /= Nothing), we have to delete the types in @tel@ -- for the data definition, lest we duplicate them. And also drop modalities (#1886). ]+ -- Translate axioms niceAxioms :: KindOfBlock -> [TypeSignatureOrInstanceBlock] -> Nice [NiceDeclaration]- niceAxioms b ds = List.concat <$> mapM (niceAxiom b) ds+ niceAxioms b ds = List.concat <$> mapM niceAxiom ds+ where+ niceAxiom :: TypeSignatureOrInstanceBlock -> Nice [NiceDeclaration]+ niceAxiom = \case+ d@(TypeSig rel tac x t) -> do+ dropTactic tac+ rel <- dropRew rel+ return [ Axiom (getRange d) PublicAccess ConcreteDef NotInstanceDef rel x t ]+ -- @instance@ and @private@ blocks mix well with other blocks.+ InstanceB r ds -> instanceBlock r =<< niceAxioms b ds+ Private r o ds | privateAllowed -> privateBlock r o =<< niceAxioms b ds+ -- @data _ where@, @postulate@ and @primitive@ blocks exclude each other.+ Pragma p@(RewritePragma r _ _) -> return [ NicePragma r p ]+ Pragma p@(OverlapPragma r _ _) -> return [ NicePragma r p ]+ d -> declarationException $ WrongContentBlock b $ getRange d+ -- @private@ is not allowed for constructors.+ privateAllowed :: Bool+ privateAllowed = case b of+ PrimitiveBlock -> True+ PostulateBlock -> True+ DataBlock -> False+ ConstructorBlock -> False+ -- We do not handle @field@ blocks here.+ FieldBlock -> __IMPOSSIBLE__ - niceAxiom :: KindOfBlock -> TypeSignatureOrInstanceBlock -> Nice [NiceDeclaration]- niceAxiom b = \case- d@(TypeSig rel _tac x t) -> do- return [ Axiom (getRange d) PublicAccess ConcreteDef NotInstanceDef rel x t ]- d@(FieldSig i tac x argt) | b == FieldBlock -> do- return [ NiceField (getRange d) PublicAccess ConcreteDef i tac x argt ]- InstanceB r decls -> do- instanceBlock r =<< niceAxioms InstanceBlock decls- Private r o decls | PostulateBlock <- b -> do- privateBlock r o =<< niceAxioms b decls- Pragma p@(RewritePragma r _ _) -> return [ NicePragma r p ]- Pragma p@(OverlapPragma r _ _) -> return [ NicePragma r p ]- d -> declarationException $ WrongContentBlock b $ getRange d+ constructorBlock :: KwRange -> [NiceDeclaration] -> Nice [NiceDeclaration]+ constructorBlock r [] = [] <$ declarationWarning (EmptyConstructor r)+ constructorBlock r ds = return $ singleton $ NiceLoneConstructor r ds - toPrim :: NiceDeclaration -> NiceDeclaration- toPrim (Axiom r p a i rel x t) = PrimitiveFunction r p a x (Arg rel t)- toPrim _ = __IMPOSSIBLE__+ postulateBlock :: KwRange -> [NiceDeclaration] -> Nice [NiceDeclaration]+ postulateBlock r [] = [] <$ declarationWarning (EmptyPostulate r)+ postulateBlock _ ds = return ds + primitiveBlock :: KwRange -> [NiceDeclaration] -> Nice [NiceDeclaration]+ primitiveBlock r [] = [] <$ declarationWarning (EmptyPrimitive r)+ primitiveBlock _ ds = mapM toPrim ds++ toPrim :: NiceDeclaration -> Nice NiceDeclaration+ toPrim (Axiom r p a inst rel x t) = do+ case inst of+ InstanceDef r -> declarationWarning $ UselessInstance r+ NotInstanceDef -> pure ()+ return $ PrimitiveFunction r p a x (Arg rel t)+ toPrim _ = __IMPOSSIBLE__+ -- Create a function definition.+ mkFunDef ::+ ArgInfo+ -> TerminationCheck+ -> CoverageCheck+ -> Name+ -> Maybe Expr+ -> List1 Declaration+ -> Nice [NiceDeclaration] mkFunDef info termCheck covCheck x mt ds0 = do- ds <- expandEllipsis ds0- cs <- mkClauses x ds empty+ ds <- expandEllipsis1 ds0+ cs <- mkClauses1 info x ds empty return [ FunSig (fuseRange x t) PublicAccess ConcreteDef NotInstanceDef NotMacroDef info termCheck covCheck x t , FunDef (getRange ds0) ds0 ConcreteDef NotInstanceDef termCheck covCheck x cs ] where@@ -737,9 +828,12 @@ -- and then use its lhs pattern to replace ellipses in the subsequent clauses (if any). expandEllipsis :: [Declaration] -> Nice [Declaration] expandEllipsis [] = return []- expandEllipsis (d@(FunClause lhs@(LHS p _ _) _ _ _) : ds)- | hasEllipsis p = (d :) <$> expandEllipsis ds- | otherwise = (d :) <$> expand (killRange p) ds+ expandEllipsis (d : ds) = List1.toList <$> expandEllipsis1 (d :| ds)++ expandEllipsis1 :: List1 Declaration -> Nice (List1 Declaration)+ expandEllipsis1 (d@(FunClause _ (LHS p _ _) _ _ _) :| ds)+ | hasEllipsis p = (d :|) <$> expandEllipsis ds+ | otherwise = (d :|) <$> expand (killRange p) ds where expand :: Pattern -> [Declaration] -> Nice [Declaration] expand _ [] = return []@@ -747,13 +841,13 @@ case d of Pragma (CatchallPragma _) -> do (d :) <$> expand p ds- FunClause (LHS p0 eqs es) rhs wh ca -> do+ FunClause ai (LHS p0 eqs es) rhs wh ca -> do case hasEllipsis' p0 of ManyHoles -> declarationException $ MultipleEllipses p0 OneHole cxt ~(EllipsisP r Nothing) -> do -- Replace the ellipsis by @p@. let p1 = cxt $ EllipsisP r $ Just $ setRange r p- let d' = FunClause (LHS p1 eqs es) rhs wh ca+ let d' = FunClause ai (LHS p1 eqs es) rhs wh ca -- If we have with-expressions (es /= []) then the following -- ellipses also get the additional patterns in p0. (d' :) <$> expand (if null es then p else killRange p1) ds@@ -766,49 +860,69 @@ -- Need to update the range also on the next with-patterns. (d :) <$> expand (if null es then p else killRange p0) ds _ -> __IMPOSSIBLE__- expandEllipsis _ = __IMPOSSIBLE__+ expandEllipsis1 _ = __IMPOSSIBLE__ -- Turn function clauses into nice function clauses.- mkClauses :: Name -> [Declaration] -> Catchall -> Nice [Clause]- mkClauses _ [] _ = return []+ mkClauses1 ::+ ArgInfo+ -- Clauses need to conform to this 'Modality'.+ -> Name -> List1 Declaration -> Catchall -> Nice (List1 Clause)+ mkClauses1 info x ds ca = List1.fromListSafe __IMPOSSIBLE__ <$> mkClauses info x (List1.toList ds) ca + mkClauses ::+ ArgInfo+ -- Clauses need to conform to this 'Modality'.+ -> Name -> [Declaration] -> Catchall -> Nice [Clause]+ mkClauses _ _ [] _ = return []+ -- A CATCHALL pragma after the last clause is useless.- mkClauses x [Pragma (CatchallPragma r)] _ = [] <$ do+ mkClauses _ _ [Pragma (CatchallPragma r)] _ = [] <$ do declarationWarning $ InvalidCatchallPragma r - mkClauses x (Pragma (CatchallPragma r) : cs) catchall = do+ mkClauses info x (Pragma (CatchallPragma r) : cs) catchall = do -- Warn about consecutive CATCHALL pragmas unless (null catchall) $ declarationWarning $ InvalidCatchallPragma r- mkClauses x cs (YesCatchall r)+ mkClauses info x cs (YesCatchall r) - mkClauses x (FunClause lhs rhs wh ca : cs) catchall- | null (lhsWithExpr lhs) || hasEllipsis lhs =- (Clause x (ca <> catchall) lhs rhs wh [] :) <$> mkClauses x cs empty -- Will result in an error later.+ mkClauses info x (FunClause ai lhs rhs wh ca : cs) catchall+ | null (lhsWithExpr lhs) || hasEllipsis lhs = do+ ai <- checkModality info ai+ (Clause x (ca <> catchall) ai lhs rhs wh [] :) <$> mkClauses info x cs empty - mkClauses x (FunClause lhs rhs wh ca : cs) catchall = do+ mkClauses info x (FunClause ai lhs rhs wh ca : cs) catchall = do+ ai <- checkModality info ai when (null withClauses) $ declarationException $ MissingWithClauses x lhs- wcs <- mkClauses x withClauses empty- (Clause x (ca <> catchall) lhs rhs wh wcs :) <$> mkClauses x cs' empty+ wcs <- mkClauses info x withClauses empty+ (Clause x (ca <> catchall) ai lhs rhs wh wcs :) <$> mkClauses info x cs' empty where (withClauses, cs') = subClauses cs -- A clause is a subclause if the number of with-patterns is -- greater or equal to the current number of with-patterns plus the -- number of with arguments.- numWith = numberOfWithPatterns p + length (filter visible es) where LHS p _ es = lhs+ numWith = numberOfWithPatterns p + length (filter visible es)+ where LHS p _ es = lhs subClauses :: [Declaration] -> ([Declaration],[Declaration])- subClauses (c@(FunClause (LHS p0 _ _) _ _ _) : cs)+ subClauses (c@(FunClause _ (LHS p0 _ _) _ _ _) : cs) | isEllipsis p0 ||- numberOfWithPatterns p0 >= numWith = mapFst (c:) (subClauses cs)+ numberOfWithPatterns p0 >= numWith = first (c:) (subClauses cs) | otherwise = ([], c:cs)- subClauses (c@(Pragma (CatchallPragma r)) : cs) = case subClauses cs of+ subClauses (c@(Pragma (CatchallPragma _r)) : cs) = case subClauses cs of ([], cs') -> ([], c:cs') (cs, cs') -> (c:cs, cs') subClauses [] = ([],[]) subClauses _ = __IMPOSSIBLE__- mkClauses _ _ _ = __IMPOSSIBLE__+ mkClauses _ _ _ _ = __IMPOSSIBLE__ + checkModality ::+ ArgInfo -- Authoritative 'Modality' from type signature.+ -> ArgInfo -- 'Modality' from clause, has to conform.+ -> Nice ArgInfo -- Deviant 'Modality' conformed to authoritative source.+ checkModality info ai+ | (null ai || sameModality info ai) = return ai+ | otherwise = info <$ declarationWarning (DivergentModalityInClause info ai)+ couldBeCallOf :: Maybe Fixity' -> Name -> Pattern -> Bool couldBeCallOf mFixity x p = let@@ -845,8 +959,8 @@ -- for finding clauses for a type sig in mutual blocks couldBeFunClauseOf :: Maybe Fixity' -> Name -> Declaration -> Bool- couldBeFunClauseOf mFixity x (Pragma (CatchallPragma{})) = True- couldBeFunClauseOf mFixity x (FunClause (LHS p _ _) _ _ _) =+ couldBeFunClauseOf _ _ (Pragma (CatchallPragma{})) = True+ couldBeFunClauseOf mFixity x (FunClause _ (LHS p _ _) _ _ _) = hasEllipsis p || couldBeCallOf mFixity x p couldBeFunClauseOf _ _ _ = False -- trace ("couldBe not (fun default)") $ False @@ -855,38 +969,35 @@ mkInterleavedMutual :: KwRange -- Range of the @interleaved mutual@ keywords. -> [NiceDeclaration] -- Declarations inside the block.- -> Nice NiceDeclaration -- Returns a 'NiceMutual'.+ -> Nice (Maybe NiceDeclaration) -- Returns a 'NiceMutual' unless empty. mkInterleavedMutual kwr ds' = do- (other, (m, checks, _)) <- runStateT (groupByBlocks kwr ds') (empty, mempty, 0)- let idecls = other ++ concatMap (uncurry interleavedDecl) (Map.toList m)+ (other, ISt m checks _) <- runStateT (groupByBlocks kwr ds') $ ISt empty mempty 0+ idecls <- (other ++) . concat <$> mapM (uncurry interleavedDecl) (Map.toList m) let decls0 = map snd $ List.sortBy (compare `on` fst) idecls- ps <- use loneSigs- checkLoneSigs ps- let decls = replaceSigs ps decls0+ decls <- turnLoneSignaturesIntoAxioms decls0 =<< use loneSigs -- process the checks let r = fuseRange kwr ds' tc <- combineTerminationChecks r (mutualTermination checks) let cc = combineCoverageChecks (mutualCoverage checks) let pc = combinePositivityChecks (mutualPositivity checks)- pure $ NiceMutual kwr tc cc pc decls+ return $ fmap (NiceMutual kwr tc cc pc) $ List1.nonEmpty decls where ------------------------------------------------------------------------------ -- Adding Signatures- addType :: Name -> (DeclNum -> a) -> MutualChecks- -> StateT (Map Name a, MutualChecks, DeclNum) Nice ()+ addType :: Name -> (DeclNum -> InterleavedDecl) -> MutualChecks -> INice () addType n c mc = do- (m, checks, i) <- get- when (isJust $ Map.lookup n m) $ lift $ declarationException $ DuplicateDefinition n- put (Map.insert n (c i) m, mc <> checks, i + 1)+ ISt m checks i <- get+ whenJust (Map.lookup n m) \ y -> lift $ declarationException $ DuplicateDefinition n $ getRange y+ put $ ISt (Map.insert n (c i) m) (mc <> checks) (i + 1) addFunType d@(FunSig _ _ _ _ _ _ tc cc n _) = do let checks = MutualChecks [tc] [cc] [] addType n (\ i -> InterleavedFun i d Nothing) checks addFunType _ = __IMPOSSIBLE__ - addDataType d@(NiceDataSig _ _ _ _ pc uc n _ _) = do+ addDataType d@(NiceDataSig _ _ _ _ pc _uc n _ _) = do let checks = MutualChecks [] [] [pc] addType n (\ i -> InterleavedData i d Nothing) checks addDataType _ = __IMPOSSIBLE__@@ -894,85 +1005,84 @@ ------------------------------------------------------------------------------ -- Adding constructors & clauses - addDataConstructors :: Maybe Range -- Range of the `data A where` (if any)- -> Maybe Name -- Data type the constructors belong to- -> [NiceConstructor] -- Constructors to add- -> StateT (InterleavedMutual, MutualChecks, DeclNum) Nice ()+ addDataConstructors ::+ Maybe (Name, DefParameters)+ -- Data type the constructors belong to, and parameter telescope of the data definition.+ -> [NiceConstructor]+ -- Constructors to add.+ -> INice () -- if we know the type's name, we can go ahead- addDataConstructors mr (Just n) ds = do- (m, checks, i) <- get+ addDataConstructors (Just (n, pars)) ds = do+ ISt m checks i <- get case Map.lookup n m of Just (InterleavedData i0 sig cs) -> do lift $ removeLoneSig n -- add the constructors to the existing ones (if any) let (cs', i') = case cs of- Nothing -> ((i , ds :| [] ), i + 1)- Just (i1, ds1) -> ((i1, ds <| ds1), i)- put (Map.insert n (InterleavedData i0 sig (Just cs')) m, checks, i')+ Nothing -> ((i , (pars, ds) :| [] ), i + 1)+ Just (i1, ds1) -> ((i1, (pars, ds) <| ds1), i)+ put $ ISt (Map.insert n (InterleavedData i0 sig (Just cs')) m) checks i' _ -> lift $ declarationWarning $ MissingDataDeclaration n - addDataConstructors mr Nothing [] = pure ()+ addDataConstructors Nothing [] = pure () -- Otherwise we try to guess which datasig the constructor is referring to- addDataConstructors mr Nothing (d : ds) = do+ addDataConstructors Nothing (d : ds) = do -- get the candidate data types that are in this interleaved mutual block- (m, _, _) <- get+ ISt m _ _ <- get let sigs = mapMaybe (\ (n, d) -> n <$ isInterleavedData d) $ Map.toList m -- check whether this constructor matches any of them case isConstructor sigs d of Right n -> do -- if so grab the whole block that may work and add them let (ds0, ds1) = span (isRight . isConstructor [n]) ds- addDataConstructors Nothing (Just n) (d : ds0)+ addDataConstructors (Just (n, [])) (d : ds0) -- and then repeat the process for the rest of the block- addDataConstructors Nothing Nothing ds1+ addDataConstructors Nothing ds1 Left (n, ns) -> lift $ declarationException $ AmbiguousConstructor (getRange d) n ns - addFunDef :: NiceDeclaration -> StateT (InterleavedMutual, MutualChecks, DeclNum) Nice ()+ addFunDef :: NiceDeclaration -> INice () addFunDef (FunDef _ ds _ _ tc cc n cs) = do- let check = MutualChecks [tc] [cc] []- (m, checks, i) <- get+ addInterleavedFun n ds cs $ MutualChecks [tc] [cc] []+ addFunDef _ = __IMPOSSIBLE__++ addInterleavedFun :: Name -> List1 Declaration -> List1 Clause -> MutualChecks -> INice ()+ addInterleavedFun n ds cs checks' = do+ ISt m checks i <- get case Map.lookup n m of Just (InterleavedFun i0 sig cs0) -> do let (cs', i') = case cs0 of Nothing -> ((i, (ds, cs) :| [] ), i + 1) Just (i1, cs1) -> ((i1, (ds, cs) <| cs1), i)- put (Map.insert n (InterleavedFun i0 sig (Just cs')) m, check <> checks, i')+ put $ ISt (Map.insert n (InterleavedFun i0 sig (Just cs')) m) (checks' <> checks) i' _ -> __IMPOSSIBLE__ -- A FunDef always come after an existing FunSig!- addFunDef _ = __IMPOSSIBLE__ addFunClauses :: KwRange+ -- Range of the @interleaved mutual@ keyword. -> [NiceDeclaration]- -> StateT (InterleavedMutual, MutualChecks, DeclNum) Nice [(DeclNum, NiceDeclaration)]- addFunClauses r (nd@(NiceFunClause _ _ _ tc cc _ d@(FunClause lhs _ _ _)) : ds) = do+ -> INice [(DeclNum, NiceDeclaration)]+ addFunClauses r (nd@(NiceFunClause _ _ _ tc cc _ (FunClause ai lhs _ _ _)) : ds) = do -- get the candidate functions that are in this interleaved mutual block- (m, checks, i) <- get+ ISt m checks i <- get let sigs = mapMaybe (\ (n, d) -> n <$ isInterleavedFun d) $ Map.toList m -- find the funsig candidates for the funclause of interest case [ (x, fits, rest) | x <- sigs- , let (fits, rest) = spanJust (couldBeNiceFunClauseOf (Map.lookup x fixs) x) (nd : ds)- , not (null fits)+ , let (fits0, rest) = spanJust (couldBeNiceFunClauseOf (Map.lookup x fixs) x) (nd : ds)+ , fits <- maybeToList $ List1.nonEmpty fits0 ] of -- no candidate: keep the isolated fun clause, we'll complain about it later [] -> do let check = MutualChecks [tc] [cc] []- put (m, check <> checks, i + 1)+ put $ ISt m (check <> checks) (i + 1) ((i,nd) :) <$> groupByBlocks r ds -- exactly one candidate: attach the funclause to the definition [(n, fits0, rest)] -> do- let (checkss, fits) = unzip fits0- ds <- lift $ expandEllipsis fits- cs <- lift $ mkClauses n ds empty- case Map.lookup n m of- Just (InterleavedFun i0 sig cs0) -> do- let (cs', i') = case cs0 of- Nothing -> ((i, (fits,cs) :| [] ), i + 1)- Just (i1, cs1) -> ((i1, (fits,cs) <| cs1), i)- let checks' = Fold.fold checkss- put (Map.insert n (InterleavedFun i0 sig (Just cs')) m, checks' <> checks, i')- _ -> __IMPOSSIBLE__+ let (checkss, fits) = List1.unzip fits0+ ds <- lift $ expandEllipsis1 fits+ cs <- lift $ mkClauses1 ai n ds empty+ addInterleavedFun n fits {- or? ds -} cs $ Fold.fold checkss groupByBlocks r rest -- more than one candidate: fail, complaining about the ambiguity! xf:xfs -> lift $ declarationException@@ -982,18 +1092,20 @@ groupByBlocks :: KwRange+ -- Range of the @interleaved mutual@ keyword. -> [NiceDeclaration]- -> StateT (InterleavedMutual, MutualChecks, DeclNum) Nice [(DeclNum, NiceDeclaration)]- groupByBlocks kwr [] = pure []+ -> INice [(DeclNum, NiceDeclaration)]+ groupByBlocks _kwr [] = pure [] groupByBlocks kwr (d : ds) = do -- for most branches we deal with the one declaration and move on let oneOff act = act >>= \ ns -> (ns ++) <$> groupByBlocks kwr ds case d of NiceDataSig{} -> oneOff $ [] <$ addDataType d- NiceDataDef r _ _ _ _ n _ ds -> oneOff $ [] <$ addDataConstructors (Just r) (Just n) ds- NiceLoneConstructor _ ds -> oneOff $ [] <$ addDataConstructors Nothing Nothing ds+ NiceDataDef _ _ _ _ _ n pars ds+ -> oneOff $ [] <$ addDataConstructors (Just (n, pars)) ds+ NiceLoneConstructor _ ds -> oneOff $ [] <$ addDataConstructors Nothing ds FunSig{} -> oneOff $ [] <$ addFunType d- FunDef _ _ _ _ _ _ n cs+ FunDef _ _ _ _ _ _ n _cs | not (isNoName n) -> oneOff $ [] <$ addFunDef d -- It's a bit different for fun clauses because we may need to grab a lot -- of clauses to handle ellipses properly.@@ -1001,8 +1113,8 @@ -- We do not need to worry about RecSig vs. RecDef: we know there's exactly one -- of each for record definitions and leaving them in place should be enough! _ -> oneOff $ do- (m, c, i) <- get -- TODO: grab checks from c?- put (m, c, i + 1)+ ISt m c i <- get -- TODO: grab checks from c?+ put $ ISt m c (i + 1) pure [(i,d)] -- Extract the name of the return type (if any) of a potential constructor.@@ -1026,14 +1138,13 @@ -- Turn an old-style mutual block into a new style mutual block -- by pushing the definitions to the end. mkOldMutual- :: KwRange -- Range of the @mutual@ keyword (if any).- -> [NiceDeclaration] -- Declarations inside the block.- -> Nice NiceDeclaration -- Returns a 'NiceMutual'.+ :: KwRange -- Range of the @mutual@ keyword (if any).+ -> [NiceDeclaration] -- Declarations inside the block.+ -> Nice (Maybe NiceDeclaration)+ -- Returns a 'NiceMutual' unless empty. mkOldMutual kwr ds' = do- -- Postulate the missing definitions- let ps = loneSigsFromLoneNames loneNames- checkLoneSigs ps- let ds = replaceSigs ps ds'+ -- Turn the missing definitions into postulates.+ ds <- turnLoneSignaturesIntoAxioms ds' $ loneSigsFromLoneNames loneSigNames -- -- Remove the declarations that aren't allowed in old style mutual blocks -- ds <- fmap catMaybes $ forM ds $ \ d -> let success = pure (Just d) in case d of@@ -1053,7 +1164,7 @@ -- Definitions of names go to the bottom. -- Some declarations are forbidden, as their positioning could confuse -- the user.- (top, bottom, invalid) <- forEither3M ds $ \ d -> do+ (top, bottom, _invalid) <- forEither3M ds $ \ d -> do let top = return (In1 d) bottom = return (In2 d) invalid s = In3 d <$ do declarationWarning $ NotAllowedInMutual (getRange d) s@@ -1075,13 +1186,18 @@ NiceImport{} -> top NiceRecSig{} -> top NiceDataSig{} -> top- -- Andreas, 2017-10-09, issue #2576, raise error about missing type signature+ -- Andreas, 2017-10-09, issue #2576, keep NiceFunClause in+ -- to raise error about missing type signature -- in ConcreteToAbstract rather than here.- NiceFunClause{} -> bottom+ -- Andreas, 2026-02-28, issue #4150: sort it up to give the+ -- MissingTypeSignature error priority over potential NotInScope errors.+ NiceFunClause{} -> top FunSig{} -> top FunDef{} -> bottom- NiceDataDef{} -> bottom- NiceRecDef{} -> bottom+ -- Andreas, 2026-02-28, issue #4150:+ -- Sort lone defs up to prioritise MissingTypeSignature error.+ NiceDataDef _ _ _ _ _ x _ _ -> if x `Set.member` loneDefNames then top else bottom+ NiceRecDef _ _ _ _ _ _ x _ _ _-> if x `Set.member` loneDefNames then top else bottom -- Andreas, 2018-05-11, issue #3051, allow pat.syn.s in mutual blocks -- Andreas, 2018-10-29: We shift pattern synonyms to the bottom -- since they might refer to constructors defined in a data types@@ -1097,7 +1213,7 @@ -- they all need to be. NiceOpaque r _ _ -> In3 d <$ do declarationException $ OpaqueInMutual r- NicePragma r pragma -> case pragma of+ NicePragma _r pragma -> case pragma of OptionsPragma{} -> top -- error thrown in the type checker @@ -1121,7 +1237,7 @@ OverlapPragma{} -> top ImpossiblePragma{} -> top -- error thrown in scope checker- EtaPragma{} -> bottom -- needs record definition+ EtaPragma{} -> top -- does not matter, pragma removed WarningOnUsage{} -> top WarningOnImport{} -> top InjectivePragma{} -> top -- only needs name, not definition@@ -1130,6 +1246,7 @@ -- The attached pragmas have already been handled at this point. CatchallPragma{} -> __IMPOSSIBLE__+ EtaEqualityPragma{} -> __IMPOSSIBLE__ TerminationCheckPragma{} -> __IMPOSSIBLE__ NoPositivityCheckPragma{} -> __IMPOSSIBLE__ PolarityPragma{} -> __IMPOSSIBLE__@@ -1166,13 +1283,15 @@ let pcs = map positivityCheckOldMutual ds let pc = combinePositivityChecks (pc0:pcs) - return $ NiceMutual kwr tc cc pc $ top ++ bottom+ return $ fmap (NiceMutual kwr tc cc pc) $ List1.nonEmpty $ top ++ bottom where sigNames = [ (r, x, k) | LoneSigDecl r k x <- map declKind ds' ] defNames = [ (x, k) | LoneDefs k xs <- map declKind ds', x <- xs ] -- compute the set difference with equality just on names- loneNames = [ (r, x, k) | (r, x, k) <- sigNames, List.all ((x /=) . fst) defNames ]+ loneSigNames = [ (r, x, k) | (r, x, k) <- sigNames, List.all ((x /=) . fst) defNames ]+ loneDefNames = Set.fromList [ x | (x, _) <- defNames, x `Set.notMember` sigNameSet ]+ sigNameSet = Set.fromList [ x | (_, x, _) <- sigNames ] termCheck :: NiceDeclaration -> TerminationCheck -- Andreas, 2013-02-28 (issue 804):@@ -1236,8 +1355,8 @@ positivityCheckOldMutual (NiceDataDef _ _ _ pc _ _ _ _) = pc positivityCheckOldMutual (NiceDataSig _ _ _ _ pc _ _ _ _) = pc positivityCheckOldMutual (NiceMutual _ _ _ pc _) = pc- positivityCheckOldMutual (NiceRecSig _ _ _ _ pc _ _ _ _) = pc- positivityCheckOldMutual (NiceRecDef _ _ _ pc _ _ _ _ _) = pc+ positivityCheckOldMutual (NiceRecSig _ _ _ _ pc _ _ _ _ _) = pc+ positivityCheckOldMutual (NiceRecDef _ _ _ pc _ _ _ _ _ _) = pc positivityCheckOldMutual _ = YesPositivityCheck -- A mutual block cannot have a measure,@@ -1255,8 +1374,8 @@ unless inherited $ declarationWarning $ UselessAbstract r return ds -- no change! - privateBlock- :: KwRange -- Range of @private@ keyword.+ privateBlock ::+ KwRange -- Range of @private@ keyword. -> Origin -- Origin of the private block. -> [NiceDeclaration] -> Nice [NiceDeclaration]@@ -1273,8 +1392,8 @@ where warn = declarationWarning $ UselessPrivate r - instanceBlock- :: KwRange -- Range of @instance@ keyword.+ instanceBlock ::+ KwRange -- Range of @instance@ keyword. -> [NiceDeclaration] -> Nice [NiceDeclaration] instanceBlock r ds = do@@ -1284,13 +1403,15 @@ return ds -- no change! -- Make a declaration eligible for instance search.- mkInstance- :: KwRange -- Range of @instance@ keyword.+ mkInstance ::+ KwRange -- Range of @instance@ keyword. -> Updater NiceDeclaration mkInstance r0 = \case Axiom r p a i rel x e -> (\ i -> Axiom r p a i rel x e) <$> setInstance r0 i FunSig r p a i m rel tc cc x e -> (\ i -> FunSig r p a i m rel tc cc x e) <$> setInstance r0 i- NiceUnquoteDecl r p a i tc cc x e -> (\ i -> NiceUnquoteDecl r p a i tc cc x e) <$> setInstance r0 i+ -- Andreas, 2026-10-19, AIM XLIII, issue 8847+ -- The type checker ignores the IsInstanceDef for UnquoteDecl, so it does not help to propagate it here.+ -- NiceUnquoteDecl r p a i tc cc x e -> (\ i -> NiceUnquoteDecl r p a i tc cc x e) <$> setInstance r0 i NiceMutual r tc cc pc ds -> NiceMutual r tc cc pc <$> mapM (mkInstance r0) ds NiceLoneConstructor r ds -> NiceLoneConstructor r <$> mapM (mkInstance r0) ds d@NiceFunClause{} -> return d@@ -1298,6 +1419,7 @@ NiceOpaque r ns i -> (\ i -> NiceOpaque r ns i) <$> traverse (mkInstance r0) i d@NiceField{} -> return d -- Field instance are handled by the parser d@PrimitiveFunction{} -> return d+ d@NiceUnquoteDecl{} -> return d d@NiceUnquoteDef{} -> return d d@NiceRecSig{} -> return d d@NiceDataSig{} -> return d@@ -1361,6 +1483,7 @@ mkAbstract = traverse . mkAbstract instance MakeAbstract a => MakeAbstract [a]+instance MakeAbstract a => MakeAbstract (List1 a) -- Leads to overlap with 'WhereClause': -- instance (Traversable f, MakeAbstract a) => MakeAbstract (f a) where@@ -1378,16 +1501,16 @@ NiceLoneConstructor r ds -> NiceLoneConstructor r <$> mkAbstract kwr ds FunDef r ds a i tc cc x cs -> (\ a -> FunDef r ds a i tc cc x) <$> mkAbstract kwr a <*> mkAbstract kwr cs NiceDataDef r o a pc uc x ps cs -> (\ a -> NiceDataDef r o a pc uc x ps) <$> mkAbstract kwr a <*> mkAbstract kwr cs- NiceRecDef r o a pc uc x dir ps cs -> (\ a -> NiceRecDef r o a pc uc x dir ps cs) <$> mkAbstract kwr a+ NiceRecDef r o a pc uc eta x dir ps cs -> (\ a -> NiceRecDef r o a pc uc eta x dir ps cs) <$> mkAbstract kwr a NiceFunClause r p a tc cc catchall d -> (\ a -> NiceFunClause r p a tc cc catchall d) <$> mkAbstract kwr a -- The following declarations have an @InAbstract@ field -- but are not really definitions, so we do count them into -- the declarations which can be made abstract -- (thus, do not notify progress with @dirty@).- Axiom r p a i rel x e -> return $ Axiom r p AbstractDef i rel x e- FunSig r p a i m rel tc cc x e -> return $ FunSig r p AbstractDef i m rel tc cc x e- NiceRecSig r er p a pc uc x ls t -> return $ NiceRecSig r er p AbstractDef pc uc x ls t- NiceDataSig r er p a pc uc x ls t -> return $ NiceDataSig r er p AbstractDef pc uc x ls t+ Axiom r p _ i rel x e -> return $ Axiom r p AbstractDef i rel x e+ FunSig r p _ i m rel tc cc x e -> return $ FunSig r p AbstractDef i m rel tc cc x e+ NiceRecSig r er p _ pc uc eta x ls t-> return $ NiceRecSig r er p AbstractDef pc uc eta x ls t+ NiceDataSig r er p _ pc uc x ls t -> return $ NiceDataSig r er p AbstractDef pc uc x ls t NiceField r p _ i tac x e -> return $ NiceField r p AbstractDef i tac x e PrimitiveFunction r p _ x e -> return $ PrimitiveFunction r p AbstractDef x e -- Andreas, 2016-07-17 it does have effect on unquoted defs.@@ -1409,8 +1532,8 @@ NiceOpaque r ns ds -> NiceOpaque r ns <$> mkAbstract kwr ds instance MakeAbstract Clause where- mkAbstract kwr (Clause x catchall lhs rhs wh with) = do- Clause x catchall lhs rhs <$> mkAbstract kwr wh <*> mkAbstract kwr with+ mkAbstract kwr (Clause x catchall ai lhs rhs wh with) = do+ Clause x catchall ai lhs rhs <$> mkAbstract kwr wh <*> mkAbstract kwr with -- | Contents of a @where@ clause are abstract if the parent is. --@@ -1444,6 +1567,7 @@ mkPrivate kwr o = traverse $ mkPrivate kwr o instance MakePrivate a => MakePrivate [a]+instance MakePrivate a => MakePrivate (List1 a) -- Leads to overlap with 'WhereClause': -- instance (Traversable f, MakePrivate a) => MakePrivate (f a) where@@ -1460,11 +1584,10 @@ NiceField r p a i tac x e -> (\ p -> NiceField r p a i tac x e) <$> mkPrivate kwr o p PrimitiveFunction r p a x e -> (\ p -> PrimitiveFunction r p a x e) <$> mkPrivate kwr o p NiceMutual r tc cc pc ds -> (\ ds-> NiceMutual r tc cc pc ds) <$> mkPrivate kwr o ds- NiceLoneConstructor r ds -> NiceLoneConstructor r <$> mkPrivate kwr o ds NiceModule r p a e x tel ds -> (\ p -> NiceModule r p a e x tel ds) <$> mkPrivate kwr o p NiceModuleMacro r p e x ma op is -> (\ p -> NiceModuleMacro r p e x ma op is) <$> mkPrivate kwr o p FunSig r p a i m rel tc cc x e -> (\ p -> FunSig r p a i m rel tc cc x e) <$> mkPrivate kwr o p- NiceRecSig r er p a pc uc x ls t -> (\ p -> NiceRecSig r er p a pc uc x ls t) <$> mkPrivate kwr o p+ NiceRecSig r er p a pc uc eta x ls t -> (\ p -> NiceRecSig r er p a pc uc eta x ls t) <$> mkPrivate kwr o p NiceDataSig r er p a pc uc x ls t -> (\ p -> NiceDataSig r er p a pc uc x ls t) <$> mkPrivate kwr o p NiceFunClause r p a tc cc catchall d -> (\ p -> NiceFunClause r p a tc cc catchall d) <$> mkPrivate kwr o p NiceUnquoteDecl r p a i tc cc x e -> (\ p -> NiceUnquoteDecl r p a i tc cc x e) <$> mkPrivate kwr o p@@ -1473,24 +1596,25 @@ NiceGeneralize r p i tac x t -> (\ p -> NiceGeneralize r p i tac x t) <$> mkPrivate kwr o p NiceOpaque r ns ds -> (\ p -> NiceOpaque r ns p) <$> mkPrivate kwr o ds d@NicePragma{} -> return d- d@(NiceOpen r _x dir) -> d <$ do+ d@(NiceOpen _kwr _x dir) -> d <$ do unless (null kwr) $ whenJust (publicOpen dir) \ kwrPublic ->- lift $ declarationWarning $ OpenImportPrivate r kwrPublic kwr OpenNotImport- d@(NiceImport r _x _as _open dir) -> d <$ do+ lift $ declarationWarning $ OpenImportPrivate (getRange d) kwrPublic kwr OpenNotImport+ d@(NiceImport opn impR x args dir) -> d <$ do unless (null kwr) $ whenJust (publicOpen dir) \ kwrPublic ->- lift $ declarationWarning $ OpenImportPrivate r kwrPublic kwr ImportMayOpen+ lift $ declarationWarning $ OpenImportPrivate (getRange (opn, impR, x, args, dir)) kwrPublic kwr ImportMayOpen -- Andreas, 2016-07-08, issue #2089 -- we need to propagate 'private' to the named where modules FunDef r ds a i tc cc x cls -> FunDef r ds a i tc cc x <$> mkPrivate kwr o cls+ d@NiceLoneConstructor{} -> return d -- Issue #7998: constructors cannot be private d@NiceDataDef{} -> return d d@NiceRecDef{} -> return d d@NiceUnquoteData{} -> return d instance MakePrivate Clause where- mkPrivate kwr o (Clause x catchall lhs rhs wh with) = do- Clause x catchall lhs rhs <$> mkPrivate kwr o wh <*> mkPrivate kwr o with+ mkPrivate kwr o (Clause x catchall ai lhs rhs wh with) = do+ Clause x catchall ai lhs rhs <$> mkPrivate kwr o wh <*> mkPrivate kwr o with instance MakePrivate WhereClause where mkPrivate kwr o = \case@@ -1505,6 +1629,75 @@ SomeWhere r e m a ds -> mkPrivate kwr o a <&> \a' -> SomeWhere r e m a' ds +-- | Check data/record definition parameters for parts that are not allowed+-- (allowed if at all in data/record signatures).+niceDefParameters :: DataOrRecord_ -> Parameters -> Nice DefParameters+niceDefParameters dataOrRec = concatMapM \case+ DomainFree x ->+ singleton <$> strip x+ DomainFull (TBind _r xs a) -> do+ warn a "parameter type"+ mapM strip $ List1.toList xs+ DomainFull (TLet r _ds) ->+ [] <$ warn r "parameter `let'"+ where+ warn :: HasRange a => a -> Text -> Nice ()+ warn a what = declarationWarning $+ InvalidDataOrRecDefParameter (getRange a) dataOrRec what $+ "(note: parameters may not repeat information from signature)"++ strip :: NamedArg Binder -> Nice (WithHiding (Named_ Name))+ strip (Arg (ArgInfo h m _o _fv ann) (Named mn (Binder mp _bo (BName x fx tac _)))) =+ WithHiding h (Named mn x) <$ do+ unless (null m) $ warn m "parameter modality"+ unless (null ann) $ warn ann "parameter annotation"+ unless (null mp) $ warn mp "pattern attached to parameter"+ unless (null tac) $ warn tac "tactic argument"+ unless (null fx) $ __IMPOSSIBLE__++-- | Emit bits attached to the given name+-- that have been accumulated during processing of the interleaved mutual block+-- as 'NiceDeclaration'.+--+-- Warns about mistakes in parameters in data definition blocks;+-- but those parameters are finally ignored, taking the parameters of+-- the data signature instead.+interleavedDecl :: Name -> InterleavedDecl -> Nice [(DeclNum, NiceDeclaration)]+interleavedDecl k = \case++ InterleavedData i d@(NiceDataSig _ _ _acc abs pc uc _ pars _) ds -> do+ let+ fpars = parametersToDefParameters pars+ r = getRange (k, fpars)+ ddef cs = NiceDataDef (getRange (r, cs)) UserWritten abs pc uc k fpars cs+ case ds of+ Nothing -> return [(i, d)] -- signature only+ Just (j, dds) -> do+ dds' <- forM (List1.reverse dds) \ (defpars, cs) -> do+ unless (null defpars || defpars == fpars) $ declarationWarning $+ InvalidDataOrRecDefParameter (getRange defpars) IsData "parameter names" $+ "(in `interleaved mutual' blocks, parameters of a data definition must either be omitted or match exactly the parameters given in the data signature)"+ pure cs+ return [(i, d), (j, ddef $ sconcat dds')]++ InterleavedFun i d@(FunSig r _acc abs inst _mac _info tc cc n _e) dcs -> do+ let+ fdef dcss = FunDef r (sconcat dss) abs inst tc cc n (sconcat css)+ where (dss, css) = List1.unzip $ List1.reverse dcss+ return . ((i,d) :) . maybeToList $ fmap (second fdef) dcs++ _ -> __IMPOSSIBLE__ -- someone messed up and broke the invariant++-- | Make sure that the 'TacticAttribute' is empty.+dropTactic :: TacticAttribute -> Nice ()+dropTactic = \case+ TacticAttribute Nothing -> return ()+ TacticAttribute (Just re) -> declarationWarning $ InvalidTacticAttribute $ getRange re++-- | Ensure there is no local rewrite attribute+dropRew :: LensRewriteAnn a => a -> Nice a+dropRew = ignoreRew $ declarationWarning . InvalidRewriteAttribute . getRange+ -- The following function is (at the time of writing) only used three -- times: for building Lets, and for printing error messages. @@ -1515,21 +1708,21 @@ Axiom _ _ _ i rel x e -> inst i $ TypeSig rel empty x e NiceField _ _ _ i tac x argt -> singleton $ FieldSig i tac x argt PrimitiveFunction _ _ _ x e -> singleton $ Primitive empty $ singleton $ TypeSig (argInfo e) empty x (unArg e)- NiceMutual r _ _ _ ds -> singleton $ Mutual r $ List1.concat $ fmap notSoNiceDeclarations ds+ NiceMutual r _ _ _ ds -> singleton $ Mutual r $ List1.toList $ sconcat $ fmap notSoNiceDeclarations ds NiceLoneConstructor r ds -> singleton $ LoneConstructor r $ List1.concat $ fmap notSoNiceDeclarations ds NiceModule r _ _ e x tel ds -> singleton $ Module r e x tel ds NiceModuleMacro r _ e x ma o dir -> singleton $ ModuleMacro r e x ma o dir- NiceOpen r x dir -> singleton $ Open r x dir- NiceImport r x as o dir -> singleton $ Import r x as o dir+ NiceOpen kwr x dir -> singleton $ Open kwr x dir+ NiceImport o r x as dir -> singleton $ Import o r x as dir NicePragma _ p -> singleton $ Pragma p- NiceRecSig r er _ _ _ _ x bs e -> singleton $ RecordSig r er x bs e+ NiceRecSig r er _ _ _ _ _ x bs e -> singleton $ RecordSig r er x bs e NiceDataSig r er _ _ _ _ x bs e -> singleton $ DataSig r er x bs e NiceFunClause _ _ _ _ _ _ d -> singleton $ d FunSig _ _ _ i _ rel _ _ x e -> inst i $ TypeSig rel empty x e- FunDef _ ds _ _ _ _ _ _ -> List1.fromListSafe __IMPOSSIBLE__ ds -- TODO: use List1 in type of FunDef- NiceDataDef r _ _ _ _ x bs cs -> singleton $ DataDef r x bs $ List1.concat $ fmap notSoNiceDeclarations cs- NiceRecDef r _ _ _ _ x dir bs ds -> singleton $ RecordDef r x dir bs ds+ FunDef _ ds _ _ _ _ _ _ -> ds+ NiceDataDef r _ _ _ _ x bs cs -> singleton $ DataDef r x (defParametersToParameters bs) $ List1.concat $ fmap notSoNiceDeclarations cs+ NiceRecDef r _ _ _ _ _ x dir bs ds -> singleton $ RecordDef r x dir (defParametersToParameters bs) ds NicePatternSyn r _ n as p -> singleton $ PatternSyn r n as p NiceGeneralize _ _ i tac n e -> singleton $ Generalize empty $ singleton $ TypeSig i tac n e NiceUnquoteDecl r _ _ i _ _ x e -> inst i $ UnquoteDecl r x e@@ -1559,7 +1752,7 @@ FunSig{} -> Nothing FunDef _ _ a _ _ _ _ _ -> Just a NiceDataDef _ _ a _ _ _ _ _ -> Just a- NiceRecDef _ _ a _ _ _ _ _ _ -> Just a+ NiceRecDef _ _ a _ _ _ _ _ _ _ -> Just a NicePatternSyn{} -> Nothing NiceGeneralize{} -> Nothing NiceUnquoteDecl _ _ a _ _ _ _ _ -> Just a
src/full/Agda/Syntax/Concrete/Definitions/Errors.hs view
@@ -1,6 +1,11 @@+{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-}+ module Agda.Syntax.Concrete.Definitions.Errors where import Control.DeepSeq+import Data.Text (Text) import GHC.Generics (Generic) @@ -12,13 +17,14 @@ import Agda.Interaction.Options.Warnings -import Agda.Utils.Null ( empty )+import Agda.Utils.Boolean ( ifThenElse ) import Agda.Utils.CallStack ( CallStack )-import Agda.Utils.List1 (List1, pattern (:|))-import Agda.Utils.List2 (List2, pattern List2)-import qualified Agda.Utils.List1 as List1-import Agda.Utils.Set1 (Set1)-import qualified Agda.Utils.Set1 as Set1+import Agda.Utils.List1 ( List1 )+import Agda.Utils.List1 qualified as List1+import Agda.Utils.List2 ( List2 )+import Agda.Utils.Null ( empty )+import Agda.Utils.Set1 ( Set1 )+import Agda.Utils.Set1 qualified as Set1 import Agda.Utils.Singleton ------------------------------------------------------------------------@@ -33,8 +39,11 @@ -- | The exception type. data DeclarationException' = MultipleEllipses Pattern- | DuplicateDefinition Name- | DuplicateAnonDeclaration Range+ | DuplicateDefinition Name Range+ -- ^ The 'Range' is the range of the previous definition.+ | DuplicateAnonDeclaration Range Range+ -- ^ The first 'Range' is the range of the current declaration of _.+ -- The second 'Range' is the range of the previous declaration of _. | MissingWithClauses Name LHS | WrongDefinition Name DataRecOrFun DataRecOrFun | WrongContentBlock KindOfBlock Range@@ -89,7 +98,10 @@ -- | Non-fatal errors encountered in the Nicifier. data DeclarationWarning' -- Please keep in (mostly) alphabetical order.- = EmptyAbstract KwRange -- ^ Empty @abstract@ block.+ = DivergentModalityInClause ArgInfo ArgInfo+ -- ^ The modality of the clause (second 'ArgInfo', range of the warning)+ -- is different from the modality of the type signature (first 'ArgInfo').+ | EmptyAbstract KwRange -- ^ Empty @abstract@ block. | EmptyConstructor KwRange -- ^ Empty @data _ where@ block. | EmptyField KwRange -- ^ Empty @field@ block. | EmptyGeneralize KwRange -- ^ Empty @variable@ block.@@ -101,6 +113,8 @@ | EmptyPrimitive KwRange -- ^ Empty @primitive@ block. | EmptyPolarityPragma Range -- ^ POLARITY pragma without any polarities.+ | FixityDeclarationForNonOperator Range Name+ -- ^ A fixity declaration for a closed operator or syntax. | HiddenGeneralize Range -- ^ A 'Hidden' identifier in a @variable@ declaration. -- Hiding has no effect there as generalized variables are always hidden@@ -112,6 +126,14 @@ -- ^ Invalid constructor block (not inside an interleaved mutual block) | InvalidCoverageCheckPragma Range -- ^ A {-\# NON_COVERING \#-} pragma that does not apply to any function.+ | InvalidDataOrRecDefParameter Range DataOrRecord_ Text Text+ -- ^ An entry in a data or record definition parameter that is not allowed here.+ -- Such parameters can only be names with hiding.+ -- The first 'Text' says what is wrong and thus ignored.+ -- The second 'Text' may contain extra details or clarification.+ | InvalidEtaEqualityPragma Range+ -- ^ A {-\# ETA_EQUALITY \#-} pragma+ -- that does not apply to any record type. | InvalidNoPositivityCheckPragma Range -- ^ A {-\# NO_POSITIVITY_CHECK \#-} pragma -- that does not apply to any data or record type.@@ -121,6 +143,10 @@ | InvalidTerminationCheckPragma Range -- ^ A {-\# TERMINATING \#-} and {-\# NON_TERMINATING \#-} pragma -- that does not apply to any function.+ | InvalidTacticAttribute Range+ -- ^ A misplaced @tactic@ attribute.+ | InvalidRewriteAttribute Range+ -- ^ A misplaced @rewrite@ attribute. | MissingDataDeclaration Name -- ^ A @data@ definition without a @data@ signature. | MissingDefinitions (List1 (Name, Range))@@ -141,7 +167,6 @@ -- by @{-\# TERMINATING \#-}@ and @{-\# NON_TERMINATING \#-}@. | PragmaCompiled Range -- ^ @COMPILE@ pragmas are not allowed in safe mode.- | SafeFlagEta Range -- ^ @ETA@ pragma is unsafe. | SafeFlagInjective Range -- ^ @INJECTIVE@ pragma is unsafe. | SafeFlagNoCoverageCheck Range -- ^ @NON_COVERING@ pragma is unsafe. | SafeFlagNoPositivityCheck Range -- ^ @NO_POSITIVITY_CHECK@ pragma is unsafe.@@ -162,6 +187,8 @@ -- ^ @macro@ block with nothing that can (newly) be made macro. | UselessPrivate KwRange -- ^ @private@ block with nothing that can (newly) be made private.+ | UselessImport Range+ -- ^ An @import@ that is applied to parameters by neither bound not opened. deriving (Show, Generic) -- | @open@ or @import@@@ -176,48 +203,54 @@ declarationWarningName' :: DeclarationWarning' -> WarningName declarationWarningName' = \case -- Please keep in alphabetical order.- EmptyAbstract{} -> EmptyAbstract_- EmptyConstructor{} -> EmptyConstructor_- EmptyField{} -> EmptyField_- EmptyGeneralize{} -> EmptyGeneralize_- EmptyInstance{} -> EmptyInstance_- EmptyMacro{} -> EmptyMacro_- EmptyMutual{} -> EmptyMutual_- EmptyPrivate{} -> EmptyPrivate_- EmptyPostulate{} -> EmptyPostulate_- EmptyPrimitive{} -> EmptyPrimitive_- EmptyPolarityPragma{} -> EmptyPolarityPragma_- HiddenGeneralize{} -> HiddenGeneralize_- InvalidCatchallPragma{} -> InvalidCatchallPragma_- InvalidConstructorBlock{} -> InvalidConstructorBlock_- InvalidNoPositivityCheckPragma{} -> InvalidNoPositivityCheckPragma_- InvalidNoUniverseCheckPragma{} -> InvalidNoUniverseCheckPragma_- InvalidTerminationCheckPragma{} -> InvalidTerminationCheckPragma_- InvalidCoverageCheckPragma{} -> InvalidCoverageCheckPragma_- MissingDataDeclaration{} -> MissingDataDeclaration_- MissingDefinitions{} -> MissingDefinitions_- NotAllowedInMutual{} -> NotAllowedInMutual_- OpenImportPrivate{} -> OpenImportPrivate_- OpenImportAbstract{} -> OpenImportAbstract_- PolarityPragmasButNotPostulates{} -> PolarityPragmasButNotPostulates_- PragmaNoTerminationCheck{} -> PragmaNoTerminationCheck_- PragmaCompiled{} -> PragmaCompiled_- SafeFlagEta {} -> SafeFlagEta_- SafeFlagInjective {} -> SafeFlagInjective_- SafeFlagNoCoverageCheck {} -> SafeFlagNoCoverageCheck_- SafeFlagNoPositivityCheck {} -> SafeFlagNoPositivityCheck_- SafeFlagNoUniverseCheck {} -> SafeFlagNoUniverseCheck_- SafeFlagNonTerminating {} -> SafeFlagNonTerminating_- SafeFlagPolarity {} -> SafeFlagPolarity_- SafeFlagTerminating {} -> SafeFlagTerminating_- ShadowingInTelescope{} -> ShadowingInTelescope_- UnknownFixityInMixfixDecl{} -> UnknownFixityInMixfixDecl_- UnknownNamesInFixityDecl{} -> UnknownNamesInFixityDecl_- UnknownNamesInPolarityPragmas{} -> UnknownNamesInPolarityPragmas_- UselessAbstract{} -> UselessAbstract_- UselessInstance{} -> UselessInstance_- UselessMacro{} -> UselessMacro_- UselessPrivate{} -> UselessPrivate_+ DivergentModalityInClause {} -> DivergentModalityInClause_+ EmptyAbstract {} -> EmptyAbstract_+ EmptyConstructor {} -> EmptyConstructor_+ EmptyField {} -> EmptyField_+ EmptyGeneralize {} -> EmptyGeneralize_+ EmptyInstance {} -> EmptyInstance_+ EmptyMacro {} -> EmptyMacro_+ EmptyMutual {} -> EmptyMutual_+ EmptyPrivate {} -> EmptyPrivate_+ EmptyPostulate {} -> EmptyPostulate_+ EmptyPrimitive {} -> EmptyPrimitive_+ EmptyPolarityPragma {} -> EmptyPolarityPragma_+ FixityDeclarationForNonOperator {} -> FixityDeclarationForNonOperator_+ HiddenGeneralize {} -> HiddenGeneralize_+ InvalidCatchallPragma {} -> InvalidCatchallPragma_+ InvalidConstructorBlock {} -> InvalidConstructorBlock_+ InvalidDataOrRecDefParameter {} -> InvalidDataOrRecDefParameter_+ InvalidEtaEqualityPragma {} -> InvalidEtaEqualityPragma_+ InvalidNoPositivityCheckPragma {} -> InvalidNoPositivityCheckPragma_+ InvalidNoUniverseCheckPragma {} -> InvalidNoUniverseCheckPragma_+ InvalidTerminationCheckPragma {} -> InvalidTerminationCheckPragma_+ InvalidCoverageCheckPragma {} -> InvalidCoverageCheckPragma_+ InvalidTacticAttribute {} -> InvalidTacticAttribute_+ InvalidRewriteAttribute {} -> MisplacedRewrite_+ MissingDataDeclaration {} -> MissingDataDeclaration_+ MissingDefinitions {} -> MissingDefinitions_+ NotAllowedInMutual {} -> NotAllowedInMutual_+ OpenImportPrivate {} -> OpenImportPrivate_+ OpenImportAbstract {} -> OpenImportAbstract_+ PolarityPragmasButNotPostulates {} -> PolarityPragmasButNotPostulates_+ PragmaNoTerminationCheck {} -> PragmaNoTerminationCheck_+ PragmaCompiled {} -> PragmaCompiled_+ SafeFlagInjective {} -> SafeFlagInjective_+ SafeFlagNoCoverageCheck {} -> SafeFlagNoCoverageCheck_+ SafeFlagNoPositivityCheck {} -> SafeFlagNoPositivityCheck_+ SafeFlagNoUniverseCheck {} -> SafeFlagNoUniverseCheck_+ SafeFlagNonTerminating {} -> SafeFlagNonTerminating_+ SafeFlagPolarity {} -> SafeFlagPolarity_+ SafeFlagTerminating {} -> SafeFlagTerminating_+ ShadowingInTelescope {} -> ShadowingInTelescope_+ UnknownFixityInMixfixDecl {} -> UnknownFixityInMixfixDecl_+ UnknownNamesInFixityDecl {} -> UnknownNamesInFixityDecl_+ UnknownNamesInPolarityPragmas {} -> UnknownNamesInPolarityPragmas_+ UselessAbstract {} -> UselessAbstract_+ UselessImport {} -> UselessImport_+ UselessInstance {} -> UselessInstance_+ UselessMacro {} -> UselessMacro_+ UselessPrivate {} -> UselessPrivate_ -- | Nicifier warnings turned into errors in @--safe@ mode. unsafeDeclarationWarning :: DeclarationWarning -> Bool@@ -226,6 +259,7 @@ unsafeDeclarationWarning' :: DeclarationWarning' -> Bool unsafeDeclarationWarning' = \case -- Please keep in alphabetical order.+ DivergentModalityInClause{} -> False EmptyAbstract{} -> False EmptyConstructor{} -> False EmptyField{} -> False@@ -237,13 +271,18 @@ EmptyPostulate{} -> False EmptyPrimitive{} -> False EmptyPolarityPragma{} -> False+ FixityDeclarationForNonOperator{} -> False HiddenGeneralize{} -> False InvalidCatchallPragma{} -> False InvalidConstructorBlock{} -> False+ InvalidDataOrRecDefParameter{} -> False+ InvalidEtaEqualityPragma{} -> False InvalidNoPositivityCheckPragma{} -> False InvalidNoUniverseCheckPragma{} -> False InvalidTerminationCheckPragma{} -> False InvalidCoverageCheckPragma{} -> False+ InvalidTacticAttribute{} -> False+ InvalidRewriteAttribute{} -> False MissingDataDeclaration{} -> True -- not safe MissingDefinitions{} -> False -- not safe but deferred until after typechecking NotAllowedInMutual{} -> False -- really safe?@@ -252,7 +291,6 @@ PolarityPragmasButNotPostulates{} -> False PragmaNoTerminationCheck{} -> True -- not safe PragmaCompiled{} -> True -- not safe- SafeFlagEta {} -> True SafeFlagInjective {} -> True SafeFlagNoCoverageCheck {} -> True SafeFlagNoPositivityCheck {} -> True@@ -265,6 +303,7 @@ UnknownNamesInFixityDecl{} -> False UnknownNamesInPolarityPragmas{} -> False UselessAbstract{} -> False+ UselessImport{} -> False UselessInstance{} -> False UselessMacro{} -> False UselessPrivate{} -> False@@ -278,7 +317,8 @@ CatchallPragma{} -> empty CompilePragma{} -> singleton $ PragmaCompiled r DisplayPragma{} -> empty- EtaPragma{} -> singleton $ SafeFlagEta r+ EtaPragma{} -> empty+ EtaEqualityPragma{} -> empty ForeignPragma{} -> empty ImpossiblePragma{} -> empty InjectivePragma{} -> singleton $ SafeFlagInjective r@@ -317,11 +357,11 @@ instance HasRange DeclarationException' where getRange (MultipleEllipses d) = getRange d- getRange (DuplicateDefinition x) = getRange x- getRange (DuplicateAnonDeclaration r) = r- getRange (MissingWithClauses x lhs) = getRange lhs- getRange (WrongDefinition x k k') = getRange x- getRange (AmbiguousFunClauses lhs xs) = getRange lhs+ getRange (DuplicateDefinition x _) = getRange x+ getRange (DuplicateAnonDeclaration r _) = r+ getRange (MissingWithClauses _x lhs) = getRange lhs+ getRange (WrongDefinition x _k _k') = getRange x+ getRange (AmbiguousFunClauses lhs _xs) = getRange lhs getRange (AmbiguousConstructor r _ _) = r getRange (WrongContentBlock _ r) = r getRange (InvalidMeasureMutual r) = r@@ -336,6 +376,7 @@ instance HasRange DeclarationWarning' where getRange = \case+ DivergentModalityInClause _ ai -> getRange ai EmptyAbstract kwr -> getRange kwr EmptyConstructor kwr -> getRange kwr EmptyField kwr -> getRange kwr@@ -347,22 +388,26 @@ EmptyPrimitive kwr -> getRange kwr EmptyPrivate kwr -> getRange kwr EmptyPolarityPragma r -> r+ FixityDeclarationForNonOperator r _ -> r HiddenGeneralize r -> r InvalidCatchallPragma r -> r InvalidConstructorBlock r -> r InvalidCoverageCheckPragma r -> r+ InvalidDataOrRecDefParameter r _ _ _ -> r+ InvalidEtaEqualityPragma r -> r InvalidNoPositivityCheckPragma r -> r InvalidNoUniverseCheckPragma r -> r InvalidTerminationCheckPragma r -> r+ InvalidTacticAttribute r -> r+ InvalidRewriteAttribute r -> r MissingDataDeclaration x -> getRange x MissingDefinitions xs -> getRange xs- NotAllowedInMutual r x -> r+ NotAllowedInMutual r _x -> r OpenImportAbstract r _kwr _ -> getRange r OpenImportPrivate _r kwr _kwr _ -> getRange kwr PolarityPragmasButNotPostulates xs -> getRange xs PragmaCompiled r -> r PragmaNoTerminationCheck r -> r- SafeFlagEta r -> r SafeFlagInjective r -> r SafeFlagNoCoverageCheck r -> r SafeFlagNoPositivityCheck r -> r@@ -375,6 +420,7 @@ UnknownNamesInFixityDecl xs -> getRange xs UnknownNamesInPolarityPragmas xs -> getRange xs UselessAbstract kwr -> getRange kwr+ UselessImport r -> r UselessInstance kwr -> getRange kwr UselessMacro kwr -> getRange kwr UselessPrivate kwr -> getRange kwr@@ -384,22 +430,23 @@ instance Pretty DeclarationException' where pretty (MultipleEllipses p) = fsep $ pwords "Multiple ellipses in left-hand side" ++ [pretty p]- pretty (DuplicateDefinition x) = fsep $- pwords "Duplicate definition of" ++ [pretty x]- pretty (DuplicateAnonDeclaration _) = fsep $- pwords "Duplicate declaration of _"- pretty (MissingWithClauses x lhs) = fsep $+ pretty (DuplicateDefinition x y) = fsep $+ pwords "Duplicate definition of" ++ [pretty x <> "."] +++ pwords "Previous definition at" ++ [pretty y]+ pretty (DuplicateAnonDeclaration _ y) = fsep $+ pwords "Duplicate declaration of _." +++ pwords "Previous definition at" ++ [pretty y]+ pretty (MissingWithClauses x _lhs) = fsep $ pwords "Missing with-clauses for function" ++ [pretty x] pretty (WrongDefinition x k k') = fsep $ pretty x : pwords ("has been declared as a " ++ prettyShow k ++ ", but is being defined as a " ++ prettyShow k')- pretty (AmbiguousFunClauses lhs xs) = sep- [ fsep $- pwords "More than one matching type signature for left hand side " ++ [pretty lhs] ++- pwords "it could belong to any of:"- , vcat $ fmap (pretty . PrintRange) xs- ]+ pretty (AmbiguousFunClauses lhs xs) = vcat $+ "More than one matching type signature for left hand side" :+ pretty lhs :+ "Candidates:" :+ map (("-" <+>) . pretty . PrintRange) (List1.toList xs) pretty (AmbiguousConstructor _ n ns) = sep [ fsep (pwords "Could not find a matching data signature for constructor " ++ [pretty n]) , vcat (case ns of@@ -436,43 +483,59 @@ instance Pretty DeclarationWarning' where pretty = \case - UnknownNamesInFixityDecl xs -> fsep $- pwords "The following names are not declared in the same scope as their syntax or fixity declaration (i.e., either not in scope at all, imported from another module, or declared in a super module):"- ++ punctuate comma (fmap pretty $ Set1.toList xs)+ DivergentModalityInClause sigInfo clInfo -> fsep $ concat+ [ pwords "Ignoring the modality"+ , [ pretty (getModality clInfo) ]+ , pwords "of the clause that diverges from the declared modality"+ , [ pretty (getModality sigInfo) ]+ , pwords "of the function"+ ] - UnknownFixityInMixfixDecl xs -> fsep $- pwords "The following mixfix names do not have an associated fixity declaration:"- ++ punctuate comma (fmap pretty $ Set1.toList xs)+ UnknownNamesInFixityDecl xs ->+ fwords "The following names are not declared in the same scope as their syntax or fixity declaration (i.e., either not in scope at all, imported from another module, or declared in a super module):"+ <?>+ fsep (fmap pretty $ Set1.toList xs) - UnknownNamesInPolarityPragmas xs -> fsep $- pwords "The following names are not declared in the same scope as their polarity pragmas (they could for instance be out of scope, imported from another module, or declared in a super module):"- ++ punctuate comma (fmap pretty $ Set1.toList xs)+ UnknownFixityInMixfixDecl xs ->+ fwords "The following mixfix names lack an associated fixity declaration:"+ <?>+ fsep (fmap pretty $ Set1.toList xs) + UnknownNamesInPolarityPragmas xs ->+ fwords "The following names are not declared in the same scope as their polarity pragmas (they could for instance be out of scope, imported from another module, or declared in a super module):"+ <?>+ fsep (fmap pretty $ Set1.toList xs)+ MissingDataDeclaration x -> fsep $ concat [ pwords "Data definition" , [ pretty x ] , pwords "misses a data declaration" ] - MissingDefinitions xs -> fsep $- pwords "The following names are declared but not accompanied by a definition:"- ++ punctuate comma (fmap (pretty . fst) xs)+ MissingDefinitions xs ->+ fwords "The following names are declared but lack a definition:"+ <?>+ fsep (fmap (pretty . fst) xs) - NotAllowedInMutual r nd -> fsep $+ NotAllowedInMutual _r nd -> fsep $ text nd : pwords "in mutual blocks are not supported. Suggestion: get rid of the mutual block by manually ordering declarations" - PolarityPragmasButNotPostulates xs -> fsep $- pwords "Polarity pragmas have been given for the following identifiers which are not postulates:"- ++ punctuate comma (fmap pretty $ Set1.toList xs)+ PolarityPragmasButNotPostulates xs ->+ fwords "Polarity pragmas have been given for the following identifiers which are not postulates:"+ <?>+ fsep (fmap pretty $ Set1.toList xs) UselessPrivate _ -> fsep $- pwords "Using private here has no effect. Private applies only to declarations that introduce new identifiers into the module, like type signatures and data, record, and module declarations."+ pwords "Using private here has no effect. Private applies only to declarations that introduce new identifiers into the module, like type signatures except for constructors, and data, record, and module declarations" UselessAbstract _ -> fsep $ pwords "Using abstract here has no effect. Abstract applies to only definitions like data definitions, record type definitions and function clauses." + UselessImport _ -> fsep $+ pwords "An import statement with module instantiation is useless without either an `open' keyword or an `as` binding giving a name to the instantiated module."+ UselessInstance _ -> fsep $- pwords "Using instance here has no effect. Instance applies only to declarations that introduce new identifiers into the module, like type signatures and axioms."+ pwords "Using instance here has no effect. Instance applies only to (function) definitions, constructor declarations and axioms (other than primitives)." UselessMacro _ -> fsep $ pwords "Using a macro block here has no effect. `macro' applies only to function definitions."@@ -499,8 +562,29 @@ EmptyPolarityPragma _ -> fsep $ pwords "POLARITY pragma without polarities (ignored)." + FixityDeclarationForNonOperator _r x -> fsep $+ pwords "Deprecated: fixity declaration for" ++ [d, pretty x]+ where+ -- Precondition: x is not an in-, pre- or post-fix operator.+ d | any isHole (nameParts x) = "closed operator"+ | otherwise = "non-operator"+ HiddenGeneralize _ -> fsep $ pwords "Declaring a variable as hidden has no effect in a variable block. Generalization never introduces visible arguments." + InvalidDataOrRecDefParameter _ dataOrRec what explanation -> fsep $ concat+ [ [ "Ignoring" ]+ , twords what+ , pwords "in"+ , [ ifThenElse dataOrRec "data" "record", "definition" ]+ , twords explanation+ ]++ InvalidTacticAttribute _ -> fsep $+ pwords "Ignoring misplaced tactic attribute."++ InvalidRewriteAttribute _ -> fsep $+ pwords "Ignoring misplaced local rewrite attribute."+ InvalidTerminationCheckPragma _ -> fsep $ pwords "Termination checking pragmas can only precede a function definition or a mutual block (that contains a function definition)." @@ -516,6 +600,9 @@ InvalidCatchallPragma _ -> fsep $ pwords "The CATCHALL pragma can only precede a function clause." + InvalidEtaEqualityPragma _ -> fsep $+ pwords "The ETA_EQUALITY pragma can only precede a record definition."+ InvalidNoUniverseCheckPragma _ -> fsep $ pwords "NO_UNIVERSE_CHECKING pragmas can only precede a data/record definition." @@ -537,11 +624,11 @@ , pwords "so better place this statement outside of the private block" ] - ShadowingInTelescope nrs -> fsep $- pwords "Shadowing in telescope, repeated variable names:"- ++ punctuate comma (fmap (pretty . fst) nrs)+ ShadowingInTelescope nrs ->+ fwords "Shadowing in telescope, repeated variable names:"+ <?>+ fsep (fmap (pretty . fst) nrs) - SafeFlagEta _ -> unsafePragma "ETA" SafeFlagInjective _ -> unsafePragma "INJECTIVE" SafeFlagNoCoverageCheck _ -> unsafePragma "NON_COVERING" SafeFlagNoPositivityCheck _ -> unsafePragma "NO_POSITIVITY_CHECK"
src/full/Agda/Syntax/Concrete/Definitions/Monad.hs view
@@ -1,17 +1,20 @@ {-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-} module Agda.Syntax.Concrete.Definitions.Monad where import Prelude hiding ( null ) -import Control.Monad ()+import Control.Monad ( ) import Control.Monad.Except ( MonadError(..), ExceptT, runExceptT ) import Control.Monad.Reader ( MonadReader, ReaderT, runReaderT )-import Control.Monad.State ( MonadState(..), modify, State, runState )+import Control.Monad.State ( MonadState(..), modify, State, StateT, runState ) import Data.Bifunctor (second) import Data.Map (Map) import qualified Data.Map as Map+import Data.Maybe (catMaybes) import Agda.Syntax.Position import Agda.Syntax.Common hiding (TerminationCheck())@@ -35,6 +38,9 @@ , MonadReader NiceEnv, MonadState NiceState, MonadError DeclarationException ) +-- | Extension of the nicifier monad with state to process interleaved mutual blocks.+type INice = StateT InterleavedState Nice+ -- | Run a Nicifier computation, return result and warnings -- (in chronological order). runNice :: NiceEnv -> Nice a -> (Either DeclarationException a, NiceWarnings)@@ -65,6 +71,8 @@ -- ^ Positivity checking pragma waiting for a definition. , _uniChk :: UniverseCheck -- ^ Universe checking pragma waiting for a data/rec signature or definition.+ , _forceEta :: ForceRecordEta+ -- ^ @ETA_EQUALITY@ pragma waiting for a record signature or definition. , _catchall :: Catchall -- ^ Catchall pragma waiting for a function clause. , _covChk :: CoverageCheck@@ -107,6 +115,7 @@ , _termChk = TerminationCheck , _posChk = YesPositivityCheck , _uniChk = YesUniverseCheck+ , _forceEta = empty , _catchall = empty , _covChk = YesCoverageCheck , niceWarn = []@@ -142,8 +151,8 @@ let (mr, s') = Map.insertLookupWithKey (\ _k new _old -> new) x (LoneSig r x' k) s case mr of Nothing -> return s'- Just{} -> declarationException $- if not $ isNoName x then DuplicateDefinition x else DuplicateAnonDeclaration r+ Just y -> declarationException $+ if not $ isNoName x then DuplicateDefinition x (loneSigRange y) else DuplicateAnonDeclaration r (loneSigRange y) return x' -- | Remove a lone signature from the state.@@ -184,8 +193,11 @@ -- | Get names of lone function signatures, plus their unique names. -loneFuns :: LoneSigs -> [(Name,Name)]-loneFuns = map (second loneSigName) . filter (isFunName . loneSigKind . snd) . Map.toList+loneFuns :: LoneSigs -> [(Name, Arg Name)]+loneFuns ls = catMaybes $+ Map.toList ls <&> \case+ (x, LoneSig _ x' (FunName ai _ _)) -> Just (x, Arg ai x')+ _ -> Nothing -- | Create a 'LoneSigs' map from an association list. @@ -197,56 +209,48 @@ terminationCheckPragma :: Lens' NiceState TerminationCheck terminationCheckPragma f e = f (_termChk e) <&> \ s -> e { _termChk = s } +-- | Set 'terminationCheckPragma' to given value for a local computation.+ withTerminationCheckPragma :: TerminationCheck -> Nice a -> Nice a-withTerminationCheckPragma tc f = do- tc_old <- use terminationCheckPragma- terminationCheckPragma .= tc- result <- f- terminationCheckPragma .= tc_old- return result+withTerminationCheckPragma = locallyState terminationCheckPragma . const +-- | Lens for field '_covChk'.+ coverageCheckPragma :: Lens' NiceState CoverageCheck coverageCheckPragma f e = f (_covChk e) <&> \ s -> e { _covChk = s } +-- | Set 'coverageCheckPragma' to given value for a local computation.+ withCoverageCheckPragma :: CoverageCheck -> Nice a -> Nice a-withCoverageCheckPragma tc f = do- tc_old <- use coverageCheckPragma- coverageCheckPragma .= tc- result <- f- coverageCheckPragma .= tc_old- return result+withCoverageCheckPragma = locallyState coverageCheckPragma . const +-- | Lens for field '_forceEta'.++etaEqualityPragma :: Lens' NiceState ForceRecordEta+etaEqualityPragma f e = f (_forceEta e) <&> \ s -> e { _forceEta = s }++withEtaEqualityPragma :: ForceRecordEta -> Nice a -> Nice a+withEtaEqualityPragma = locallyState etaEqualityPragma . const+ -- | Lens for field '_posChk'. positivityCheckPragma :: Lens' NiceState PositivityCheck positivityCheckPragma f e = f (_posChk e) <&> \ s -> e { _posChk = s } +-- | Set 'positivityCheckPragma' to given value for a local computation.+ withPositivityCheckPragma :: PositivityCheck -> Nice a -> Nice a-withPositivityCheckPragma pc f = do- pc_old <- use positivityCheckPragma- positivityCheckPragma .= pc- result <- f- positivityCheckPragma .= pc_old- return result+withPositivityCheckPragma = locallyState positivityCheckPragma . const -- | Lens for field '_uniChk'. universeCheckPragma :: Lens' NiceState UniverseCheck universeCheckPragma f e = f (_uniChk e) <&> \ s -> e { _uniChk = s } -withUniverseCheckPragma :: UniverseCheck -> Nice a -> Nice a-withUniverseCheckPragma uc f = do- uc_old <- use universeCheckPragma- universeCheckPragma .= uc- result <- f- universeCheckPragma .= uc_old- return result---- | Get universe check pragma from a data/rec signature.--- Defaults to 'YesUniverseCheck'.+-- | Set 'universeCheckPragma' to given value for a local computation. -getUniverseCheckFromSig :: Name -> Nice UniverseCheck-getUniverseCheckFromSig x = maybe YesUniverseCheck universeCheck <$> getSig x+withUniverseCheckPragma :: UniverseCheck -> Nice a -> Nice a+withUniverseCheckPragma = locallyState universeCheckPragma . const -- | Lens for field '_catchall'. @@ -261,13 +265,10 @@ catchallPragma .= empty return ca +-- | Set 'catchallPragma' to given value for a local computation.+ withCatchallPragma :: Catchall -> Nice a -> Nice a-withCatchallPragma ca f = do- ca_old <- use catchallPragma- catchallPragma .= ca- result <- f- catchallPragma .= ca_old- return result+withCatchallPragma = locallyState catchallPragma . const -- | Add a new warning. niceWarning :: DeclarationWarning -> Nice ()
src/full/Agda/Syntax/Concrete/Definitions/Types.hs view
@@ -1,23 +1,24 @@+{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-}+ module Agda.Syntax.Concrete.Definitions.Types where import Control.DeepSeq import Data.Map (Map)-import Data.Semigroup ( Semigroup(..) ) import GHC.Generics (Generic) import Agda.Syntax.Position import Agda.Syntax.Common hiding (TerminationCheck()) import qualified Agda.Syntax.Common as Common+import Agda.Syntax.Common.Pretty import Agda.Syntax.Concrete import Agda.Syntax.Concrete.Name () import Agda.Syntax.Concrete.Pretty () -import Agda.Syntax.Common.Pretty-import Agda.Utils.Impossible import Agda.Utils.List1 (List1)-import qualified Agda.Utils.List1 as List1 {-------------------------------------------------------------------------- Types@@ -52,32 +53,32 @@ -- ('Hiding' should be 'NotHidden'.) | NiceField Range Access IsAbstract IsInstance TacticAttribute Name (Arg Expr) | PrimitiveFunction Range Access IsAbstract Name (Arg Expr)- | NiceMutual KwRange TerminationCheck CoverageCheck PositivityCheck [NiceDeclaration]+ | NiceMutual KwRange TerminationCheck CoverageCheck PositivityCheck (List1 NiceDeclaration) | NiceModule Range Access IsAbstract Erased QName Telescope [Declaration] | NiceModuleMacro Range Access Erased Name ModuleApplication OpenShortHand ImportDirective- | NiceOpen Range QName ImportDirective- | NiceImport Range QName (Maybe AsName) OpenShortHand ImportDirective+ | NiceOpen KwRange QName ImportDirective+ | NiceImport OpenShortHand KwRange QName (Either AsName RawOpenArgs) ImportDirective | NicePragma Range Pragma | NiceRecSig Range Erased Access IsAbstract PositivityCheck- UniverseCheck Name [LamBinding] Expr+ UniverseCheck ForceRecordEta Name Parameters Expr | NiceDataSig Range Erased Access IsAbstract PositivityCheck- UniverseCheck Name [LamBinding] Expr+ UniverseCheck Name Parameters Expr | NiceFunClause Range Access IsAbstract TerminationCheck CoverageCheck Catchall Declaration -- ^ An uncategorized function clause, could be a function clause -- without type signature or a pattern lhs (e.g. for irrefutable let). -- The 'Declaration' is the actual 'FunClause'. | FunSig Range Access IsAbstract IsInstance IsMacro ArgInfo TerminationCheck CoverageCheck Name Expr- | FunDef Range [Declaration] IsAbstract IsInstance TerminationCheck CoverageCheck Name [Clause]+ | FunDef Range (List1 Declaration) IsAbstract IsInstance TerminationCheck CoverageCheck Name (List1 Clause) -- ^ Block of function clauses (we have seen the type signature before). -- The 'Declaration's are the original declarations that were processed -- into this 'FunDef' and are only used in 'notSoNiceDeclaration'. -- Andreas, 2017-01-01: Because of issue #2372, we add 'IsInstance' here. -- An alias should know that it is an instance.- | NiceDataDef Range Origin IsAbstract PositivityCheck UniverseCheck Name [LamBinding] [NiceConstructor]+ | NiceDataDef Range Origin IsAbstract PositivityCheck UniverseCheck Name DefParameters [NiceConstructor] | NiceLoneConstructor KwRange [NiceConstructor]- | NiceRecDef Range Origin IsAbstract PositivityCheck UniverseCheck Name [RecordDirective] [LamBinding] [Declaration]+ | NiceRecDef Range Origin IsAbstract PositivityCheck UniverseCheck ForceRecordEta Name [RecordDirective] DefParameters [Declaration] -- ^ @(Maybe Range)@ gives range of the 'pattern' declaration. | NicePatternSyn Range Access Name [WithHiding Name] Pattern | NiceGeneralize Range Access ArgInfo TacticAttribute Name Expr@@ -102,11 +103,15 @@ -- | 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]+data Clause = Clause Name Catchall ArgInfo LHS RHS WhereClause [Clause] deriving (Show, Generic) instance NFData Clause +instance LensArgInfo Clause where+ getArgInfo (Clause _ _ ai _ _ _ _) = ai+ mapArgInfo f (Clause x ca ai lhs rhs wh cs) = Clause x ca (f ai) lhs rhs wh cs+ -- | When processing a mutual block we collect the various checks present in the block -- before combining them. @@ -151,7 +156,7 @@ -- ^ Internal number of the data signature. , interleavedDeclSig :: NiceDeclaration -- ^ The data signature.- , interleavedDataCons :: Maybe (DeclNum, List1 [NiceConstructor])+ , interleavedDataCons :: Maybe (DeclNum, List1 (DefParameters, [NiceConstructor])) -- ^ Constructors associated to the data signature. } | InterleavedFun@@ -159,13 +164,25 @@ -- ^ Internal number of the function signature. , interleavedDeclSig :: NiceDeclaration -- ^ The function signature.- , interleavedFunClauses :: Maybe (DeclNum, List1 ([Declaration],[Clause]))+ , interleavedFunClauses :: Maybe (DeclNum, List1 (List1 Declaration, List1 Clause)) -- ^ Function clauses associated to the function signature. } +-- | Extra state for the 'Nice' monad to process interleaved mutual blocks.+data InterleavedState = ISt+ { interleavedMutual :: InterleavedMutual+ , interleavedMutualChecks :: MutualChecks+ , interleavedCurrentDeclNum :: DeclNum+ }+ -- | Numbering declarations in an @interleaved mutual@ block. type DeclNum = Int +instance HasRange InterleavedDecl where+ getRange :: InterleavedDecl -> Range+ getRange (InterleavedFun _ d _) = getRange d+ getRange (InterleavedData _ d _) = getRange d+ isInterleavedFun :: InterleavedDecl -> Maybe () isInterleavedFun InterleavedFun{} = Just () isInterleavedFun _ = Nothing@@ -174,27 +191,12 @@ isInterleavedData InterleavedData{} = Just () isInterleavedData _ = Nothing -interleavedDecl :: Name -> InterleavedDecl -> [(DeclNum, NiceDeclaration)]-interleavedDecl k = \case- InterleavedData i d@(NiceDataSig _ _ acc abs pc uc _ pars _) ds ->- 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- FunDef r (sconcat dss) abs inst tc cc n (sconcat css)- in (i,d) : maybe [] (\ (j, dcss) -> [(j, fdef (List1.reverse dcss))]) dcs- _ -> __IMPOSSIBLE__ -- someone messed up and broke the invariant- -- | Several declarations expect only type signatures as sub-declarations. These are: data KindOfBlock- = PostulateBlock -- ^ @postulate@- | PrimitiveBlock -- ^ @primitive@. Ensured by parser.- | InstanceBlock -- ^ @instance@. Actually, here all kinds of sub-declarations are allowed a priori.- | FieldBlock -- ^ @field@. Ensured by parser.- | DataBlock -- ^ @data ... where@. Here we got a bad error message for Agda-2.5 (Issue 1698).+ = PostulateBlock -- ^ @postulate@.+ | PrimitiveBlock -- ^ @primitive@.+ | 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 (Eq, Ord, Show, Generic) @@ -206,16 +208,16 @@ getRange (NiceMutual kwr _ _ _ ds) = fuseRange kwr ds getRange (NiceModule r _ _ _ _ _ _ ) = r getRange (NiceModuleMacro r _ _ _ _ _ _) = r- getRange (NiceOpen r _ _) = r- getRange (NiceImport r _ _ _ _) = r+ getRange (NiceOpen kwr x dir) = getRange (kwr, x, dir)+ getRange (NiceImport o r x as dir) = getRange (o, r, x, as, dir) getRange (NicePragma r _) = r getRange (PrimitiveFunction r _ _ _ _) = r getRange (FunSig r _ _ _ _ _ _ _ _ _) = r getRange (FunDef r _ _ _ _ _ _ _) = r getRange (NiceDataDef r _ _ _ _ _ _ _) = r getRange (NiceLoneConstructor kwr ds) = fuseRange kwr ds- getRange (NiceRecDef r _ _ _ _ _ _ _ _) = r- getRange (NiceRecSig r _ _ _ _ _ _ _ _) = r+ getRange (NiceRecDef r _ _ _ _ _ _ _ _ _)= r+ getRange (NiceRecSig r _ _ _ _ _ _ _ _ _)= r getRange (NiceDataSig r _ _ _ _ _ _ _ _) = r getRange (NicePatternSyn r _ _ _ _) = r getRange (NiceGeneralize r _ _ _ _ _) = r@@ -237,19 +239,19 @@ NiceOpen _ x _ -> text "open" <+> pretty x NiceImport _ x _ _ _ -> text "import" <+> pretty x NicePragma{} -> text "{-# ... #-}"- NiceRecSig _ _ _ _ _ _ x _ _ -> text "record" <+> pretty x+ NiceRecSig _ _ _ _ _ _ _ x _ _ -> text "record" <+> pretty x NiceDataSig _ _ _ _ _ _ x _ _ -> text "data" <+> pretty x NiceFunClause{} -> text "<function clause>" FunSig _ _ _ _ _ _ _ _ x _ -> pretty x <+> colon <+> text "_" FunDef _ _ _ _ _ _ x _ -> pretty x <+> text "= _" NiceDataDef _ _ _ _ _ x _ _ -> text "data" <+> pretty x <+> text "where" NiceLoneConstructor _ _ -> text "data _ where"- NiceRecDef _ _ _ _ _ x _ _ _ -> text "record" <+> pretty x <+> text "where"+ NiceRecDef _ _ _ _ _ _ x _ _ _ -> text "record" <+> pretty x <+> text "where" NicePatternSyn _ _ x _ _ -> text "pattern" <+> pretty x NiceGeneralize _ _ _ _ x _ -> text "variable" <+> pretty x- NiceUnquoteDecl _ _ _ _ _ _ xs _ -> text "<unquote declarations>"- NiceUnquoteDef _ _ _ _ _ xs _ -> text "<unquote definitions>"- NiceUnquoteData _ _ _ _ _ x xs _ -> text "<unquote data types>"+ NiceUnquoteDecl _ _ _ _ _ _ _xs _ -> text "<unquote declarations>"+ NiceUnquoteDef _ _ _ _ _ _xs _ -> text "<unquote definitions>"+ NiceUnquoteData _ _ _ _ _ _x _xs _ -> text "<unquote data types>" declName :: NiceDeclaration -> String declName Axiom{} = "Postulates"@@ -293,9 +295,10 @@ | RecName { _kindPosCheck :: PositivityCheck , _kindUniCheck :: UniverseCheck+ , _kindForceEta :: ForceRecordEta } -- ^ Name of a record type- | FunName TerminationCheck CoverageCheck+ | FunName ArgInfo TerminationCheck CoverageCheck -- ^ Name of a function. deriving (Show, Generic) @@ -303,11 +306,24 @@ -- Ignore pragmas when checking equality instance Eq DataRecOrFun where- DataName{} == DataName{} = True- RecName{} == RecName{} = True- FunName{} == FunName{} = True- _ == _ = False+ (==) = sameKind +sameKind :: DataRecOrFun -> DataRecOrFun -> Bool+sameKind = curry \case+ (DataName{} , DataName{}) -> True+ (RecName{} , RecName{} ) -> True+ (FunName{} , FunName{} ) -> True+ _ -> False++-- | Monoidal for 'DataName' and 'RecName'.+-- Returns just first 'FunName' discarding the second one.+mergeDataRecOrFun :: DataRecOrFun -> DataRecOrFun -> Maybe DataRecOrFun+mergeDataRecOrFun = curry \case+ (DataName pc uc , DataName pc' uc') -> Just $ DataName (pc <> pc') (uc <> uc')+ (RecName pc uc eta, RecName pc' uc' eta') -> Just $ RecName (pc <> pc') (uc <> uc') (eta <> eta')+ (f@FunName{} , FunName{} ) -> Just f+ _ -> Nothing+ instance Pretty DataRecOrFun where pretty DataName{} = "data type" pretty RecName{} = "record type"@@ -317,26 +333,28 @@ isFunName (FunName{}) = True isFunName _ = False -sameKind :: DataRecOrFun -> DataRecOrFun -> Bool-sameKind = (==)- terminationCheck :: DataRecOrFun -> TerminationCheck-terminationCheck (FunName tc _) = tc+terminationCheck (FunName _ tc _) = tc terminationCheck _ = TerminationCheck coverageCheck :: DataRecOrFun -> CoverageCheck-coverageCheck (FunName _ cc) = cc+coverageCheck (FunName _ _ cc) = cc coverageCheck _ = YesCoverageCheck positivityCheck :: DataRecOrFun -> PositivityCheck positivityCheck (DataName pc _) = pc-positivityCheck (RecName pc _) = pc-positivityCheck (FunName _ _) = YesPositivityCheck+positivityCheck (RecName pc _ _)= pc+positivityCheck (FunName _ _ _) = YesPositivityCheck mutualChecks :: DataRecOrFun -> MutualChecks mutualChecks k = MutualChecks [terminationCheck k] [coverageCheck k] [positivityCheck k] universeCheck :: DataRecOrFun -> UniverseCheck universeCheck (DataName _ uc) = uc-universeCheck (RecName _ uc) = uc-universeCheck (FunName _ _) = YesUniverseCheck+universeCheck (RecName _ uc _)= uc+universeCheck (FunName _ _ _) = YesUniverseCheck++forceRecordEta :: DataRecOrFun -> ForceRecordEta+forceRecordEta (DataName _ _) = mempty+forceRecordEta (RecName _ _ eta) = eta+forceRecordEta (FunName _ _ _) = mempty
src/full/Agda/Syntax/Concrete/Fixity.hs view
@@ -1,4 +1,6 @@ {-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-} -- | Collecting fixity declarations (and polarity pragmas) for concrete -- declarations.@@ -22,6 +24,7 @@ import Agda.Syntax.Common import Agda.Syntax.Concrete import Agda.Syntax.Position+import Agda.Syntax.Notation (isPrePostOrInfixNotation) import Agda.TypeChecking.Positivity.Occurrence (PragmaPolarities) import Agda.Utils.CallStack (HasCallStack)@@ -46,6 +49,7 @@ warnUnknownFixityInMixfixDecl :: HasCallStack => Set1 Name -> m () warnPolarityPragmasButNotPostulates :: HasCallStack => Set1 Name -> m () warnEmptyPolarityPragma :: HasCallStack => Range -> m ()+ warnFixityDeclarationForNonOperator :: HasCallStack => Range -> Name -> m () -- | Add more fixities. Throw an exception for multiple fixity declarations. -- OR: Disjoint union of fixity maps. Throws exception if not disjoint.@@ -58,13 +62,21 @@ | otherwise = return $ Map.unionWithKey mergeFixites m1 m2 where -- Merge two fixities, assuming there is no conflict- mergeFixites name (Fixity' f1 s1 r1) (Fixity' f2 s2 r2) = Fixity' f s $ fuseRange r1 r2- where f | null f1 = f2- | null f2 = f1- | otherwise = __IMPOSSIBLE__- s | null s1 = s2- | null s2 = s1- | otherwise = __IMPOSSIBLE__+ mergeFixites _name (Fixity' f1 s1 r1) (Fixity' f2 s2 r2) = Fixity' f s r+ where+ (f, rf)+ | null f1 = (f2, r2)+ | null f2 = (f1, r1)+ | otherwise = __IMPOSSIBLE__+ (s, rs)+ | null s1 = (s2, r2)+ | null s2 = (s1, r1)+ | otherwise = __IMPOSSIBLE__+ -- Andreas, 2026-09-07, issue #1438+ -- If we have both a fixity and a syntax declaration,+ -- take the range of the fixity declaration.+ r | null rf = rs+ | otherwise = rf -- Compute a list of conflicts in a format suitable for error reporting. isect = [ (x, fmap (Map.findWithDefault __IMPOSSIBLE__ x) $ Pair m1 m2)@@ -135,9 +147,26 @@ -- return $ Map.restrictKeys polarities declared return $ Map.filterWithKey (\ k _ -> Set.member k declared) pols + -- Andreas, 2026-09-07, issue #1438+ -- Fixity does not make sense for names that are not operators+ -- or do not have any @syntax@ declaration attached to it,+ -- so we discard respective declarations with a warning.+ _useless <- forM (Map.toList fixs) \ (x, Fixity' fx nota r) ->+ -- Nothing to do if there is no fixity declaration or it belongs+ -- to a pre-, post-, or infix operator/syntax.+ if null fx || isPrePostOrInfixOperator x || isPrePostOrInfixNotation nota then pure Nothing+ else do+ when (doWarn == DoWarn) $ warnFixityDeclarationForNonOperator r x+ -- Discard useless fixity declarations that have no syntax notation.+ pure $ if null nota then Just x else Nothing+ -- Andreas, do not remove fixity declarations (yet) since Agda.Primitive.Cubical+ -- abuses the feature, e.g. @infix 20 primINeg@ (as of 2026-09-07).+ -- TODO: do remove them in the future (past 2.9.0). See also 'applyImportDirectiveM'.+ -- fixs <- return $ Map.withoutKeys fixs $ Set.fromList $ catMaybes useless+ -- If we have public mixfix identifiers without a corresponding fixity -- declaration, we raise a warning- Set1.unlessNull (Set.filter isOpenMixfix publicNames Set.\\ Map.keysSet fixs) $+ Set1.unlessNull (Set.filter isPrePostOrInfixOperator publicNames Set.\\ Map.keysSet fixs) $ when (doWarn == DoWarn) . warnUnknownFixityInMixfixDecl -- Check that every polarity pragma is used for a postulate.@@ -154,7 +183,10 @@ returnPol $ Map.singleton x occs -- These declarations define fixities: Syntax x syn -> returnFix $ Map.singleton x (Fixity' noFixity syn $ getRange x)- Infix f xs -> returnFix $ Map.fromList $ for (List1.toList xs) $ \ x -> (x, Fixity' f noNotation $ getRange x)+ Infix f xs1 -> flip foldMap xs1 \ x ->+ -- Andreas, 2025-07-25, issue #5224: Warn when @xs1@ contains duplicates.+ -- We achieve this through 'plusFixities'.+ returnFix $ Map.singleton x $ Fixity' f noNotation $ getRange x -- We look into these blocks: Mutual _ ds' -> fixitiesAndPolarities' ds' InterleavedMutual _ ds' -> fixitiesAndPolarities' ds'@@ -191,7 +223,13 @@ Pragma {} -> mempty Unfolding {} -> mempty -data DeclaredNames = DeclaredNames { _allNames, _postulates, _privateNames :: Set Name }+data DeclaredNames = DeclaredNames+ { _allNames :: Set Name+ , _postulates :: Set Name+ -- ^ Subset of postulates within '_allNames'.+ , _privateNames :: Set Name+ -- ^ Subset of private names within '_allNames'.+ } instance Semigroup DeclaredNames where DeclaredNames xs ps as <> DeclaredNames ys qs bs =@@ -201,11 +239,15 @@ mempty = DeclaredNames Set.empty Set.empty Set.empty mappend = (<>) +-- | Mark all declared names as postulates. allPostulates :: DeclaredNames -> DeclaredNames-allPostulates (DeclaredNames xs ps as) = DeclaredNames xs (xs <> ps) as+allPostulates (DeclaredNames xs _ps as) = DeclaredNames xs xs as+ -- Note that @_ps@ is a subset of @xs@ so we can discard it. +-- | Mark all declared names as private. allPrivateNames :: DeclaredNames -> DeclaredNames-allPrivateNames (DeclaredNames xs ps as) = DeclaredNames xs ps (xs <> as)+allPrivateNames (DeclaredNames xs ps _as) = DeclaredNames xs ps xs+ -- Note that @_as@ is a subset of @xs@ so we can discard it. declaresNames :: [Name] -> DeclaredNames declaresNames xs = DeclaredNames (Set.fromList xs) Set.empty Set.empty@@ -220,7 +262,7 @@ TypeSig _ _ x _ -> declaresName x FieldSig _ _ x _ -> declaresName x Field _ fs -> foldMap declaredNames fs- FunClause (LHS p [] []) _ _ _+ FunClause _ (LHS p [] []) _ _ _ | IdentP _ (QName x) <- removeParenP p -> declaresName x FunClause{} -> mempty@@ -228,7 +270,7 @@ DataDef _ _ _ cs -> foldMap declaredNames cs Data _ _ x _ _ cs -> declaresName x <> foldMap declaredNames cs RecordSig _ _ x _ _ -> declaresName x- RecordDef _ x ds _ _ -> declaresNames $ maybeToList (recDirConstructor ds)+ RecordDef _ _x ds _ _ -> declaresNames $ maybeToList (recDirConstructor ds) Record _ _ x ds _ _ _ -> declaresNames $ x : maybeToList (recDirConstructor ds) Infix _ _ -> mempty Syntax _ _ -> mempty
src/full/Agda/Syntax/Concrete/Generic.hs view
@@ -1,4 +1,6 @@ {-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-} -- | Generic traversal and reduce for concrete syntax, -- in the style of "Agda.Syntax.Internal.Generic".@@ -128,15 +130,15 @@ InstanceArg r e -> f $ InstanceArg r $ mapE e Lam r bs e -> f $ Lam r (mapE bs) $ mapE e AbsurdLam{} -> f $ e0- ExtendedLam r e cs -> f $ ExtendedLam r e $ mapE cs- Fun r a b -> f $ Fun r (mapE <$> a) $ mapE b- Pi tel e -> f $ Pi (mapE tel) $ mapE e- Rec kwr r es -> f $ Rec kwr r $ mapE es- RecUpdate kwr r e es -> f $ RecUpdate kwr r (mapE e) $ mapE es- Let r ds e -> f $ Let r (mapE ds) $ mapE e- Paren r e -> f $ Paren r $ mapE e- IdiomBrackets r es -> f $ IdiomBrackets r $ mapE es- DoBlock r ss -> f $ DoBlock r $ mapE ss+ ExtendedLam r e cs -> f $ ExtendedLam r e $ mapE cs+ Fun r a b -> f $ Fun r (mapE <$> a) $ mapE b+ Pi tel e -> f $ Pi (mapE tel) $ mapE e+ Rec kwr r es -> f $ Rec kwr r $ mapE es+ RecUpdate k r e es -> f $ RecUpdate k r (mapE e) $ mapE es+ Let r ds e -> f $ Let r (mapE ds) $ mapE e+ Paren r e -> f $ Paren r $ mapE e+ IdiomBrackets r q es -> f $ IdiomBrackets r q $ mapE es+ DoBlock r q ss -> f $ DoBlock r q $ mapE ss Absurd{} -> f $ e0 As r x e -> f $ As r x $ mapE e Dot r e -> f $ Dot r $ mapE e@@ -151,6 +153,7 @@ Generalized e -> f $ Generalized $ mapE e KnownIdent{} -> f $ e0 KnownOpApp nk r q ns es -> f $ KnownOpApp nk r q ns $ mapE es+ Highlighted r e -> f $ Highlighted r $ mapE e where mapE :: ExprLike e => e -> e mapE = mapExpr f@@ -166,7 +169,7 @@ instance ExprLike ModuleAssignment where mapExpr f (ModuleAssignment m es i) = ModuleAssignment m (mapExpr f es) i traverseExpr f (ModuleAssignment m es i) = (\es' -> ModuleAssignment m es' i) <$> traverseExpr f es- foldExpr f (ModuleAssignment m es i) = foldExpr f es+ foldExpr f (ModuleAssignment _ es _) = foldExpr f es instance ExprLike a => ExprLike (OpApp a) where mapExpr f = \case@@ -231,7 +234,7 @@ TypeSig ai t x e -> TypeSig ai (mapE t) x (mapE e) FieldSig i t n e -> FieldSig i (mapE t) n (mapE e) Field r fs -> Field r $ map (mapExpr f) fs- FunClause lhs rhs wh ca -> FunClause (mapE lhs) (mapE rhs) (mapE wh) ca+ FunClause ai lhs rhs wh ca-> FunClause ai (mapE lhs) (mapE rhs) (mapE wh) ca DataSig r er x bs e -> DataSig r er x (mapE bs) $ mapE e DataDef r n bs cs -> DataDef r n (mapE bs) $ mapE cs Data r er n bs e cs -> Data r er n (mapE bs) (mapE e) $ mapE cs@@ -300,6 +303,10 @@ instance FoldDecl a => FoldDecl (List2 a) instance FoldDecl a => FoldDecl (WhereClause' a) +-- | Note: this instance discards top-level OPTIONS pragmas.+instance FoldDecl Module where+ foldDecl f (Mod _name _pragmas ds) = foldDecl f ds+ instance FoldDecl Declaration where foldDecl f d = f d <> case d of Private _ _ ds -> foldDecl f ds@@ -316,7 +323,7 @@ FieldSig _ _ _ _ -> mempty Generalize _ _ -> mempty Field _ _ -> mempty- FunClause _ _ wh _ -> foldDecl f wh+ FunClause _ _ _ wh _ -> foldDecl f wh DataSig _ _ _ _ _ -> mempty Data _ _ _ _ _ _ -> mempty DataDef _ _ _ _ -> mempty@@ -371,7 +378,7 @@ FieldSig _ _ _ _ -> return d Generalize _ _ -> return d Field _ _ -> return d- FunClause lhs rhs wh ca -> preTraverseDecl f wh <&> \ wh' -> FunClause lhs rhs wh' ca+ FunClause ai lhs rhs wh ca -> preTraverseDecl f wh <&> \ wh' -> FunClause ai lhs rhs wh' ca DataSig _ _ _ _ _ -> return d Data _ _ _ _ _ _ -> return d DataDef _ _ _ _ -> return d
src/full/Agda/Syntax/Concrete/Glyph.hs view
@@ -1,4 +1,6 @@ {-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-} {-| Choice of Unicode or ASCII glyphs. -}@@ -9,19 +11,20 @@ , braces', dbraces , forallQ , leftIdiomBrkt, rightIdiomBrkt, emptyIdiomBrkt- , arrow, lambda+ , arrow, lambda, fromArrow+ , treeGlyphs , SpecialCharacters(..) ) where import Control.DeepSeq -import Data.IORef (IORef, newIORef, readIORef, writeIORef) import qualified System.IO.Unsafe as UNSAFE (unsafePerformIO) import GHC.Generics (Generic) import Agda.Utils.Boolean import Agda.Utils.List+import qualified Agda.Utils.IORef.Strict as Strict import Agda.Utils.Null import Agda.Syntax.Common.Pretty @@ -44,29 +47,33 @@ AsciiOnly -> False {-# NOINLINE unsafeUnicodeOrAsciiIORef #-}-unsafeUnicodeOrAsciiIORef :: IORef UnicodeOrAscii-unsafeUnicodeOrAsciiIORef = UNSAFE.unsafePerformIO $ newIORef UnicodeOk+unsafeUnicodeOrAsciiIORef :: Strict.IORef UnicodeOrAscii+unsafeUnicodeOrAsciiIORef = UNSAFE.unsafePerformIO $ Strict.newIORef UnicodeOk {-# NOINLINE unsafeSetUnicodeOrAscii #-} unsafeSetUnicodeOrAscii :: UnicodeOrAscii -> IO ()-unsafeSetUnicodeOrAscii = writeIORef unsafeUnicodeOrAsciiIORef+unsafeSetUnicodeOrAscii = Strict.writeIORef unsafeUnicodeOrAsciiIORef -- | Are we allowed to use unicode supscript characters? unsafeUnicodeOrAscii :: UnicodeOrAscii-unsafeUnicodeOrAscii = UNSAFE.unsafePerformIO (readIORef unsafeUnicodeOrAsciiIORef)+unsafeUnicodeOrAscii = UNSAFE.unsafePerformIO (Strict.readIORef unsafeUnicodeOrAsciiIORef) -- | Picking the appropriate set of special characters depending on -- whether we are allowed to use unicode or have to limit ourselves -- to ascii. data SpecialCharacters = SpecialCharacters- { _dbraces :: Doc -> Doc- , _lambda :: Doc- , _arrow :: Doc- , _forallQ :: Doc+ { _dbraces :: Doc -> Doc+ , _lambda :: Doc+ , _arrow :: Doc+ , _forallQ :: Doc , _leftIdiomBrkt :: Doc , _rightIdiomBrkt :: Doc , _emptyIdiomBrkt :: Doc+ , _fromArrow :: Doc+ , _treeBranch :: Doc -- ^ Connector to a child that has siblings below.+ , _treeLastBranch :: Doc -- ^ Connector to the last child.+ , _treeContinue :: Doc -- ^ Indentation under a child that has siblings below. } specialCharactersUnicode :: SpecialCharacters@@ -78,6 +85,10 @@ , _leftIdiomBrkt = hlSymbol "\x2987" , _rightIdiomBrkt = hlSymbol "\x2988" , _emptyIdiomBrkt = hlSymbol "\x2987\x2988"+ , _fromArrow = hlSymbol "←"+ , _treeBranch = "├─ "+ , _treeLastBranch = "└─ "+ , _treeContinue = "│ " } specialCharactersAscii :: SpecialCharacters@@ -89,6 +100,10 @@ , _leftIdiomBrkt = hlSymbol "(|" , _rightIdiomBrkt = hlSymbol "|)" , _emptyIdiomBrkt = hlSymbol "(|)"+ , _fromArrow = hlSymbol "<-"+ , _treeBranch = "|- "+ , _treeLastBranch = "`- "+ , _treeContinue = "| " } -- | Return the glyph set based on a given (unicode or ascii) glyph mode@@ -124,6 +139,16 @@ rightIdiomBrkt = _rightIdiomBrkt specialCharacters emptyIdiomBrkt = _emptyIdiomBrkt specialCharacters -arrow, lambda :: Doc-arrow = _arrow specialCharacters-lambda = _lambda specialCharacters+arrow, lambda, fromArrow :: Doc+arrow = _arrow specialCharacters+lambda = _lambda specialCharacters+fromArrow = _fromArrow specialCharacters++-- | Glyphs for drawing trees with 'prettyTree'.+treeGlyphs :: TreeGlyphs+treeGlyphs = TreeGlyphs+ { treeBranch = _treeBranch specialCharacters+ , treeLastBranch = _treeLastBranch specialCharacters+ , treeContinue = _treeContinue specialCharacters+ , treeEmpty = " "+ }
src/full/Agda/Syntax/Concrete/Name.hs view
@@ -1,8 +1,14 @@+{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-}+ {-| Names in the concrete syntax are just strings (or lists of strings for qualified names). -} module Agda.Syntax.Concrete.Name where +import Prelude hiding (null)+ import Control.DeepSeq import Data.ByteString.Char8 (ByteString)@@ -23,6 +29,7 @@ import Agda.Utils.Suffix import Agda.Utils.Impossible+import Agda.Utils.Null (Null (empty, null)) {-| A name is a non-empty list of alternating 'Id's and 'Hole's. A normal name is represented by a singleton list, and operators are represented by a list@@ -48,8 +55,8 @@ -- | An open mixfix identifier is either prefix, infix, or suffix. -- That is to say: at least one of its extremities is a @Hole@ -isOpenMixfix :: Name -> Bool-isOpenMixfix = \case+isPrePostOrInfixOperator :: Name -> Bool+isPrePostOrInfixOperator = \case Name _ _ (x :| x' : xs) -> x == Hole || last1 x' xs == Hole _ -> False @@ -57,8 +64,15 @@ underscore = NoName noRange __IMPOSSIBLE__ isUnderscore NoName{} = True isUnderscore (Name {nameNameParts = Id x :| []}) = isUnderscore x+ isUnderscore (Name {nameNameParts = Hole :| []}) = True isUnderscore _ = False +instance Null Name where+ empty = NoName empty empty+ null = \case+ NoName _r i -> null i+ Name{} -> False+ -- | Mixfix identifiers are composed of words and holes, -- e.g. @_+_@ or @if_then_else_@ or @[_/_]@. data NamePart@@ -114,6 +128,12 @@ isUnderscore (QName x) = isUnderscore x isUnderscore Qual{} = False +instance Null QName where+ empty = QName empty+ null = \case+ QName x -> null x+ Qual{} -> False+ ------------------------------------------------------------------------ -- * Constructing simple 'Name's. ------------------------------------------------------------------------@@ -129,6 +149,12 @@ -- | Create an ordinary 'InScope' name containing a single 'Hole'. simpleHole :: Name simpleHole = Name noRange InScope $ singleton Hole++-- | Check whether a name is a simple identifier without holes.+isSimpleName :: Name -> Maybe RawName+isSimpleName = \case+ Name _ _ (Id x :| []) -> Just x+ _ -> Nothing ------------------------------------------------------------------------ -- * Operations on 'Name' and 'NamePart'
src/full/Agda/Syntax/Concrete/Operators.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-} {-# LANGUAGE DataKinds #-} @@ -19,17 +20,22 @@ , parsePatternSyn ) where +import Prelude hiding (null)+ import Control.Applicative ( Alternative( (<|>) ) ) import Control.Monad.Except (throwError)+import Control.Monad ((<$!>)) import Data.Either (partitionEithers) import qualified Data.Function+import Data.Foldable import qualified Data.List as List import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Traversable as Trav +import Agda.Syntax.Abstract.Name (KindOfName(..)) import Agda.Syntax.Common import Agda.Syntax.Concrete hiding (appView) import Agda.Syntax.Concrete.Operators.Parser@@ -38,7 +44,7 @@ import Agda.Syntax.Position import Agda.Syntax.Notation import Agda.Syntax.Scope.Base-import Agda.Syntax.Scope.Flat+import Agda.Syntax.Scope.Operator import Agda.Syntax.Scope.Monad import Agda.TypeChecking.Monad.Base (typeError, TypeError(..), LHSOrPatSyn(..))@@ -52,6 +58,7 @@ import Agda.Utils.List import Agda.Utils.List1 (List1, pattern (:|), (<|)) import Agda.Utils.List2 (List2, pattern List2)+import Agda.Utils.Null import qualified Agda.Utils.List1 as List1 import qualified Agda.Utils.List2 as List2 import Agda.Utils.Maybe@@ -68,12 +75,9 @@ -- | Bills the operator parser. billToParser :: ExprKind -> ScopeM a -> ScopeM a-billToParser k = Bench.billTo- [ Bench.Parsing- , case k of- IsExpr -> Bench.OperatorsExpr- IsPattern -> Bench.OperatorsPattern- ]+billToParser k = Bench.billTo $! case k of+ IsExpr -> [Bench.Parsing, Bench.OperatorsExpr]+ IsPattern _ -> [Bench.Parsing, Bench.OperatorsPattern] --------------------------------------------------------------------------- -- * Building the parser@@ -91,20 +95,26 @@ -- | The data returned by 'buildParsers'. data Parsers e = Parsers- { parser :: [e] -> [e]+ { parser :: !([e] -> [e]) -- ^ A parser for expressions or patterns (depending on the -- 'ExprKind' argument given to 'buildParsers').- , argsParser :: [e] -> [[NamedArg e]]+ , argsParser :: !([e] -> [[NamedArg e]]) -- ^ A parser for sequences of arguments.- , operators :: [NotationSection]- -- ^ All operators/notations/sections that were used to generate+ , operators :: ![NotationSection]+ -- ^ All operators, notations, and sections that were used to generate -- the grammar.- , flattenedScope :: FlatScope- -- ^ A flattened scope that only contains those names that are- -- unqualified or qualified by qualifiers that occur in the list- -- of names given to 'buildParsers'.+ -- Only used for error reporting via 'OperatorInformation'.+ , operatorScope :: !OperatorScope+ -- ^ A flattened scope that only contains names such that+ -- they occur in the expression or at least one of their+ -- name parts occurs in the expression. } +{-# SPECIALIZE buildParsersFromOperatorScope ::+ ExprKind -> Maybe QName -> Set QName -> OperatorScope -> ScopeM (Parsers Expr) #-}+{-# SPECIALIZE buildParsersFromOperatorScope ::+ ExprKind -> Maybe QName -> Set QName -> OperatorScope -> ScopeM (Parsers Pattern) #-}+ -- | Builds parsers for operator applications from all the operators -- and function symbols in scope. --@@ -120,40 +130,27 @@ -- sections in patterns, then we would have to accept certain such -- sequences of tokens as single pattern variables. -buildParsers- :: forall e. IsExpr e+buildParsersFromOperatorScope ::+ forall e. IsExpr e => ExprKind- -- ^ Should expressions or patterns be parsed? -> Maybe QName- -- ^ Are we trying to parse the lhs of the function given here?- -> [QName]- -- ^ This list must include every name part in the- -- expression/pattern to be parsed (excluding name parts inside- -- things like parenthesised subexpressions that are treated as- -- atoms). The list is used to optimise the parser. For- -- instance, a given notation is only included in the generated- -- grammar if all of the notation's name parts are present in- -- the list of names.+ -> Set QName+ -> OperatorScope -> ScopeM (Parsers e)-buildParsers kind top exprNames0 = do- let exprNames = applyWhenJust top (:) exprNames0- flat <- flattenScope (qualifierModules exprNames) <$>- getScope- (names, ops0) <- localNames kind top flat- let ops | kind == IsPattern = filter (not . isLambdaNotation) ops0- | otherwise = ops0+buildParsersFromOperatorScope kind top namesInExpr opScope = do - let -- All names.- namesInExpr :: Set QName- namesInExpr = Set.fromList exprNames+ (names, ops0) <- localNames kind top opScope+ let ops | isKindPattern kind = filter' (not . isLambdaNotation) ops0+ | otherwise = ops0 - partListsInExpr' = map (List1.toList . nameParts . unqualify) $- Set.toList namesInExpr+ let+ partListsInExpr' = map' (List1.toList . nameParts . unqualify)+ (Set.toList namesInExpr) partListTrie f =- foldr (\ps -> Trie.union (Trie.everyPrefix ps ()))- Trie.empty- (f partListsInExpr')+ foldr' (\ps -> Trie.union (Trie.everyPrefix ps ()))+ Trie.empty+ (f partListsInExpr') -- All names. partListsInExpr :: Trie NamePart ()@@ -161,18 +158,15 @@ -- All names, with the name parts in reverse order. reversedPartListsInExpr :: Trie NamePart ()- reversedPartListsInExpr = partListTrie (map reverse)+ reversedPartListsInExpr = partListTrie (map' reverse) -- Every regular name part (not holes etc.). partsInExpr :: Set RawName partsInExpr =- Set.fromList [ s | Id s <- concat partListsInExpr' ]+ Set.fromList [ s | Id s <- concat' partListsInExpr'] -- Are all name parts present in the expression?- partsPresent n =- [ Set.member p partsInExpr- | p <- stringParts (notation n)- ]+ partsPresent n = map' (\p -> Set.member p partsInExpr) (stringParts (notation n)) addHole True p = [Hole, Id p] addHole False p = [Id p]@@ -235,27 +229,31 @@ -- resulting in a confusing error message claiming that "if" -- is not in scope. - (non, fix) = List.partition nonfix (filter (and . partsPresent) ops)+ (non, fix) = partition' nonfix (filter' (and . partsPresent) ops) + cons :: [List1 NewNotation] cons = getDefinedNames- (someKindsOfNames [ConName, CoConName, FldName, PatternSynName]) flat+ (someKindsOfNames [ConName, CoConName, FldName, PatternSynName]) opScope+ conNames :: Set QName conNames = Set.fromList $- filter (flip Set.member namesInExpr) $- map (notaName . List1.head) cons- conParts = Set.fromList $- concatMap notationNames $- filter (or . partsPresent) $- List1.concat cons+ filter' (flip Set.member namesInExpr) $+ map' (notaName . List1.head) cons+ conParts :: Set QName+ conParts = Set.fromList $ concatMap' notationNames conPartNotations+ conPartNotations :: [NewNotation]+ conPartNotations = filter' (or . partsPresent) $ List1.concat' cons + allNames :: Set QName allNames = Set.fromList $- filter (flip Set.member namesInExpr) names+ filter' (flip Set.member namesInExpr) names+ allParts :: Set QName allParts = Set.union conParts (Set.fromList $- concatMap notationNames $- filter (or . partsPresent) ops)+ concatMap' notationNames $+ filter' (or . partsPresent) ops) isAtom x- | kind == IsPattern && not (isQualified x) =+ | isKindPattern kind && not (isQualified x) = not (Set.member x conParts) || Set.member x conNames | otherwise = not (Set.member x allParts) || Set.member x allNames@@ -263,8 +261,8 @@ -- unless it is also used as an identifier. See issue 307. parseSections = case kind of- IsPattern -> DoNotParseSections- IsExpr -> ParseSections+ IsPattern _ -> DoNotParseSections+ IsExpr -> ParseSections let nonClosedSections l ns = case parseSections of@@ -280,16 +278,15 @@ unrelatedOperators :: [NotationSection] unrelatedOperators = filterCorrectUnderscoresOp unrelated- +++ ++! nonClosedSections Unrelated unrelated where- unrelated = filter ((== Unrelated) . level) fix+ unrelated = filter' ((== Unrelated) . level) fix nonWithSections :: [NotationSection] nonWithSections =- map (\s -> s { sectLevel = Nothing })- (filterCorrectUnderscoresOp non)- +++ map' (\s -> s { sectLevel = Nothing }) (filterCorrectUnderscoresOp non)+ ++! case parseSections of DoNotParseSections -> [] ParseSections ->@@ -303,43 +300,59 @@ -- level comes first. relatedOperators :: [(PrecedenceLevel, [NotationSection])] relatedOperators =- map (\((l, ns) :| rest) -> (l, ns ++ concatMap snd rest)) .+ map' (\((l, ns) :| rest) -> (l, ns ++! concatMap' snd rest)) . List1.groupOn fst .- mapMaybe (\n -> case level n of+ mapMaybe' (\n -> case level n of Unrelated -> Nothing r@(Related l) -> Just (l, filterCorrectUnderscoresOp [n] ++ nonClosedSections r [n])) $ fix + almostEverything :: [NotationSection]+ almostEverything =+ concatMap' snd relatedOperators ++!+ unrelatedOperators ++!+ nonWithSections++ -- Andreas, 2026-02-21, issue #5839+ -- Add constructor parts to the used-operators list,+ -- so that failing lhs parses become more comprehensible.+ -- Disclaimer: I don't know my way around this code,+ -- and the expert did get active on this issue, see+ -- https://github.com/agda/agda/issues/5839#issuecomment-1073286909+ -- so I apologize if this is done in a non-idiomatic of clumsy fashion. everything :: [NotationSection] everything =- concatMap snd relatedOperators ++- unrelatedOperators ++- nonWithSections+ almostEverything ++!+ map' noSection (filter' ((`Set.notMember` keys) . key) conPartNotations)+ where+ key = notaName+ keys = Set.fromList $ map' (key . sectNotation) almostEverything reportS "scope.operators" 50 [ "unrelatedOperators = " ++ prettyShow unrelatedOperators , "nonWithSections = " ++ prettyShow nonWithSections , "relatedOperators = " ++ prettyShow relatedOperators+ , "conPartNotations = " ++ prettyShow conPartNotations ] let g = Data.Function.fix $ \p -> InternalParsers { pTop = memoise TopK $ Agda.Utils.List.asum $- foldr (\(l, ns) higher ->- mkP (Right l) parseSections- (pTop p) ns higher True) (pApp p)+ foldr' (\(l, ns) higher ->+ mkP (RightPK l) parseSections+ (pTop p) ns higher True) (pApp p) relatedOperators :- zipWith (\ k n ->- mkP (Left k) parseSections+ zipWith' (\ k n ->+ mkP (LeftPK k) parseSections (pTop p) [n] (pApp p) False) [0..] unrelatedOperators , pApp = memoise AppK $ appP (pNonfix p) (pArgs p) , pArgs = argsP (pNonfix p) , pNonfix = memoise NonfixK $ Agda.Utils.List.asum $- pAtom p :- map (\sect ->+ (pAtom p :) $!+ map' (\sect -> let n = sectNotation sect inner :: forall k. NK k ->@@ -363,14 +376,14 @@ -- Andreas, 2020-06-03 #4712 -- Note: needs Agda to be compiled with DEBUG_PARSING to print the grammar.- reportSDoc "scope.grammar" 20 $ return $+ reportS "scope.grammar" 20 $ "Operator grammar:" $$ nest 2 (grammar (pTop g)) return $ Parsers { parser = parse (parseSections, pTop g) , argsParser = parse (parseSections, pArgs g) , operators = everything- , flattenedScope = flat+ , operatorScope = opScope } where level :: NewNotation -> FixityLevel@@ -403,7 +416,7 @@ mkP key parseSections p0 ops higher includeHigher = memoise (NodeK key) $ Agda.Utils.List.asum $- applyWhen includeHigher (higher :) $+ applyWhen includeHigher (higher :) $! catMaybes [nonAssoc, preRights, postLefts] where -- Andreas, 2025-02-27@@ -441,12 +454,12 @@ choiceIn :: [NotationSection] -> Parser e (OperatorType 'InfixNotation e) choiceIn = Agda.Utils.List.asum .- map \ sect -> opP parseSections p0 (sectNotation sect) In+ map' \ sect -> opP parseSections p0 (sectNotation sect) In choicePre :: [NotationSection] -> Parser e (OperatorType 'PrefixNotation e) choicePre = Agda.Utils.List.asum .- map \ sect -> do+ map' \ sect -> do let n = sectNotation sect if isinfix n || ispostfix n then flip ($) <$> placeholder Beginning@@ -456,7 +469,7 @@ choicePost :: [NotationSection] -> Parser e (OperatorType 'PostfixNotation e) choicePost = Agda.Utils.List.asum .- map \ sect -> do+ map' \ sect -> do let n = sectNotation sect if isinfix n || isprefix n then flip <$> opP parseSections p0 n In@@ -472,18 +485,18 @@ <*> choiceIn ops <*> higher - or p1 [] p2 [] = Nothing- or p1 [] p2 ops2 = Just (p2 ops2)- or p1 ops1 p2 [] = Just (p1 ops1)+ or _ [] _ [] = Nothing+ or _ [] p2 ops2 = Just (p2 ops2)+ or p1 ops1 _ [] = Just (p1 ops1) or p1 ops1 p2 ops2 = Just (p1 ops1 <|> p2 ops2) preRight :: Maybe (Parser e (MaybePlaceholder e -> e)) preRight = or choicePre- (filter isPrefix ops)+ (filter' isPrefix ops) (\ops -> flip ($) <$> (noPlaceholder <$> higher) <*> choiceIn ops)- (filter (isInfix RightAssoc) ops)+ (filter' (isInfix RightAssoc) ops) preRights :: Maybe (Parser e e) preRights = do@@ -498,7 +511,7 @@ (filter isPostfix ops) (\ops -> flip <$> choiceIn ops <*> (noPlaceholder <$> higher))- (filter (isInfix LeftAssoc) ops)+ (filter' (isInfix LeftAssoc) ops) postLefts :: Maybe (Parser e e) postLefts = do@@ -508,7 +521,51 @@ flip ($) <$> (noPlaceholder <$> (postLefts <|> higher)) <*> postLeft +-- | Only build parsers if there's at least one relevant operator or notation in+-- scope.+buildParsers ::+ forall e. IsExpr e+ => ExprKind+ -- ^ Should expressions or patterns be parsed?+ -> Maybe QName+ -- ^ Are we trying to parse the lhs of the function given here?+ -> [QName]+ -- ^ This list must include every name part in the+ -- expression/pattern to be parsed (excluding name parts inside+ -- things like parenthesised subexpressions that are treated as+ -- atoms). The list is used to optimise the parser. For+ -- instance, a given notation is only included in the generated+ -- grammar if all of the notation's name parts are present in+ -- the list of names.+ -> ScopeM (Maybe (Parsers e))+buildParsers kind top exprNames0 = do+ let namesInExpr = Set.fromList $ applyWhenJust top (:) exprNames0+ opScope <- getOperatorScope namesInExpr <$> getScope+ if osHasOps opScope+ then Just <$!> buildParsersFromOperatorScope kind top namesInExpr opScope+ else pure Nothing +-- | Build parsers regardless of there being operators or notations in the relevant scope.+alwaysBuildParsers ::+ forall e. IsExpr e+ => ExprKind+ -- ^ Should expressions or patterns be parsed?+ -> Maybe QName+ -- ^ Are we trying to parse the lhs of the function given here?+ -> [QName]+ -- ^ This list must include every name part in the+ -- expression/pattern to be parsed (excluding name parts inside+ -- things like parenthesised subexpressions that are treated as+ -- atoms). The list is used to optimise the parser. For+ -- instance, a given notation is only included in the generated+ -- grammar if all of the notation's name parts are present in+ -- the list of names.+ -> ScopeM (Parsers e)+alwaysBuildParsers kind top exprNames0 = do+ let namesInExpr = Set.fromList $ applyWhenJust top (:) exprNames0+ opScope <- getOperatorScope namesInExpr <$> getScope+ buildParsersFromOperatorScope kind top namesInExpr opScope+ --------------------------------------------------------------------------- -- * Parse functions ---------------------------------------------------------------------------@@ -535,7 +592,7 @@ InstanceP _ _ -> fail "bad instance argument" AsP r x p -> AsP r x <$> loop p p@DotP{} -> return p- ParenP r p -> fullParen' <$> loop p+ ParenP _r p -> fullParen' <$> loop p p@WildP{} -> return p p@AbsurdP{} -> return p p@LitP{} -> return p@@ -610,46 +667,46 @@ -- 'Nothing' if we parse a pattern. -> Pattern -- ^ Thing to parse.- -> ScopeM (ParseLHS, [NotationSection])+ -> ScopeM (ParseLHS, [NotationSection], OperatorScope) -- ^ The returned list contains all operators\/notations\/sections that -- were used to generate the grammar. parseLHS' NoDisplayLHS IsLHS (Just qn) WildP{} =- return (ParseLHS qn $ LHSHead qn [], [])+ return (ParseLHS qn $ LHSHead qn [], [], empty) parseLHS' displayLhs lhsOrPatSyn top p = do -- Build parser.- patP <- buildParsers IsPattern top (patternQNames p)+ patP <- alwaysBuildParsers (IsPattern displayLhs) top (patternQNames p) -- Run parser, forcing result. let ps = let result = parsePat (parser patP) p- in foldr seq () result `seq` result+ in foldr' seq () result `seq` result -- Classify parse results. let cons = getNames (someKindsOfNames $ applyWhen displayLhs (defNameKinds ++) conLikeNameKinds)- (flattenedScope patP)+ (operatorScope patP) let flds = getNames (someKindsOfNames [FldName])- (flattenedScope patP)+ (operatorScope patP) let conf = PatternCheckConfig top (hasElem cons) (hasElem flds) - let (errs, results) = partitionEithers $ map (validPattern conf) ps+ let (errs, results) = partitionEithers' $ map' (validPattern conf) ps reportS "scope.operators" 60 $ vcat $ [ "Possible parses for lhs:" ] ++ map (nest 2 . pretty . snd) results case results of -- Unique result.- [(_,lhs)] -> (lhs, operators patP) <$ do+ [(_,lhs)] -> (lhs, operators patP, operatorScope patP) <$ do reportS "scope.operators" 50 $ "Parsed lhs:" <+> pretty lhs -- No result.- [] -> typeError $ OperatorInformation (operators patP) $+ [] -> typeError $ OperatorInformation (operators patP) (operatorScope patP) $ NoParseForLHS lhsOrPatSyn (catMaybes errs) p -- Ambiguous result.- r0:r1:rs -> typeError $ OperatorInformation (operators patP) $+ r0:r1:rs -> typeError $ OperatorInformation (operators patP) (operatorScope patP) $ AmbiguousParseForLHS lhsOrPatSyn p $ fmap (fullParen . fst) $ List2 r0 r1 rs where getNames kinds flat =- map (notaName . List1.head) $ getDefinedNames kinds flat+ map' (notaName . List1.head) $ getDefinedNames kinds flat -- The pattern is retained for error reporting in case of ambiguous parses. validPattern :: PatternCheckConfig -> Pattern -> PM (Pattern, ParseLHS)@@ -684,7 +741,12 @@ return $ ParseLHS x $ lhsCoreAddSpine (LHSHead x []) ps -- case @d ps@- Arg _ (Named _ (IdentP _ x)) :| ps | fldName conf x -> do+ -- Andreas, 2026-08-21, issue #8599:+ -- A field can only head a projection (copattern) if we are parsing a lhs,+ -- i.e., if we are looking for the defined name @topName@.+ -- When parsing a mere pattern, a field name has to be treated+ -- like an ordinary identifier, falling through to the last case.+ Arg _ (Named _ (IdentP _ x)) :| ps | isJust (topName conf), fldName conf x -> do -- Step 1: check for valid copattern lhs. ps0 :: [NamedArg ParseLHS] <- mapM classPat ps@@ -738,11 +800,11 @@ -> Pattern -- ^ Full left hand side. -> ScopeM LHSCore-parseLHS displayLhs top p = billToParser IsPattern $ do- (res, ops) <- parseLHS' displayLhs IsLHS (Just top) p+parseLHS displayLhs top p = billToParser (IsPattern displayLhs) $ do+ (res, ops, opScope) <- parseLHS' displayLhs IsLHS (Just top) p case res of- ParseLHS f lhs -> return lhs- _ -> typeError $ OperatorInformation ops+ ParseLHS _f lhs -> return lhs+ _ -> typeError $ OperatorInformation ops opScope $ NoParseForLHS IsLHS [] p -- | Parses a pattern.@@ -753,11 +815,11 @@ parsePatternSyn = parsePatternOrSyn IsPatSyn parsePatternOrSyn :: LHSOrPatSyn -> Pattern -> ScopeM Pattern-parsePatternOrSyn lhsOrPatSyn p = billToParser IsPattern $ do- (res, ops) <- parseLHS' NoDisplayLHS lhsOrPatSyn Nothing p+parsePatternOrSyn lhsOrPatSyn p = billToParser (IsPattern NoDisplayLHS) $ do+ (res, ops, opScope) <- parseLHS' NoDisplayLHS lhsOrPatSyn Nothing p case res of ParsePattern p -> return p- _ -> typeError $ OperatorInformation ops+ _ -> typeError $ OperatorInformation ops opScope $ NoParseForLHS lhsOrPatSyn [] p -- | Helper function for 'parseLHS' and 'parsePattern'.@@ -787,7 +849,7 @@ | cons x -> mapM_ loop ps | otherwise -> failure QuoteP _ :| [_] -> ok- DotP _ _ _ :| ps -> mapM_ loop ps+ DotP _ _ _ _ :| ps -> mapM_ loop ps -- Failures: AbsurdP{} :| _:_ -> failure@@ -831,33 +893,39 @@ where ret p = p :| reverse acc --- | Return all qualifiers occuring in a list of 'QName's.--- Each qualifier is returned as a list of names, e.g.--- for @Data.Nat._+_@ we return the list @[Data,Nat]@.-qualifierModules :: [QName] -> [[Name]]-qualifierModules qs =- nubOn id $ filter (not . null) $ map (List1.init . qnameParts) qs- -- | Parse a list of expressions (typically from a 'RawApp') into an application. parseApplication :: List2 Expr -> ScopeM Expr parseApplication es = billToParser IsExpr $ do let es0 = List2.toList es- -- Build the parser p <- buildParsers IsExpr Nothing [ q | Ident q <- es0 ]+ case p of - -- Parse- let result = parser p es0- case foldr seq () result `seq` result of- [e] -> do- reportSDoc "scope.operators" 50 $ return $- "Parsed an operator application:" <+> pretty e- return e- [] -> typeError $ OperatorInformation (operators p)- $ NoParseForApplication es- e:es' -> typeError $ OperatorInformation (operators p)- $ AmbiguousParseForApplication es- $ fmap fullParen (e :| es')+ -- no operators or notations in scope+ Nothing -> do+ let hd :| rest = List2.toList1 es+ app :: Expr -> Expr -> Expr+ app !acc !e = let+ range = fuseRange acc e+ !arg = case e of+ HiddenArg _ e -> hide (defaultArg e)+ InstanceArg _ e -> makeInstance (defaultArg e)+ e -> defaultArg (unnamed e)+ in App range acc arg+ !res = foldl' app hd rest+ pure res + -- operators or notations in scope+ Just p -> case parser p es0 of+ [e] -> do+ reportS "scope.operators" 50 $+ "Parsed an operator application:" <+> pretty e+ return $! e+ [] -> typeError $ OperatorInformation (operators p) (operatorScope p)+ $ NoParseForApplication es+ e:es' -> typeError $ OperatorInformation (operators p) (operatorScope p)+ $ AmbiguousParseForApplication es+ $ fmap fullParen (e :| es')+ -- | Parse the arguments of a raw application with known head. -- parseArguments ::@@ -873,16 +941,20 @@ -- Build the arguments parser p <- buildParsers IsExpr Nothing [ q | Ident q <- es ]-- -- Parse- -- TODO: not sure about forcing- case {-force $-} argsParser p es of- [as] -> return as- [] -> typeError $ OperatorInformation (operators p)+ case p of+ Nothing -> do+ let go :: Expr -> NamedArg Expr+ go (HiddenArg _ e) = hide (defaultArg e)+ go (InstanceArg _ e) = makeInstance (defaultArg e)+ go e = defaultArg (unnamed e)+ return $! map' go es+ Just p -> case argsParser p es of+ [as] -> return $! as+ [] -> typeError $ OperatorInformation (operators p) (operatorScope p) $ NoParseForApplication es2 as : ass -> do- let f = fullParen . foldl (App noRange) hd- typeError $ OperatorInformation (operators p)+ let f = fullParen . foldl' (App noRange) hd+ typeError $ OperatorInformation (operators p) (operatorScope p) $ AmbiguousParseForApplication es2 $ fmap f (as :| ass)
src/full/Agda/Syntax/Concrete/Operators/Parser.hs view
@@ -1,4 +1,6 @@ {-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-} {-# LANGUAGE DataKinds #-} @@ -7,11 +9,9 @@ import Control.Applicative ( Alternative((<|>), many) ) 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 Agda.Syntax.Position@@ -23,7 +23,7 @@ import qualified Agda.Syntax.Concrete.Operators.Parser.Monad as P import Agda.Syntax.Common.Pretty-import Agda.Utils.List ( spanEnd )+import Agda.Utils.List import Agda.Utils.List1 ( List1, pattern (:|), (<|) ) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Set1 ( Set1 )@@ -77,7 +77,7 @@ exprView = \case Ident x -> LocalV x App _ e1 e2 -> AppV e1 e2- OpApp r d ns es -> OpAppV d ns es+ OpApp _ d ns es -> OpAppV d ns es HiddenArg _ e -> HiddenArgV e InstanceArg _ e -> InstanceArgV e Paren _ e -> ParenV e@@ -102,7 +102,7 @@ IdentP True x -> LocalV x IdentP False _ -> __IMPOSSIBLE__ AppP e1 e2 -> AppV e1 e2- OpAppP r d ns es -> OpAppV d ns $ (fmap . fmap . fmap) (noPlaceholder . Ordinary) es+ OpAppP _ d ns es -> OpAppV d ns $ (fmap . fmap . fmap) (noPlaceholder . Ordinary) es HiddenP _ e -> HiddenArgV e InstanceP _ e -> InstanceArgV e ParenP _ e -> ParenV e@@ -253,8 +253,8 @@ flip fmap (worker (List1.init $ qnameParts q) withoutExternalHoles) $ \(range, hs) -> - let (normal, binders) = partitionEithers hs- lastHole = maximum $ (-1) : mapMaybe holeTarget syn+ let (normal, binders) = partitionEithers' hs+ lastHole = maximum $ ((-1) :) $ mapMaybe' holeTarget syn app :: ([(MaybePlaceholder e, NamedArg (Ranged Int))] -> [(MaybePlaceholder e, NamedArg (Ranged Int))]) -> e@@ -271,13 +271,13 @@ {-then-} (unExprView $ LocalV q') {-else-} $ unExprView . OpAppV q' names where- args = fmap (findExprFor (f normal) binders) [0..lastHole]+ args = map (findExprFor (f normal) binders) [0..lastHole] q' = setRange range q in case kind of- In -> \x y -> app (\es -> (x, leadingHole) : es ++ [(y, trailingHole)])- Pre -> \ y -> app (\es -> es ++ [(y, trailingHole)])+ In -> \x y -> app (\es -> (x, leadingHole) : es ++! [(y, trailingHole)])+ Pre -> \ y -> app (\es -> es ++! [(y, trailingHole)]) Post -> \x -> app (\es -> (x, leadingHole) : es) Non -> app (\es -> es) @@ -298,7 +298,7 @@ [Name] -> Notation -> Parser e (Range, [Either (MaybePlaceholder e, NamedArg (Ranged Int)) (LamBinding, Ranged BoundVariablePosition)])- worker ms [] = pure (noRange, [])+ worker _ [] = pure (noRange, []) worker ms (IdPart x : xs) = (\r1 (r2, es) -> (fuseRanges r1 r2, es)) <$> partP ms (rangedThing x)@@ -313,16 +313,19 @@ <*> worker ms xs worker ms (WildPart h : xs) = (\(r, es) -> let anon = mkBinder_ simpleHole- in (r, Right (mkBinding h anon) : es))+ !e = Right $! mkBinding h anon+ in (r, e : es)) <$> worker ms xs worker ms (VarPart _ h : xs) = do- (\ b (r, es) -> (r, Right (mkBinding h b) : es))+ (\ b (r, es) ->+ let !e = Right $! mkBinding h b+ in (r, e : es)) -- Andreas, 2011-04-07 put just 'Relevant' here, is this -- correct? <$> patternBinder <*> worker ms xs - mkBinding h b = (DomainFree $ defaultNamedArg b, h)+ mkBinding h b = ((,) $! DomainFree $ defaultNamedArg b) h set x arg = fmap (fmap (const x)) arg @@ -335,7 +338,7 @@ [(Placeholder p, arg)] -> set (Placeholder p) arg [(NoPlaceholder _ e, arg)] -> List1.ifNull- (map snd $+ (map' snd $ List.sortBy (compare `on` fst) [ (varNumber (rangedThing m), b) | (b, m) <- binders@@ -346,7 +349,7 @@ _ -> __IMPOSSIBLE__ noPlaceholders :: OpAppArgs0 e -> Int- noPlaceholders = sum . fmap (isPlaceholder . namedArg)+ noPlaceholders = sum . map (isPlaceholder . namedArg) where isPlaceholder NoPlaceholder{} = 0 isPlaceholder Placeholder{} = 1@@ -360,7 +363,7 @@ _ -> defaultArg (unnamed e) appP :: IsExpr e => Parser e e -> Parser e [NamedArg e] -> Parser e e-appP p pa = foldl app <$> p <*> pa+appP p pa = List.foldl' app <$> p <*> pa where app e = unExprView . AppV e
src/full/Agda/Syntax/Concrete/Operators/Parser/Monad.hs view
@@ -1,4 +1,8 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-} {-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-} ------------------------------------------------------------------------ -- | The parser monad used by the operator parser@@ -16,32 +20,64 @@ , memoise , memoiseIfPrinting , grammar+ , pattern LeftPK+ , pattern RightPK ) where import Data.Hashable import GHC.Generics (Generic)+#if ! (__GLASGOW_HASKELL__ <= 908)+import GHC.Exts+#endif+import GHC.Word (Word64(..)) import Agda.Syntax.Common import Agda.Syntax.Common.Pretty import qualified Agda.Utils.Parser.MemoisedCPS as Parser+import Agda.Utils.Hash -- | Memoisation keys. -data MemoKey = NodeK PrecedenceKey- | PostLeftsK PrecedenceKey- | PreRightsK PrecedenceKey+data MemoKey = NodeK {-# UNPACK #-} !PrecedenceKey+ | PostLeftsK {-# UNPACK #-} !PrecedenceKey+ | PreRightsK {-# UNPACK #-} !PrecedenceKey | TopK | AppK | NonfixK deriving (Eq, Show, Generic) -type PrecedenceKey = Either PrecedenceLevel PrecedenceLevel+data PrecedenceKey = PrecKey !Bool !PrecedenceLevel+ deriving (Eq, Show) -instance Hashable MemoKey+pattern RightPK :: PrecedenceLevel -> PrecedenceKey+pattern RightPK l = PrecKey False l --- | The parser monad.+pattern LeftPK :: PrecedenceLevel -> PrecedenceKey+pattern LeftPK l = PrecKey True l +#if __GLASGOW_HASKELL__ <= 908+doubleToWord64 :: Double -> Word64+doubleToWord64 x = fromIntegral $ hash x+#else+doubleToWord64 :: Double -> Word64+doubleToWord64 (D# x) = W64# (castDoubleToWord64# x)+#endif++instance Hashable PrecedenceKey where+ hashWithSalt h (PrecKey b l) = fromIntegral $+ fromIntegral (h + fromEnum b) `combineWord` fromIntegral (doubleToWord64 l)++instance Hashable MemoKey where+ hashWithSalt h = \case+ NodeK pk -> hashWithSalt (h + 1) pk+ PostLeftsK pk -> hashWithSalt (h + 2) pk+ PreRightsK pk -> hashWithSalt (h + 3) pk+ TopK -> combineInt h 4+ AppK -> combineInt h 5+ NonfixK -> combineInt h 6++-- | The parser monad. type Parser tok a = #ifdef DEBUG_PARSING Parser.ParserWithGrammar
src/full/Agda/Syntax/Concrete/Pattern.hs view
@@ -1,10 +1,12 @@+-- {-# OPTIONS_GHC -Wunused-imports #-} -- no, because of liftA2+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-} -- | Tools for patterns in concrete syntax. module Agda.Syntax.Concrete.Pattern where import Control.Applicative ( liftA2 )-import Control.Arrow ( first ) import Control.Monad ( (>=>) ) import Control.Monad.Identity @@ -21,7 +23,8 @@ import Agda.Utils.List2 ( List2 ) import Agda.Utils.Maybe import Agda.Utils.Singleton-import qualified Agda.Utils.List1 as List1+import Agda.Utils.List1 qualified as List1+import Agda.Utils.Tuple ( first ) -- | Check for ellipsis @...@.@@ -125,7 +128,7 @@ lhs { lhsOriginalPattern = f p } -- | Effectfully modify the 'Pattern' component in 'LHS'.-mapLhsOriginalPatternM :: (Functor m, Applicative m) => (Pattern -> m Pattern) -> LHS -> m LHS+mapLhsOriginalPatternM :: (Functor m) => (Pattern -> m Pattern) -> LHS -> m LHS mapLhsOriginalPatternM f lhs@LHS{ lhsOriginalPattern = p } = f p <&> \ p' -> lhs { lhsOriginalPattern = p' } @@ -158,12 +161,12 @@ foldrCPattern = foldMap . foldrCPattern -- | Traverse pattern with option of post-traversal modification.- traverseCPatternA :: (Applicative m, Functor m)+ traverseCPatternA :: (Applicative m) => (Pattern -> m Pattern -> m Pattern) -- ^ Combine a pattern and the its recursively computed version. -> p -> m p - default traverseCPatternA :: (Traversable f, CPatternLike q, f q ~ p, Applicative m, Functor m)+ default traverseCPatternA :: (Traversable f, CPatternLike q, f q ~ p, Applicative m) => (Pattern -> m Pattern -> m Pattern) -> p -> m p traverseCPatternA = traverse . traverseCPatternA@@ -198,7 +201,7 @@ -- Nonrecursive cases: IdentP _ _ -> mempty WildP _ -> mempty- DotP _ _ _ -> mempty+ DotP _ _ _ _ -> mempty AbsurdP _ -> mempty LitP _ _ -> mempty QuoteP _ -> mempty@@ -219,7 +222,7 @@ -- Nonrecursive cases: IdentP _ _ -> pure p0 WildP _ -> pure p0- DotP _ _ _ -> pure p0+ DotP _ _ _ _ -> pure p0 AbsurdP _ -> pure p0 LitP _ _ -> pure p0 QuoteP _ -> pure p0@@ -242,7 +245,7 @@ -- Nonrecursive cases: IdentP _ _ -> return p0 WildP _ -> return p0- DotP _ _ _ -> return p0+ DotP _ _ _ _ -> return p0 AbsurdP _ -> return p0 LitP _ _ -> return p0 QuoteP _ -> return p0@@ -309,7 +312,7 @@ f = \case IdentP _ x -> Endo (x :) OpAppP _ x _ _ -> Endo (x :)- AsP _ x _ -> mempty -- x must be a bound name, can't be a constructor!+ AsP _ _x _ -> mempty -- _x must be a bound name, can't be a constructor! AppP _ _ -> mempty WithP _ _ -> mempty RawAppP _ _ -> mempty@@ -317,7 +320,7 @@ ParenP _ _ -> mempty WildP _ -> mempty AbsurdP _ -> mempty- DotP _ _ _ -> mempty+ DotP _ _ _ _ -> mempty LitP _ _ -> mempty QuoteP _ -> mempty InstanceP _ _ -> mempty@@ -354,16 +357,17 @@ EllipsisP _ Nothing -> OneHole id p _ -> mp +-- | Reconstruct the ellipsis, used in printing (AbstractToConcrete). reintroduceEllipsis :: ExpandedEllipsis -> Pattern -> Pattern reintroduceEllipsis (ExpandedEllipsis r k) p | hasWithPatterns p = let (args, wargs) = splitEllipsis k $ List1.toList $ patternAppView p (hd,args') = fromMaybe __IMPOSSIBLE__ $ uncons args- core = foldl AppP (namedArg hd) args+ core = foldl AppP (namedArg hd) args' in foldl AppP (EllipsisP r $ Just $ core) wargs reintroduceEllipsis _ p = p splitEllipsis :: (IsWithP p) => Int -> [p] -> ([p],[p])-splitEllipsis k [] = ([] , [])+splitEllipsis _ [] = ([] , []) splitEllipsis k (p:ps) | isJust (isWithP p) = if | k == 0 -> ([] , p:ps)
src/full/Agda/Syntax/Concrete/Pretty.hs view
@@ -1,5 +1,9 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-} +{-# OPTIONS_GHC -Wno-orphans #-}+ {-| Pretty printer for the concrete syntax. -} module Agda.Syntax.Concrete.Pretty@@ -11,18 +15,15 @@ import Data.Maybe import qualified Data.Foldable as Fold-import qualified Data.Semigroup as Semigroup import qualified Data.Strict.Maybe as Strict-import qualified Data.Text as T import Agda.Syntax.Common import Agda.Syntax.Concrete import Agda.Syntax.Concrete.Glyph -import Agda.Utils.Float (toStringWithoutDotZero) import Agda.Utils.Function import Agda.Utils.Functor-import Agda.Utils.List1 ( List1, pattern (:|), (<|) )+import Agda.Utils.List1 ( List1, (<|) ) import qualified Agda.Utils.List1 as List1 import qualified Agda.Utils.List2 as List2 import Agda.Utils.Maybe@@ -77,9 +78,13 @@ prettyTactic' :: TacticAttribute -> Doc -> Doc prettyTactic' t = (pretty t <+>) +qualifier :: Pretty a => Maybe a -> Doc -> Doc+qualifier (Just x) k = pretty x <> dot <> k+qualifier Nothing k = k+ instance Pretty a => Pretty (TacticAttribute' a) where pretty (TacticAttribute t) =- ifNull (pretty t) empty \ d -> "@" <> parens ("tactic" <+> d)+ ifNull (pretty t) empty \ d -> "@" <> parens (hlKeyword "tactic" <+> d) instance Pretty (ThingWithFixity Name) where pretty (ThingWithFixity n _) = pretty n@@ -106,6 +111,7 @@ cohesion = case c of Flat{} -> Just "@♭" Continuous{} -> Nothing+ Sharp{} -> Just "@♯" Squash{} -> Just "@⊤" polarity = case modPolarityAnn p of MixedPolarity -> "@mixed"@@ -125,7 +131,7 @@ instance Pretty Expr where pretty = \case Ident x -> pretty x- KnownIdent nk x -> annotateAspect (Asp.Name (Just nk) False) (pretty x)+ KnownIdent nk x -> annotate nk (pretty x) Lit _ l -> pretty l QuestionMark _ n -> hlSymbol "?" <> maybe empty (text . show) n Underscore _ n -> maybe underscore text n@@ -137,8 +143,8 @@ -- , nest 2 $ fsep $ map pretty args -- ] RawApp _ es -> fsep $ map pretty $ List2.toList es- OpApp _ q _ es -> fsep $ prettyOpApp (Asp.Name Nothing True) q es- KnownOpApp nk _ q _ es -> fsep $ prettyOpApp (Asp.Name (Just nk) True) q es+ OpApp _ q _ es -> fsep $ prettyOpApp empty q es+ KnownOpApp nk _ q _ es -> fsep $ prettyOpApp nk q es WithApp _ e es -> fsep $ pretty e <| fmap ((hlSymbol "|" <+>) . pretty) es@@ -167,12 +173,11 @@ , maybe empty (\ e -> hlKeyword "in" <+> pretty e) me ] Paren _ e -> parens $ pretty e- IdiomBrackets _ es ->- case es of+ IdiomBrackets _ q es -> qualifier q case es of [] -> emptyIdiomBrkt [e] -> leftIdiomBrkt <+> pretty e <+> rightIdiomBrkt e:es -> leftIdiomBrkt <+> pretty e <+> fsep (map (("|" <+>) . pretty) es) <+> rightIdiomBrkt- DoBlock _ ss -> hlKeyword "do" <+> vcat (fmap pretty ss)+ DoBlock _ q ss -> qualifier q $ hlKeyword "do" <+> vcat (fmap pretty ss) As _ x e -> pretty x <> hlSymbol "@" <> pretty e Dot _ e -> hlSymbol "." <> pretty e DoubleDot _ e -> hlSymbol ".." <> pretty e@@ -181,15 +186,16 @@ sep [hlKeyword "record", bracesAndSemicolons (map pretty xs)] RecUpdate _ _ e xs -> sep [hlKeyword "record" <+> pretty e, bracesAndSemicolons (map pretty xs)]- Quote _ -> hlKeyword "quote"+ Quote _ -> hlKeyword "quote" QuoteTerm _ -> hlKeyword "quoteTerm"- Unquote _ -> hlKeyword "unquote"+ Unquote _ -> hlKeyword "unquote" Tactic _ t -> hlKeyword "tactic" <+> pretty t -- Andreas, 2011-10-03 print irrelevant things as .(e) DontCare e -> hlSymbol "." <> parens (pretty e) Equal _ a b -> pretty a <+> equals <+> pretty b Ellipsis _ -> hlSymbol "..." Generalized e -> pretty e+ Highlighted a e -> annotate a (pretty e) where absurd NotHidden = parens mempty absurd Instance{} = dbraces mempty@@ -199,7 +205,7 @@ pretty = either pretty pretty instance Pretty a => Pretty (FieldAssignment' a) where- pretty (FieldAssignment x e) = sep [ pretty x <+> "=" , nest 2 $ pretty e ]+ pretty (FieldAssignment x e) = sep [ pretty x <+> equals, nest 2 $ pretty e ] instance Pretty ModuleAssignment where pretty (ModuleAssignment m es i) = fsep (pretty m : map pretty es) <+> pretty i@@ -239,10 +245,10 @@ instance Pretty NamedBinding where pretty (NamedBinding withH- x@(Arg (ArgInfo h (Modality r q c p) _o _fv (Annotation lock))+ x@(Arg (ArgInfo h (Modality r q c p) _o _fv (Annotation lock rew)) (Named _mn xb@(Binder _mp _ (BName _y _fix t _fin))))) = applyWhen withH prH $- applyWhenJust (isLabeled x) (\ l -> (text l <+>) . ("=" <+>)) (pretty xb)+ applyWhenJust (isLabeled x) (\ l -> (text l <+>) . (equals <+>)) (pretty xb) -- isLabeled looks at _mn and _y -- pretty xb prints also the pattern _mp where@@ -253,11 +259,13 @@ . (pol <+>) . (lck <+>) . (tac <+>)+ . (rw <+>) coh = pretty c qnt = pretty q pol = pretty p tac = pretty t lck = pretty lock+ rw = pretty rew -- Parentheses are needed when an attribute @... is printed mparens = applyUnless (null coh && null qnt && null lck && null tac && null pol) parens @@ -266,7 +274,7 @@ pretty (DomainFull b) = pretty b instance Pretty TypedBinding where- pretty (TLet _ ds) = parens $ "let" <+> vcat (fmap pretty ds)+ pretty (TLet _ ds) = parens $ hlKeyword "let" <+> vcat (fmap pretty ds) pretty (TBind _ xs (Underscore _ Nothing)) = fsep (fmap (pretty . NamedBinding True) xs) pretty (TBind _ xs e) = fsep@@ -277,9 +285,10 @@ $ prettyQuantity y $ prettyLock y $ prettyPolarity y- $ prettyTactic (binderName $ namedArg y) $+ $ prettyTactic (binderName $ namedArg y)+ $ prettyRewriteAnn y $ sep [ fsep (map (pretty . NamedBinding False) ys)- , ":" <+> pretty e ]+ , colon <+> pretty e ] | ys@(y : _) <- groupBinds $ List1.toList xs ] where groupBinds [] = []@@ -302,36 +311,36 @@ smashTel :: Telescope -> Telescope smashTel (TBind r xs e : TBind _ ys e' : tel)- | prettyShow e == prettyShow e' = smashTel (TBind r (xs Semigroup.<> ys) e : tel)+ | prettyShow e == prettyShow e' = smashTel (TBind r (xs <> ys) e : tel) smashTel (b : tel) = b : smashTel tel smashTel [] = [] instance Pretty RHS where- pretty (RHS e) = "=" <+> pretty e+ pretty (RHS e) = equals <+> pretty e pretty AbsurdRHS = empty instance Pretty WhereClause where pretty NoWhere = empty pretty (AnyWhere _ [Module _ NotErased{} x [] ds]) | isNoName (unqualify x)- = vcat [ "where", nest 2 (vcat $ map pretty ds) ]- pretty (AnyWhere _ ds) = vcat [ "where", nest 2 (vcat $ map pretty ds) ]+ = vcat [ hlKeyword "where", nest 2 (vcat $ map pretty ds) ]+ pretty (AnyWhere _ ds) = vcat [ hlKeyword "where", nest 2 (vcat $ map pretty ds) ] pretty (SomeWhere _ erased m a ds) = vcat [ hsep $ privateWhenUserWritten a- [ "module", prettyErased erased (pretty m), "where" ]+ [ hlKeyword "module", prettyErased erased (pretty m), hlKeyword "where" ] , nest 2 (vcat $ map pretty ds) ] where privateWhenUserWritten = \case- PrivateAccess _ UserWritten -> ("private" :)+ PrivateAccess _ UserWritten -> (hlKeyword "private" :) _ -> id instance Pretty LHS where pretty (LHS p eqs es) = sep [ pretty p , nest 2 $ if null eqs then empty else fsep $ map pretty eqs- , nest 2 $ prefixedThings "with" (map prettyWithd es)+ , nest 2 $ prefixedThings (hlKeyword "with") (map prettyWithd es) ] where prettyWithd :: WithExpr -> Doc@@ -339,7 +348,7 @@ let e = pretty wh in case nm of Nothing -> e- Just n -> pretty n <+> ":" <+> e+ Just n -> pretty n <+> colon <+> e instance Pretty LHSCore where pretty (LHSHead f ps) = sep $ pretty f : map (parens . pretty) ps@@ -349,31 +358,32 @@ pretty (LHSWith h wps ps) = if null ps then doc else sep $ parens doc : map (parens . pretty) ps where- doc = sep $ pretty h <$ fmap (("|" <+>) . pretty) wps- pretty (LHSEllipsis r p) = "..."+ doc = sep $ pretty h <$ fmap ((pipe <+>) . pretty) wps+ pretty (LHSEllipsis _ _) = "..." instance Pretty ModuleApplication where pretty (SectionApp _ bs x es) = fsep $ concat [ map pretty bs- , [ "=", pretty x ]+ , [ equals, pretty x ] , map pretty es ]- pretty (RecordModuleInstance _ x) = "=" <+> pretty x <+> "{{...}}"+ pretty (RecordModuleInstance _ x) = equals <+> pretty x <+> "{{...}}" instance Pretty DoStmt where pretty (DoBind _ p e cs) =- ((pretty p <+> "←") <?> pretty e) <?> prCs cs+ ((pretty p <+> fromArrow) <?> pretty e) <?> prCs cs where prCs [] = empty- prCs cs = "where" <?> vcat (map pretty cs)- pretty (DoThen e) = pretty e- pretty (DoLet _ ds) = "let" <+> vcat (fmap pretty ds)+ prCs cs = hlKeyword "where" <?> vcat (map pretty cs)+ pretty (DoThen e) = pretty e+ pretty (DoLet _ ds) = hlKeyword "let" <+> vcat (fmap pretty ds) instance Pretty Declaration where prettyList = vcat . map pretty pretty = \case TypeSig i tac x e ->- sep [ prettyTactic' tac $ prettyRelevance i $ prettyCohesion i $ prettyQuantity i $ prettyPolarity i $ pretty x <+> ":"+ sep [ prettyTactic' tac $ prettyRelevance i $ prettyCohesion i $+ prettyQuantity i $ prettyPolarity i $ pretty x <+> colon , nest 2 $ pretty e ] FieldSig inst tac x (Arg i e) ->@@ -382,54 +392,55 @@ prettyRelevance i $ prettyHiding i id $ pretty $ TypeSig (setRelevance relevant i) tac x e where- mkInst (InstanceDef _) d = sep [ "instance", nest 2 d ]+ mkInst (InstanceDef _) d = sep [ hlKeyword "instance", nest 2 d ] mkInst NotInstanceDef d = d - mkOverlap i d | isYesOverlap i = "overlap" <+> d+ mkOverlap i d | isYesOverlap i = hlKeyword "overlap" <+> d | otherwise = d Field _ fs ->- sep [ "field"+ sep [ hlKeyword "field" , nest 2 $ vcat (map pretty fs) ]- FunClause lhs rhs wh _ ->- sep [ pretty lhs+ FunClause ai lhs rhs wh _ ->+ sep [ pretty (getModality ai)+ , pretty lhs , nest 2 $ pretty rhs ] $$ nest 2 (pretty wh) DataSig _ erased x tel e ->- sep [ hsep [ "data"+ sep [ hsep [ hlKeyword "data" , prettyErased erased (pretty x) , fsep (map pretty tel) ] , nest 2 $ hsep- [ ":"+ [ colon , pretty e ] ] Data _ erased x tel e cs ->- sep [ hsep [ "data"+ sep [ hsep [ hlKeyword "data" , prettyErased erased (pretty x) , fsep (map pretty tel) ] , nest 2 $ hsep- [ ":"+ [ colon , pretty e- , "where"+ , hlKeyword "where" ] ] $$ nest 2 (vcat $ map pretty cs) DataDef _ x tel cs ->- sep [ hsep [ "data"+ sep [ hsep [ hlKeyword "data" , pretty x , fsep (map pretty tel) ]- , nest 2 $ "where"+ , nest 2 $ hlKeyword "where" ] $$ nest 2 (vcat $ map pretty cs) RecordSig _ erased x tel e ->- sep [ hsep [ "record"+ sep [ hsep [ hlKeyword "record" , prettyErased erased (pretty x) , fsep (map pretty tel) ] , nest 2 $ hsep- [ ":"+ [ colon , pretty e ] ]@@ -439,9 +450,9 @@ pRecord defaultErased x dir tel Nothing cs 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+ Syntax n _xs -> hlKeyword "syntax" <+> pretty n <+> "..."+ PatternSyn _ n as p -> hlKeyword "pattern" <+> pretty n <+> fsep (map pretty as)+ <+> equals <+> pretty p Mutual _ ds -> namedBlock "mutual" ds InterleavedMutual _ ds -> namedBlock "interleaved mutual" ds LoneConstructor _ ds -> namedBlock "data _ where" ds@@ -453,51 +464,51 @@ Primitive _ ds -> namedBlock "primitive" ds Generalize _ ds -> namedBlock "variable" ds Opaque _ ds -> namedBlock "opaque" ds- Unfolding _ rs -> "unfolding" <+> braces (fsep (punctuate semi (pretty <$> rs)))+ Unfolding _ rs -> hlKeyword "unfolding" <+> braces (fsep (punctuate semi (pretty <$> rs))) Module _ erased x tel ds ->- hsep [ "module"+ hsep [ hlKeyword "module" , prettyErased erased (pretty x) , fsep (map pretty tel)- , "where"+ , hlKeyword "where" ] $$ nest 2 (vcat $ map pretty ds)- ModuleMacro _ NotErased{} x (SectionApp _ [] y es) DoOpen i+ ModuleMacro _ NotErased{} x (SectionApp _ [] y es) doOpen@(DoOpen _kwr) i | isNoName x ->- sep [ pretty DoOpen+ sep [ pretty doOpen , nest 2 $ fsep $ pretty y : map pretty es , nest 4 $ pretty i ] ModuleMacro _ erased x (SectionApp _ tel y es) open i ->- sep [ pretty open <+> "module" <+>+ sep [ pretty open <+> hlKeyword "module" <+> prettyErased erased (pretty x) <+> fsep (map pretty tel)- , nest 2 $ fsep $ concat [ [ "=", pretty y ], map pretty es, [ pretty i ] ]+ , nest 2 $ fsep $ concat [ [ equals, pretty y ], map pretty es, [ pretty i ] ] ]- ModuleMacro _ erased x (RecordModuleInstance _ rec) open i ->- sep [ pretty open <+> "module" <+> prettyErased erased (pretty x)- , nest 2 $ "=" <+> pretty rec <+> "{{...}}"+ ModuleMacro _ erased x (RecordModuleInstance _ rec) open _i ->+ sep [ pretty open <+> hlKeyword "module" <+> prettyErased erased (pretty x)+ , nest 2 $ equals <+> 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 ]+ Open _ x i -> hsep [ hlKeyword "open", pretty x, pretty i ]+ Import open _ x rn i ->+ hsep [ pretty open, hlKeyword "import", pretty x, as rn, pretty i ] where- as Nothing = empty- as (Just x) = "as" <+> pretty (asName x)+ as (Left x) = hlKeyword "as" <+> pretty (asName x)+ as (Right args) = fsep (map pretty args) UnquoteDecl _ xs t ->- sep [ "unquoteDecl" <+> fsep (map pretty xs) <+> "=", nest 2 $ pretty t ]+ sep [ hlKeyword "unquoteDecl" <+> fsep (map pretty xs) <+> equals, nest 2 $ pretty t ] UnquoteDef _ xs t ->- sep [ "unquoteDef" <+> fsep (map pretty xs) <+> "=", nest 2 $ pretty t ]+ sep [ hlKeyword "unquoteDef" <+> fsep (map pretty xs) <+> equals, nest 2 $ pretty t ] UnquoteData _ x xs t ->- sep [ "unquoteData" <+> pretty x <+> fsep (map pretty xs) <+> "=", nest 2 $ pretty t ]+ sep [ hlKeyword "unquoteData" <+> pretty x <+> fsep (map pretty xs) <+> equals, nest 2 $ pretty t ] Pragma pr -> sep [ "{-#" <+> pretty pr, "#-}" ] where namedBlock s ds =- sep [ text s+ sep [ hlKeyword (text s) , nest 2 $ vcat $ map pretty ds ] pHasEta0 :: HasEta0 -> Doc pHasEta0 = \case- YesEta -> "eta-equality"- NoEta () -> "no-eta-equality"+ YesEta -> hlKeyword "eta-equality"+ NoEta () -> hlKeyword "no-eta-equality" instance Pretty RecordDirective where pretty = pRecordDirective@@ -505,24 +516,24 @@ pRecordDirective :: RecordDirective -> Doc pRecordDirective = \case Induction ind -> pretty (rangedThing ind)- Constructor n inst -> hsep [ pInst, "constructor", pretty n ] where+ Constructor n inst -> hsep [ pInst, hlKeyword "constructor", pretty n ] where pInst = case inst of- InstanceDef{} -> "instance"+ InstanceDef{} -> hlKeyword "instance" NotInstanceDef{} -> empty Eta eta -> pHasEta0 (rangedThing eta)- PatternOrCopattern{} -> "pattern"+ PatternOrCopattern{} -> hlKeyword "pattern" pRecord :: Erased -> Name -> [RecordDirective]- -> [LamBinding]+ -> Parameters -> Maybe Expr -> [Declaration] -> Doc pRecord erased x directives tel me ds = vcat [ sep- [ hsep [ "record"+ [ hsep [ hlKeyword "record" , prettyErased erased (pretty x) , fsep (map pretty tel) ]@@ -533,97 +544,83 @@ , map pretty ds ] ]- where pType (Just e) = hsep- [ ":"- , pretty e- , "where"- ]- pType Nothing =- "where"+ where+ pType (Just e) = hsep [ colon, pretty e, hlKeyword "where" ]+ pType Nothing = hlKeyword "where" instance Pretty OpenShortHand where- pretty DoOpen = "open"- pretty DontOpen = empty+ pretty = \case+ DoOpen _ -> hlKeyword "open"+ DontOpen -> empty instance Pretty Pragma where- pretty (OptionsPragma _ opts) = fsep $ map text $ "OPTIONS" : opts- pretty (BuiltinPragma _ b x) = hsep [ "BUILTIN", text (rangedThing b), pretty x ]+ pretty (OptionsPragma _ opts) = fsep $ hlKeyword "OPTIONS" : map (hlPragma . text) opts+ pretty (BuiltinPragma _ b x) = hsep [ hlKeyword "BUILTIN", hlPragma (text (rangedThing b)), pretty x ] pretty (RewritePragma _ _ xs) =- hsep [ "REWRITE", hsep $ map pretty xs ]+ hsep [ hlKeyword "REWRITE", hsep $ map pretty xs ] pretty (CompilePragma _ b x e) =- hsep [ "COMPILE", pretty (rangedThing b), pretty x, textNonEmpty e ]+ hsep [ hlKeyword "COMPILE", pretty (rangedThing b), pretty x, textNonEmpty e ] pretty (ForeignPragma _ b s) =- vcat $ hsep [ "FOREIGN", pretty (rangedThing b) ] : map text (lines s)+ vcat $ hsep [ hlKeyword "FOREIGN", pretty (rangedThing b) ] : map text (lines s) pretty (StaticPragma _ i) =- hsep $ ["STATIC", pretty i]+ hsep $ [hlKeyword "STATIC", pretty i] pretty (InjectivePragma _ i) =- hsep $ ["INJECTIVE", pretty i]+ hsep $ [hlKeyword "INJECTIVE", pretty i] pretty (InjectiveForInferencePragma _ i) =- hsep $ ["INJECTIVE_FOR_INFERENCE", pretty i]+ hsep $ [hlKeyword "INJECTIVE_FOR_INFERENCE", pretty i] pretty (InlinePragma _ True i) =- hsep $ ["INLINE", pretty i]+ hsep $ [hlKeyword "INLINE", pretty i] pretty (NotProjectionLikePragma _ i) =- hsep $ ["NOT_PROJECTION_LIKE", pretty i]+ hsep $ [hlKeyword "NOT_PROJECTION_LIKE", pretty i] pretty (InlinePragma _ False i) =- hsep $ ["NOINLINE", pretty i]+ hsep $ [hlKeyword "NOINLINE", pretty i] pretty (ImpossiblePragma _ strs) =- hsep $ ["IMPOSSIBLE"] ++ map text strs+ hsep $ [hlKeyword "IMPOSSIBLE"] ++ map text strs pretty (EtaPragma _ x) =- hsep $ ["ETA", pretty x]+ hsep $ [hlKeyword "ETA", pretty x]+ pretty (EtaEqualityPragma _) =+ hsep $ [hlKeyword "ETA_EQUALITY"] pretty (TerminationCheckPragma _ tc) = case tc of TerminationCheck -> __IMPOSSIBLE__- NoTerminationCheck -> "NO_TERMINATION_CHECK"- NonTerminating -> "NON_TERMINATING"- Terminating -> "TERMINATING"- TerminationMeasure _ x -> hsep $ ["MEASURE", pretty x]- pretty (NoCoverageCheckPragma _) = "NON_COVERING"- pretty (WarningOnUsage _ nm str) = hsep [ "WARNING_ON_USAGE", pretty nm, text (show str) ]- pretty (WarningOnImport _ str) = hsep [ "WARNING_ON_IMPORT", text (show str) ]- pretty (CatchallPragma _) = "CATCHALL"- pretty (DisplayPragma _ lhs rhs) = "DISPLAY" <+> sep [ pretty lhs <+> "=", nest 2 $ pretty rhs ]- pretty (NoPositivityCheckPragma _) = "NO_POSITIVITY_CHECK"+ NoTerminationCheck -> hlKeyword "NO_TERMINATION_CHECK"+ NonTerminating -> hlKeyword "NON_TERMINATING"+ Terminating -> hlKeyword "TERMINATING"+ TerminationMeasure _ x -> hsep $ [hlKeyword "MEASURE", pretty x]+ pretty (NoCoverageCheckPragma _) = hlKeyword "NON_COVERING"+ pretty (WarningOnUsage _ nm str) = hsep [ hlKeyword "WARNING_ON_USAGE", pretty nm, hlPragma (text (show str)) ]+ pretty (WarningOnImport _ str) = hsep [ hlKeyword "WARNING_ON_IMPORT", hlPragma (text (show str)) ]+ pretty (CatchallPragma _) = hlKeyword "CATCHALL"+ pretty (DisplayPragma _ lhs rhs) = hlKeyword "DISPLAY" <+> sep [ pretty lhs <+> equals, nest 2 $ pretty rhs ]+ pretty (NoPositivityCheckPragma _) = hlKeyword "NO_POSITIVITY_CHECK" pretty (PolarityPragma _ q occs) =- hsep ("POLARITY" : pretty q : map pretty occs)- pretty (NoUniverseCheckPragma _) = "NO_UNIVERSE_CHECK"+ hsep (hlKeyword "POLARITY" : pretty q : map pretty occs)+ pretty (NoUniverseCheckPragma _) = hlKeyword "NO_UNIVERSE_CHECK" pretty (OverlapPragma _ x m) = hsep [pretty m, pretty x] -instance Pretty NotationPart where- pretty (IdPart x) = text $ rangedThing x- pretty HolePart{} = underscore- pretty VarPart{} = underscore- pretty WildPart{} = underscore-- prettyList = hcat . map pretty--instance Pretty Fixity' where- pretty (Fixity' fix nota _range)- | null nota = pretty fix- | otherwise = "syntax" <+> pretty nota- instance Pretty Pattern where prettyList = fsep . map pretty pretty = \case IdentP _ x -> pretty x AppP p1 p2 -> sep [ pretty p1, nest 2 $ pretty p2 ] RawAppP _ ps -> fsep $ map pretty $ List2.toList ps- OpAppP _ q _ ps -> fsep $ prettyOpApp (Asp.Name Nothing True) q $ fmap (fmap (fmap (NoPlaceholder Strict.Nothing))) ps+ OpAppP _ q _ ps -> fsep $ prettyOpApp empty q $ fmap (fmap (fmap (NoPlaceholder Strict.Nothing))) ps HiddenP _ p -> braces' $ pretty p InstanceP _ p -> dbraces $ pretty p ParenP _ p -> parens $ pretty p WildP _ -> underscore- AsP _ x p -> pretty x <> "@" <> pretty p- DotP _ _ p -> "." <> pretty p+ AsP _ x p -> pretty x <> hlSymbol "@" <> pretty p+ DotP _ _ _ p -> "." <> pretty p AbsurdP _ -> "()" LitP _ l -> pretty l- QuoteP _ -> "quote"- RecP _ _ fs -> sep [ "record", bracesAndSemicolons (map pretty fs) ]- EqualP _ es -> sep $ for es \ (e1, e2) -> parens $ sep [pretty e1, "=", pretty e2]- EllipsisP _ mp -> "..."+ QuoteP _ -> hlKeyword "quote"+ RecP _ _ fs -> sep [ hlKeyword "record", bracesAndSemicolons (map pretty fs) ]+ EqualP _ es -> sep $ for es \ (e1, e2) -> parens $ sep [pretty e1, equals, pretty e2]+ EllipsisP _ _ -> "..." WithP _ p -> "|" <+> pretty p prettyOpApp :: forall a .- Pretty a => Asp.Aspect -> QName -> List1 (NamedArg (MaybePlaceholder a)) -> [Doc]+ Pretty a => Asp.Aspects -> QName -> List1 (NamedArg (MaybePlaceholder a)) -> [Doc] prettyOpApp asp q es = merge [] $ prOp ms xs $ List1.toList es where -- ms: the module part of the name.@@ -640,7 +637,7 @@ NoPlaceholder{} -> (pretty e, Nothing) : prOp ms xs es -- Module qualifier needs to go on section holes (#3072) prOp _ (Hole : _) [] = __IMPOSSIBLE__- prOp ms (Id x : xs) es = ( qual ms $ annotateAspect asp $ pretty $ simpleName x+ prOp ms (Id x : xs) es = ( qual ms $ annotate asp $ pretty $ simpleName x , Nothing ) : prOp [] xs es -- Qualify the name part with the module.
src/full/Agda/Syntax/DoNotation.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-} {-| Desugaring for do-notation. Uses whatever `_>>=_` and `_>>_` happen to be@@ -46,14 +47,18 @@ import Agda.Utils.Impossible -desugarDoNotation :: Range -> List1 DoStmt -> ScopeM Expr-desugarDoNotation r ss = do- let qBind = QName $ simpleBinaryOperator ">>="- qThen = QName $ simpleBinaryOperator ">>"- isBind DoBind{} = True- isBind _ = False- isThen DoThen{} = True- isThen _ = False+desugarDoNotation :: Maybe QName -> List1 DoStmt -> ScopeM Expr+desugarDoNotation mod ss = do+ let+ qBind = maybe QName qualify mod $ simpleBinaryOperator ">>="+ qThen = maybe QName qualify mod $ simpleBinaryOperator ">>"++ isBind DoBind{} = True+ isBind _ = False++ isThen DoThen{} = True+ isThen _ = False+ -- Only check the operation we actually need. One could imagine to fall back -- on _>>=_ if _>>_ is not in scope, but if we are desugaring to _>>_ at all -- I think we should throw an error rather than silently switching to _>>=_.
src/full/Agda/Syntax/Fixity.hs view
@@ -1,4 +1,6 @@ {-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-} {-| Definitions for fixity, precedence levels, and declared syntax. -}
src/full/Agda/Syntax/IdiomBrackets.hs view
@@ -1,3 +1,6 @@+{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+ module Agda.Syntax.IdiomBrackets (parseIdiomBracketsSeq) where import Control.Monad@@ -16,23 +19,23 @@ import Agda.Syntax.Common.Pretty ( prettyShow ) import Agda.Utils.Singleton -parseIdiomBracketsSeq :: Range -> [Expr] -> ScopeM Expr-parseIdiomBracketsSeq r es = do- let qEmpty = QName $ simpleName "empty"- qPlus = QName $ simpleBinaryOperator "<|>"+parseIdiomBracketsSeq :: Range -> Maybe QName -> [Expr] -> ScopeM Expr+parseIdiomBracketsSeq r mod es = do+ let qEmpty = maybe QName qualify mod $ simpleName "empty"+ qPlus = maybe QName qualify mod $ simpleBinaryOperator "<|>" ePlus a b = App r (App r (Ident qPlus) (defaultNamedArg a)) (defaultNamedArg b) case es of [] -> ensureInScope qEmpty >> return (Ident qEmpty)- [e] -> parseIdiomBrackets r e+ [e] -> parseIdiomBrackets r mod e es@(_:_) -> do ensureInScope qPlus- es' <- mapM (parseIdiomBrackets r) es+ es' <- mapM (parseIdiomBrackets r mod) es return $ foldr1 ePlus es' -parseIdiomBrackets :: Range -> Expr -> ScopeM Expr-parseIdiomBrackets r e = do- let qPure = QName $ simpleName "pure"- qAp = QName $ simpleBinaryOperator "<*>"+parseIdiomBrackets :: Range -> Maybe QName -> Expr -> ScopeM Expr+parseIdiomBrackets r mod e = do+ let qPure = maybe QName qualify mod $ simpleName "pure"+ qAp = maybe QName qualify mod $ simpleBinaryOperator "<*>" ePure = App r (Ident qPure) . defaultNamedArg eAp a b = App r (App r (Ident qAp) (defaultNamedArg a)) (defaultNamedArg b) mapM_ ensureInScope [qPure, qAp]
src/full/Agda/Syntax/Info.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-} {-| An info object contains additional information about a piece of abstract syntax that isn't part of the actual syntax. For instance, it might contain@@ -11,8 +13,6 @@ import Control.DeepSeq -import Data.Semigroup (Semigroup)- import GHC.Generics (Generic) import qualified Agda.Syntax.Concrete.Name as C@@ -98,7 +98,7 @@ getRange (ExprRange r) = r instance KillRange ExprInfo where- killRange (ExprRange r) = exprNoRange+ killRange (ExprRange _) = exprNoRange {-------------------------------------------------------------------------- Application information@@ -146,7 +146,7 @@ -- if any. Retained for highlighting purposes. , minfoAsName :: Maybe C.Name -- ^ The \"as\" module name, if any. Retained for highlighting purposes.- , minfoOpenShort :: Maybe OpenShortHand+ , minfoOpenShort :: OpenShortHand , minfoDirective :: Maybe ImportDirective -- ^ Retained for @abstractToConcrete@ of 'ModuleMacro'. }@@ -174,7 +174,7 @@ getRange (LetRange r) = r instance KillRange LetInfo where- killRange (LetRange r) = LetRange noRange+ killRange (LetRange _) = LetRange noRange {-------------------------------------------------------------------------- Definition information (declarations that actually define something)@@ -205,7 +205,7 @@ instance SetRange (DefInfo' t) where setRange r i = i { defInfo = setRange r (defInfo i) } -instance KillRange t => KillRange (DefInfo' t) where+instance KillRange (DefInfo' t) where killRange i = i { defInfo = killRange $ defInfo i, defTactic = killRange $ defTactic i } @@ -281,7 +281,7 @@ getRange (LHSInfo r _) = r instance KillRange LHSInfo where- killRange (LHSInfo r ell) = LHSInfo noRange ell+ killRange (LHSInfo _ ell) = LHSInfo noRange ell instance Null LHSInfo where null i = null (lhsRange i) && null (lhsEllipsis i)@@ -320,7 +320,7 @@ killRange (ConPatInfo b i l) = ConPatInfo b (killRange i) l instance SetRange ConPatInfo where- setRange r (ConPatInfo b i l) = ConPatInfo b (PatRange r) l+ setRange r (ConPatInfo b _ l) = ConPatInfo b (PatRange r) l instance NFData ConPatInfo
src/full/Agda/Syntax/Internal.hs view
@@ -1,3 +1,9 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE MagicHash #-}+{-# OPTIONS_GHC -Wunused-imports #-}+-- {-# OPTIONS_GHC -Wunused-matches #-} module Agda.Syntax.Internal ( module Agda.Syntax.Internal@@ -12,11 +18,12 @@ import Control.Monad.Identity import Control.DeepSeq+import GHC.Exts -import Data.Function (on) import qualified Data.List as List import Data.Maybe-import Data.Semigroup ( Semigroup, (<>), Sum(..) )+import Data.Semigroup ( Sum(..) )+import System.IO.Unsafe (unsafePerformIO) import GHC.Generics (Generic) @@ -40,9 +47,13 @@ import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.Lens+import Agda.Utils.List+import Agda.Utils.List1 (List1) import Agda.Utils.Null import Agda.Utils.Size-import Agda.Utils.Tuple+import Agda.Utils.ExpandCase+import qualified Agda.Utils.CompactRegion as Compact+import qualified Agda.Utils.MinimalArray.Lifted as AL import Agda.Utils.Impossible @@ -50,6 +61,85 @@ -- * Function type domain --------------------------------------------------------------------------- +data RewDom' t = RewDom+ { rewDomEq :: LocalEquation' t+ -- ^ Elaborated "@rewrite" equation+ , rewDomRew :: Maybe RewriteRule+ -- ^ "@rewrite" equation transformed into a directed rewrite rule.+ --+ -- @Nothing@ iff invalidated by a substitution. If we are checking+ -- against an "@rewrite" domain, this is fine, but if we are inside an "@rewrite"+ -- context, this is probably an internal error.+ } deriving (Show, Generic)++type RewDom = RewDom' Term++data DomInfo t = DomInfo {+ domInfoArgInfo :: ArgInfo+ , domInfoName :: (Maybe NamedName)+ -- ^ e.g. @x@ in @{x = y : A} -> B@.+ , domInfoIsFinite :: Bool+ -- ^ Is this a Π-type (False), or a partial type (True)?+ , domInfoTactic :: (Maybe t)+ -- ^ "@tactic e".+ , domInfoRew :: (Maybe (RewDom' t))+ -- ^ Elaborated "@rewrite" equation+ --+ -- Will only be present if domain annotated with "@rewrite" (@annRewrite@+ -- is @IsRewrite@) AND the type successfully elaborated into a rewrite rule.+ }++instance Show t => Show (DomInfo t) where+ show (DomInfo a b c d e) = show (a,b,c,d,e)++{-# INLINE domInfo #-}+domInfo :: Dom' t e -> ArgInfo+domInfo d = domInfoArgInfo (domDomInfo d)++{-# INLINE dInfo #-}+dInfo :: Lens' (Dom' t e) ArgInfo+dInfo = \f d ->+ f (domInfo d) <&> \x -> d {domDomInfo = (domDomInfo d){domInfoArgInfo = x}}++{-# INLINE domName #-}+domName :: Dom' t e -> Maybe NamedName+domName d = domInfoName (domDomInfo d)++{-# INLINE dName #-}+dName :: Lens' (Dom' t e) (Maybe NamedName)+dName = \f d ->+ f (domName d) <&> \x -> d {domDomInfo = (domDomInfo d){domInfoName = x}}++{-# INLINE domIsFinite #-}+domIsFinite :: Dom' t e -> Bool+domIsFinite d =+ domInfoIsFinite (domDomInfo d)++{-# INLINE dIsFinite #-}+dIsFinite :: Lens' (Dom' t e) Bool+dIsFinite = \f d ->+ f (domIsFinite d) <&> \x -> d {domDomInfo = (domDomInfo d){domInfoIsFinite = x}}++{-# INLINE domTactic #-}+domTactic :: Dom' t e -> Maybe t+domTactic d =+ domInfoTactic (domDomInfo d)++{-# INLINE dTactic #-}+dTactic :: Lens' (Dom' t e) (Maybe t)+dTactic = \f d ->+ f (domTactic d) <&> \x -> d {domDomInfo = (domDomInfo d){domInfoTactic = x}}++{-# INLINE rewDom #-}+rewDom :: Dom' t e -> Maybe (RewDom' t)+rewDom d =+ domInfoRew (domDomInfo d)++{-# INLINE dRew #-}+dRew :: Lens' (Dom' t e) (Maybe (RewDom' t))+dRew = \f d ->+ f (rewDom d) <&> \x -> d {domDomInfo = (domDomInfo d){domInfoRew = x}}+ -- | Similar to 'Arg', but we need to distinguish -- an irrelevance annotation in a function domain -- (the domain itself is not irrelevant!)@@ -64,44 +154,72 @@ -- 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- , 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 (Show, Functor, Foldable, Traversable)+data Dom' t e = Dom'+ { domDomInfo :: !(DomInfo t)+ , unDom :: e+ } deriving (Show, Foldable, Traversable) +pattern Dom :: ArgInfo -> Maybe NamedName -> Bool -> Maybe t -> Maybe (RewDom' t) -> e -> Dom' t e+pattern Dom a b c d e f = Dom' (DomInfo a b c d e) f+{-# INLINE Dom #-}+{-# COMPLETE Dom #-}++instance Functor (Dom' t) where+ {-# INLINE fmap #-}+ fmap fn = \(Dom a b c d e f) -> Dom a b c d e $! fn f+ type Dom = Dom' Term +{-# INLINE domEq #-}+domEq :: Dom' t e -> Maybe (LocalEquation' t)+domEq = fmap rewDomEq . rewDom++-- | Is this Dom annotated as a local rewrite rule and if so, has the rewrite+-- been invalidated due to a substitution?+invalidRew :: Dom' t e -> Bool+invalidRew d = case rewDom d of+ Just (RewDom {rewDomRew = Nothing}) -> True+ _ -> False++ instance Decoration (Dom' t) where- traverseF f (Dom ai x t b a) = Dom ai x t b <$> f a+ traverseF f (Dom ai x t b r a) = Dom ai x t b r <$> f a instance HasRange a => HasRange (Dom' t a) where getRange = getRange . unDom +instance KillRange t => KillRange (RewDom' t) where+ killRange (RewDom eq rew) = killRangeN RewDom eq rew+ instance (KillRange t, KillRange a) => KillRange (Dom' t a) where- killRange (Dom info x t b a) = killRangeN Dom info x t b a+ killRange (Dom info x t b r a) = killRangeN Dom info x t b r a -- | Ignores 'Origin' and 'FreeVariables' and tactic. instance Eq a => Eq (Dom' t a) where- Dom (ArgInfo h1 m1 _ _ a1) s1 f1 _ x1 == Dom (ArgInfo h2 m2 _ _ a2) s2 f2 _ 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- lensNamed f dom = f (domName dom) <&> \ nm -> dom { domName = nm }+ {-# INLINE lensNamed #-}+ lensNamed = \f dom ->+ f (domName dom) <&> \ nm -> dom { domDomInfo = (domDomInfo dom){domInfoName = nm }} instance LensArgInfo (Dom' t e) where getArgInfo = domInfo- setArgInfo ai dom = dom { domInfo = ai }- mapArgInfo f dom = dom { domInfo = f $ domInfo dom }+ setArgInfo ai dom = dom { domDomInfo = (domDomInfo dom) {domInfoArgInfo = ai} } instance LensLock (Dom' t e) where getLock = getLock . getArgInfo setLock = mapArgInfo . setLock +instance LensRewriteAnn (Dom' t e) where+ getRewriteAnn = getRewriteAnn . getArgInfo+ setRewriteAnn = mapRewriteAnn . setRewriteAnn++instance LensLocalEquation (Dom e) where+ getLocalEq = domEq+ -- The other lenses are defined through LensArgInfo instance LensHiding (Dom' t e) where@@ -118,56 +236,47 @@ instance LensModalPolarity (Dom' t e) where argFromDom :: Dom' t a -> Arg a-argFromDom Dom{domInfo = i, unDom = a} = Arg i a+argFromDom d = let !i = domInfo d in Arg i (unDom d) namedArgFromDom :: Dom' t a -> NamedArg a-namedArgFromDom Dom{domInfo = i, domName = s, unDom = a} = Arg i $ Named s a+namedArgFromDom d =+ let !i = domInfo d+ !s = domName d+ in Arg i $ Named s (unDom d) -- The following functions are less general than they could be: -- @Dom@ could be replaced by @Dom' t@. -- However, this causes problems with instance resolution in several places. -- often for class AddContext. +domFromArgRew :: Maybe RewDom -> Arg a -> Dom a+domFromArgRew rew (Arg i a) = Dom i Nothing False Nothing rew a+ domFromArg :: Arg a -> Dom a-domFromArg (Arg i a) = Dom i Nothing False Nothing a+domFromArg = domFromArgRew Nothing domFromNamedArg :: NamedArg a -> Dom a-domFromNamedArg (Arg i a) = Dom i (nameOf a) False Nothing (namedThing a)+domFromNamedArg (Arg i a) = Dom i (nameOf a) False Nothing Nothing (namedThing a) defaultDom :: a -> Dom a defaultDom = defaultArgDom defaultArgInfo +defaultArgDomRew :: ArgInfo -> Maybe RewDom -> a -> Dom a+defaultArgDomRew info rew x = domFromArgRew rew (Arg info x)+ defaultArgDom :: ArgInfo -> a -> Dom a-defaultArgDom info x = domFromArg (Arg info x)+defaultArgDom info = defaultArgDomRew info Nothing defaultNamedArgDom :: ArgInfo -> String -> a -> Dom a-defaultNamedArgDom info s x = (defaultArgDom info x) { domName = Just $ WithOrigin Inserted $ unranged s }+defaultNamedArgDom info (unranged -> !s) x =+ set lensNamed (Just $ WithOrigin Inserted s) (defaultArgDom info x) -- | Type of argument lists. -- type Args = [Arg Term] type NamedArgs = [NamedArg Term]--data DataOrRecord' p- = IsData- | IsRecord p- deriving (Show, Eq, Generic)--type DataOrRecord = DataOrRecord' PatternOrCopattern-type DataOrRecord_ = DataOrRecord' ()--pattern IsRecord_ :: DataOrRecord_-pattern IsRecord_ = IsRecord ()--instance PatternMatchingAllowed DataOrRecord where- patternMatchingAllowed = \case- IsData -> True- IsRecord patCopat -> patternMatchingAllowed patCopat--instance CopatternMatchingAllowed DataOrRecord where- copatternMatchingAllowed = \case- IsData -> False- IsRecord patCopat -> copatternMatchingAllowed patCopat+type Args1 = List1 (Arg Term)+type NamedArgs1 = List1 (NamedArg Term) -- | Store the names of the record fields in the constructor. -- This allows reduction of projection redexes outside of TCM.@@ -176,6 +285,7 @@ { conName :: QName -- ^ The name of the constructor. , conDataRecord :: DataOrRecord -- ^ Data or record constructor? , conInductive :: Induction -- ^ Record constructors can be coinductive.+ , conIsHIT :: IsHIT -- ^ Is the datatype of this constructor a HIT? , 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).@@ -211,6 +321,21 @@ setConName c con = con { conName = c } +-- | Terms used for internal purposes+data DummyTermKind+ = DummyNamed String+ -- ^ Generic dummy term, the 'String' generally describes where the+ -- term was generated (as well as giving a disambiguator).+ --+ -- Should not be used to convey actual information.++ | DummyBrave Term+ -- ^ Collects applications to a 'BraveTerm'.+ deriving Show++instance IsString DummyTermKind where+ fromString = DummyNamed+ -- | Raw values. -- -- @Def@ is used for both defined and undefined constants.@@ -218,7 +343,7 @@ -- every constant, even if the definition is an empty -- list of clauses. ---data Term = Var {-# UNPACK #-} !Int Elims -- ^ @x es@ neutral+data Term = Var' {-# UNPACK #-} !Int Elims -- ^ @x es@ neutral | Lam ArgInfo (Abs Term) -- ^ Terms are beta normal. Relevance is ignored | Lit Literal | Def QName Elims -- ^ @f es@, possibly a delta/iota-redex@@ -234,18 +359,56 @@ -- ^ Irrelevant stuff in relevant position, but created -- in an irrelevant context. Basically, an internal -- version of the irrelevance axiom @.irrAx : .A -> A@.- | Dummy String Elims+ | Dummy DummyTermKind Elims -- ^ A (part of a) term or type which is only used for internal purposes.- -- Replaces the @Sort Prop@ hack.- -- The @String@ typically describes the location where we create this dummy,- -- but can contain other information as well.- -- The second field accumulates eliminations in case we- -- apply a dummy term to more of them. Dummy terms should never be used in places- -- 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.+ --+ -- The 'DummyTermKind' describes why this dummy was created;+ -- typically, it is a string describing the source location+ -- that created it, but dummy terms are also used when+ -- *leaving* the type checker (through reification) to+ -- convey out-of-band information.+ --+ -- The second field accumulates eliminations in case we+ -- apply a dummy term to more of them. Dummy terms should+ -- never be used in places 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 Show +-- Caching small variables+--------------------------------------------------------------------------------++{-# NOINLINE varTable #-}+varTable :: AL.Array Term+varTable = unsafePerformIO $ do+ !c <- Compact.new 4096+ let !tbl = AL.fromList [Var' i [] | i <- [0..(varTableSize - 1)]]+ Compact.add c tbl++pattern Var :: Int -> Elims -> Term+pattern Var i es <- Var' i es where+ Var i es = case es of+ [] -> case i < varTableSize of+ True -> AL.unsafeIndex varTable i+ _ -> Var' i es+ _ -> Var' i es+{-# INLINE Var #-}+{-# COMPLETE Var, Lam, Lit, Def, Con, Pi, Sort, Level, MetaV, DontCare, Dummy #-}++{-# INLINE varTableSize #-}+varTableSize :: Int+varTableSize = 128++-- | An unapplied variable.+var :: Nat -> Term+var i | i >= 0 = case i < varTableSize of+ True -> AL.unsafeIndex varTable i+ _ -> Var' i []+ | otherwise = __IMPOSSIBLE__++--------------------------------------------------------------------------------+ type ConInfo = ConOrigin type Elim = Elim' Term@@ -261,8 +424,13 @@ -- ^ The body has (at least) one free variable. -- Danger: 'unAbs' doesn't shift variables properly | NoAbs { absName :: ArgName, unAbs :: a }- deriving (Functor, Foldable, Traversable, Generic)+ deriving (Foldable, Traversable, Generic) +instance Functor Abs where+ fmap f = \case+ Abs x y -> Abs x $! f y+ NoAbs x y -> NoAbs x $! f y+ instance Decoration Abs where traverseF f (Abs x a) = Abs x <$> f a traverseF f (NoAbs x a) = NoAbs x <$> f a@@ -302,9 +470,11 @@ -- | Sequence of types. An argument of the first type is bound in later types -- and so on. data Tele a = EmptyTel- | ExtendTel a (Abs (Tele a)) -- ^ 'Abs' is never 'NoAbs'.+ | ExtendTel a !(Abs (Tele a)) -- ^ 'Abs' is never 'NoAbs'. deriving (Show, Functor, Foldable, Traversable, Generic) +instance ExpandCase (Tele a) where type Result (Tele a) = Tele a+ type Telescope = Tele (Dom Type) data UnivSize@@ -312,6 +482,33 @@ | ULarge -- ^ @(Prop/Set/SSet)ωᵢ@. deriving stock (Eq, Show) +-- | Blocked dependency (i.e. free zero variable) check, used in 'PiSort'.+--+-- For efficiency, we track whether the codomain sort has actually changed.+-- If it hasn't, we can avoid duplicating work.+data BlockedDepCheck t+ = CodomainSortSame+ -- ^ The codomain sort has not changed, so we can just do the dependency+ -- check on the current codomain sort.+ | CodomainSortOld t+ -- ^ The codomain sort has changed, so we really need to do the dependency+ -- check on the original codomain sort.+ --+ -- E.g. see #5810: @∀ t → Set (ℓ t)@ has codomain sort @Set (lsuc (ℓ t))@+ -- but then after the substitution @ℓ ↦ λ _ → lzero@, the codomain sort+ -- becomes @Set (lsuc lzero)@, which is no longer dependent on @t@.+ -- To avoid a subject reduction problem, we have to remember that the+ -- codomain sort before the substitution was @Set (lsuc (ℓ t))@.+ --+ -- The old codomain sort lives in its original context. In an ideal world,+ -- we would store this context, but this does not appear very feasible+ -- (without a significant refactor).+ deriving (Show, Functor, Foldable, Traversable, Generic)++codomainSortOld :: t -> BlockedDepCheck t -> t+codomainSortOld s (CodomainSortOld s') = s'+codomainSortOld s CodomainSortSame = s+ -- | Sorts. -- data Sort' t@@ -319,22 +516,64 @@ -- ^ @Prop ℓ@, @Set ℓ@, @SSet ℓ@. | Inf Univ !Integer -- ^ @Propωᵢ@, @(S)Setωᵢ@.- | SizeUniv -- ^ @SizeUniv@, a sort inhabited by type @Size@.- | LockUniv -- ^ @LockUniv@, a sort for locks.- | LevelUniv -- ^ @LevelUniv@, a sort inhabited by type @Level@. When --level-universe isn't on, this universe reduces to @Set 0@- | 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.+ | SizeUniv+ -- ^ @SizeUniv@, a sort inhabited by type @Size@.+ | LockUniv+ -- ^ @LockUniv@, a sort for locks.+ | LevelUniv+ -- ^ @LevelUniv@, a sort inhabited by type @Level@.+ -- When --level-universe isn't on, this universe reduces to @Set 0@+ | IntervalUniv+ -- ^ @IntervalUniv@, a sort inhabited by the cubical interval.+ | PiSort' (BlockedDepCheck (Sort' t)) (Dom' t t) (Sort' t) (Abs (Sort' t))+ -- ^ Sort of the pi type @(x : A) → B@.+ -- The components are the blocked dependency problem @c@, the domain @A@+ -- (as a bare term), the sort @s1@ of @A@, and the sort @s2@ of @B@ in+ -- the context extended by @x : A@.+ --+ -- @s2@ is always @Abs@+ --+ -- @c@ stores the original codomain sort to ensure we make coherent+ -- choices w.r.t. whether pi types are level-dependent or not+ -- (see #5810)+ --+ -- The sort denoted by @'PiSort' c A s1 s2@ only depends on @c@, @s1@+ -- and @s2@. The domain @A@ is kept around so that we can rebuild the+ -- type @'El' s1 A@ needed to extend the context when we have to work+ -- under the binder of @s2@; see e.g. 'reduceB'' for sorts or+ -- 'piSortEquals'.+ | FunSort (Sort' t) (Sort' t)+ -- ^ Sort of a (non-dependent) function type.+ | UnivSort (Sort' t)+ -- ^ Sort of another sort ("successor sort"). | MetaS {-# UNPACK #-} !MetaId [Elim' t]- | DefS QName [Elim' t] -- ^ A postulated sort.+ -- ^ Sort metavariable.+ | DefS QName [Elim' t]+ -- ^ A postulated sort. | DummyS String- -- ^ A (part of a) term or type which is only used for internal purposes.- -- 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.+ -- ^ A (part of a) term or type which is only used for internal purposes.+ -- 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 Show +mustBeAbs :: Impossible -> Abs t -> Abs t+mustBeAbs err (Abs x t) = Abs x t+mustBeAbs err NoAbs{} = throwImpossible err++-- | The codomain sort of a 'PiSort' should always be 'Abs'. This pattern+-- synonym defensively checks this.+pattern PiSort ::+ BlockedDepCheck (Sort' t) -> Dom' t t -> Sort' t -> Abs (Sort' t)+ -> Sort' t+pattern PiSort c a s1 s2Abs <- PiSort' c a s1 s2Abs where+ PiSort c a s1 s2Abs = PiSort' c a s1 (mustBeAbs __IMPOSSIBLE__ s2Abs)++{-# COMPLETE+ Univ, Inf,+ SizeUniv, LockUniv, LevelUniv, IntervalUniv,+ PiSort, FunSort, UnivSort, MetaS, DefS, DummyS #-}+ pattern Prop, Type, SSet :: Level' t -> Sort' t pattern Prop l = Univ UProp l pattern Type l = Univ UType l@@ -385,6 +624,27 @@ -- | Named pattern arguments. type NAPs = [NamedArg DeBruijnPattern] +-- | Does the clause body contain calls to any of the mutually recursive functions?+data ClauseRecursive+ = YesRecursive+ -- ^ Definitely a call to a mutually recursive function.+ | NotRecursive+ -- ^ Definitely no call to a mutually recursive function.+ | MaybeRecursive+ -- ^ Don't know because the analysis has not run yet.+ deriving (Bounded, Enum, Eq, Generic, Show)++couldBeRecursive :: ClauseRecursive -> Bool+couldBeRecursive = \case+ YesRecursive -> True+ NotRecursive -> False+ MaybeRecursive -> True++decideRecursive :: Bool -> ClauseRecursive+decideRecursive = \case+ True -> YesRecursive+ False -> NotRecursive+ -- | A clause is a list of patterns and the clause body. -- -- The telescope contains the types of the pattern variables and the@@ -415,13 +675,8 @@ -- pattern on the lhs. , clauseCatchall :: Catchall -- ^ Clause has been labelled as CATCHALL.- , clauseRecursive :: Maybe Bool- -- ^ @clauseBody@ contains recursive calls; computed by termination checker.- -- @Nothing@ means that termination checker has not run yet,- -- or that @clauseBody@ contains meta-variables;- -- these could be filled with recursive calls later!- -- @Just False@ means definitely no recursive call.- -- @Just True@ means definitely a recursive call.+ , clauseRecursive :: ClauseRecursive+ -- ^ @clauseBody@ contains recursive calls? Computed by termination checker. , clauseUnreachable :: Maybe Bool -- ^ Clause has been labelled as unreachable by the coverage checker. -- @Nothing@ means coverage checker has not run yet (clause may be unreachable).@@ -435,7 +690,7 @@ deriving (Show, Generic) clausePats :: Clause -> [Arg DeBruijnPattern]-clausePats = map (fmap namedThing) . namedClausePats+clausePats = map' (fmap namedThing) . namedClausePats instance HasRange Clause where getRange = clauseLHSRange@@ -454,6 +709,9 @@ , patAsNames :: [Name] } deriving (Show, Eq, Generic) +instance Null PatternInfo where+ empty = defaultPatternInfo+ defaultPatternInfo :: PatternInfo defaultPatternInfo = PatternInfo PatOSystem [] @@ -485,7 +743,7 @@ | ConP ConHead ConPatternInfo [NamedArg (Pattern' x)] -- ^ @c ps@ -- The subpatterns do not contain any projection copatterns.- | LitP PatternInfo Literal+ | LitP LitPatternInfo Literal -- ^ E.g. @5@, @"hello"@. | ProjP ProjOrigin QName -- ^ Projection copattern. Can only appear by itself.@@ -505,7 +763,7 @@ dotP = DotP defaultPatternInfo litP :: Literal -> Pattern' a-litP = LitP defaultPatternInfo+litP = LitP empty -- | Type used when numbering pattern variables. data DBPatVar = DBPatVar@@ -526,6 +784,41 @@ absurdP :: Int -> DeBruijnPattern absurdP = VarP (PatternInfo PatOAbsurd []) . DBPatVar absurdPatternName +-- | For the sake of reducing clauses before they have compiled,+-- we keep a match priority in the constructors (and literals)+-- of patterns that is computed during lhs checking and+-- decides whether a mismatch should be treated as a hard 'No'.+-- Matches that get available earlier have a lower priority.+-- Lower priority wins, meaning that if we combine a+-- 'DontKnow' with a 'No' we take the one with the lower priority.+newtype MatchPrio = MatchPrio { theMatchPrio :: Int }+ deriving (Eq, Ord, Show, Enum, KillRange, NFData)++instance Null MatchPrio where+ empty = MatchPrio 0++instance Semigroup MatchPrio where+ MatchPrio p <> MatchPrio p' = MatchPrio $ min p p'++instance Monoid MatchPrio where+ mempty = empty++-- | Extra information attached to a 'LitP'.+data LitPatternInfo = LitPatternInfo+ { litPInfo :: PatternInfo+ -- ^ Information on the origin of the pattern.+ , litPPrio :: MatchPrio+ -- ^ Time when this pattern was constructed during LHS checking.+ -- This field is used during pattern matching with the non-compiled clauses.+ }+ deriving (Eq, Show, Generic)++instance Null LitPatternInfo where+ empty = LitPatternInfo empty empty++instance KillRange LitPatternInfo where+ killRange (LitPatternInfo a b) = killRangeN LitPatternInfo a b+ -- | The @ConPatternInfo@ states whether the constructor belongs to -- a record type (@True@) or data type (@False@). -- In the former case, the @PatOrigin@ of the @conPInfo@ says@@ -557,11 +850,14 @@ -- ('Agda.TypeChecking.CompiledClause.Compile.compileClauses') when the -- variables they bind are unused. The GHC backend compiles lazy matches -- to lazy patterns in Haskell (TODO: not yet).+ , conPPrio :: !MatchPrio+ -- ^ Time when this pattern was constructed during LHS checking.+ -- This field is used during pattern matching with the non-compiled clauses. } deriving (Show, Generic) noConPatternInfo :: ConPatternInfo-noConPatternInfo = ConPatternInfo defaultPatternInfo False False Nothing False+noConPatternInfo = ConPatternInfo defaultPatternInfo False False Nothing False empty -- | Build partial 'ConPatternInfo' from 'ConInfo' toConPatternInfo :: ConInfo -> ConPatternInfo@@ -618,7 +914,7 @@ patternInfo :: Pattern' x -> Maybe PatternInfo patternInfo (VarP i _) = Just i patternInfo (DotP i _) = Just i-patternInfo (LitP i _) = Just i+patternInfo (LitP i _) = Just $ litPInfo i patternInfo (ConP _ ci _) = Just $ conPInfo ci patternInfo ProjP{} = Nothing patternInfo (IApplyP i _ _ _) = Just i@@ -650,7 +946,7 @@ -- Apply this to closed terms you want to use in a non-empty context. -- @Γ ⊢ EmptyS : ()@ - | a :# Substitution' a+ | a :# !(Substitution' a) -- ^ Substitution extension, ``cons''. -- @ -- Γ ⊢ u : Aρ Γ ⊢ ρ : Δ@@ -658,7 +954,7 @@ -- Γ ⊢ u :# ρ : Δ, A -- @ - | Strengthen Impossible !Int (Substitution' a)+ | Strengthen Impossible !Int !(Substitution' a) -- ^ Strengthening substitution. First argument is @__IMPOSSIBLE__@. -- In @'Strengthen err n ρ@ the number @n@ must be non-negative. -- This substitution should only be applied to values @t@ for@@ -670,7 +966,7 @@ -- Γ ⊢ Strengthen n ρ : Δ, Θ -- @ - | Wk !Int (Substitution' a)+ | Wk !Int !(Substitution' a) -- ^ Weakening substitution, lifts to an extended context. -- @ -- Γ ⊢ ρ : Δ@@ -679,7 +975,7 @@ -- @ - | Lift !Int (Substitution' a)+ | Lift !Int !(Substitution' a) -- ^ Lifting substitution. Use this to go under a binder. -- @Lift 1 ρ == var 0 :# Wk 1 ρ@. -- @@@ -697,6 +993,7 @@ type Substitution = Substitution' Term type PatternSubstitution = Substitution' DeBruijnPattern+type Renaming = Substitution' Nat infixr 4 :# @@ -705,6 +1002,11 @@ null IdS = True null _ = False +-- | Wrapper for types that do not contain variables (so applying a substitution is the identity).+-- Useful if you have a structure of types that support substitution mixed with types that don't+-- and need to apply a substitution to the full structure.+newtype NoSubst t a = NoSubst { unNoSubst :: a }+ deriving (Generic, NFData, Functor) --------------------------------------------------------------------------- -- * Views@@ -803,11 +1105,6 @@ -- * Smart constructors --------------------------------------------------------------------------- --- | An unapplied variable.-var :: Nat -> Term-var i | i >= 0 = Var i []- | otherwise = __IMPOSSIBLE__- -- | Add 'DontCare' is it is not already a @DontCare@. dontCare :: Term -> Term dontCare v =@@ -815,17 +1112,15 @@ DontCare{} -> v _ -> DontCare v -type DummyTermKind = String- -- | Construct a string representing the call-site that created the dummy thing. dummyLocName :: CallStack -> String dummyLocName cs = maybe __IMPOSSIBLE__ prettyCallSite (headCallSite cs) -- | Aux: A dummy term to constitute a dummy term/level/sort/type.-dummyTermWith :: DummyTermKind -> CallStack -> Term-dummyTermWith kind cs = flip Dummy [] $ concat [kind, ": ", dummyLocName cs]+dummyTermWith :: String -> CallStack -> Term+dummyTermWith kind cs = flip Dummy [] . DummyNamed $ concat [kind, ": ", dummyLocName cs] -__DUMMY_TERM_WITH__ :: HasCallStack => DummyTermKind -> Term+__DUMMY_TERM_WITH__ :: HasCallStack => String -> Term __DUMMY_TERM_WITH__ = withCallerCallStack . dummyTermWith -- | A dummy term created at location.@@ -886,7 +1181,7 @@ -- | Given a constant @m@ and level @l@, compute @m + l@ levelPlus :: Integer -> Level -> Level-levelPlus m (Max n as) = Max (m + n) $ map pplus as+levelPlus m (Max n as) = Max (m + n) $ map' pplus as where pplus (Plus n l) = Plus (m + n) l levelSuc :: Level -> Level@@ -902,7 +1197,7 @@ mkSSet n = SSet $ ClosedLevel n impossibleTerm :: CallStack -> Term-impossibleTerm = flip Dummy [] . show . Impossible+impossibleTerm = flip Dummy [] . DummyNamed . show . Impossible --------------------------------------------------------------------------- -- * Sorts.@@ -941,7 +1236,7 @@ -- | A traversal for the names in a telescope. mapAbsNamesM :: Applicative m => (ArgName -> m ArgName) -> Tele a -> m (Tele a)-mapAbsNamesM f EmptyTel = pure EmptyTel+mapAbsNamesM _ EmptyTel = pure EmptyTel mapAbsNamesM f (ExtendTel a ( Abs x b)) = ExtendTel a <$> ( Abs <$> f x <*> mapAbsNamesM f b) mapAbsNamesM f (ExtendTel a (NoAbs x b)) = ExtendTel a <$> (NoAbs <$> f x <*> mapAbsNamesM f b) -- Ulf, 2013-11-06: Last case is really impossible but I'd rather find out we@@ -950,17 +1245,6 @@ mapAbsNames :: (ArgName -> ArgName) -> Tele a -> Tele a mapAbsNames f = runIdentity . mapAbsNamesM (Identity . f) --- Ulf, 2013-11-06--- The record parameter is named "" inside the record module so we can avoid--- printing it (issue 208), but we don't want that to show up in the type of--- the functions in the module (issue 892). This function is used on the record--- module telescope before adding it to a type in--- TypeChecking.Monad.Signature.addConstant (to handle functions defined in--- record modules) and TypeChecking.Rules.Record.checkProjection (to handle--- record projections).-replaceEmptyName :: ArgName -> Tele a -> Tele a-replaceEmptyName x = mapAbsNames $ \ y -> if null y then x else y- -- | Telescope as list. type ListTel' a = [Dom (a, Type)] type ListTel = ListTel' ArgName@@ -968,7 +1252,7 @@ telFromList' :: (a -> ArgName) -> ListTel' a -> Telescope telFromList' f = List.foldr extTel EmptyTel where- extTel dom@Dom{unDom = (x, a)} = ExtendTel (dom{unDom = a}) . Abs (f x)+ extTel dom@Dom'{unDom = (x, a)} = ExtendTel (dom{unDom = a}) . Abs (f x) -- | Convert a list telescope to a telescope. telFromList :: ListTel -> Telescope@@ -977,7 +1261,7 @@ -- | Convert a telescope to its list form. telToList :: Tele (Dom t) -> [Dom (ArgName,t)] telToList EmptyTel = []-telToList (ExtendTel arg (Abs x tel)) = fmap (x,) arg : telToList tel+telToList (ExtendTel arg (Abs x tel)) = (fmap (x,) arg :) $! telToList tel telToList (ExtendTel _ NoAbs{} ) = __IMPOSSIBLE__ -- | Lens to edit a 'Telescope' as a list.@@ -989,7 +1273,7 @@ telToArgs :: a -> [Arg ArgName] instance TelToArgs ListTel where- telToArgs = map $ \ dom -> Arg (domInfo dom) (fst $ unDom dom)+ telToArgs = map' \dom -> Arg (domInfo dom) (fst $ unDom dom) instance TelToArgs Telescope where telToArgs = telToArgs . telToList@@ -1053,9 +1337,49 @@ -- * Eliminations. --------------------------------------------------------------------------- +{-+Note: 'unSpine' is computed quite often, so it makes sense to optimize it. The first optimization is+to check with 'hasProj' and skip building a new term if the spine doesn't contain projections. The+second optimization is to use an unboxed sum type to distinguish the three cases for reconstructing+a term with spines ('Var', 'Def' and 'MetaV'), thereby avoiding heap allocation.++Docs on unboxed sums: https://downloads.haskell.org/ghc/9.14.1/docs/users_guide/exts/primitives.html#unboxed-sums+-}++hasProj :: Elims -> Bool+hasProj = \case+ [] -> False+ Proj{}:_ -> True+ _:es -> hasProj es++#if __GLASGOW_HASKELL__ < 906+data SpineHead' = SHVar !Int | SHDef !QName | SHMetaV {-# UNPACK #-} !MetaId+newtype SpineHead = SpineHead SpineHead'+#else+data SpineHead' = SHVar !Int | SHDef !QName | SHMetaV {-# UNPACK #-} !MetaId+data SpineHead = SpineHead {-# UNPACK #-} !SpineHead'+#endif++applySpineHead :: SpineHead -> Elims -> Term+applySpineHead h !es = case h of+ SpineHead (SHVar x ) -> Var x es+ SpineHead (SHDef f ) -> Def f es+ SpineHead (SHMetaV x) -> MetaV x es++unSpineLoop :: SpineHead -> Elims -> Elims -> Term+unSpineLoop !h !res es = case es of+ [] -> applySpineHead h $! reverse res+ Proj _ f : es' -> let !v = defaultArg $! (applySpineHead h $! reverse res) in+ unSpineLoop (SpineHead (SHDef f)) [Apply v] es'+ e : es' -> unSpineLoop h (e : res) es'+ -- | Convert top-level postfix projections into prefix projections. unSpine :: Term -> Term-unSpine = unSpine' $ \_ _ -> True+unSpine t = case t of+ Var i es | hasProj es -> unSpineLoop (SpineHead (SHVar i )) [] es+ Def f es | hasProj es -> unSpineLoop (SpineHead (SHDef f )) [] es+ MetaV x es | hasProj es -> unSpineLoop (SpineHead (SHMetaV x)) [] es+ t -> t -- | Convert 'Proj' projection eliminations -- according to their 'ProjOrigin' into@@ -1069,11 +1393,12 @@ loop :: (Elims -> Term) -> Elims -> Elims -> Term loop h res es = case es of- [] -> v- Proj o f : es' | p o f -> loop (Def f) [Apply (defaultArg v)] es'+ [] -> h $! reverse res+ Proj o f : es' | p o f -> let !v = defaultArg $! (h $! reverse res) in+ loop (Def f) [Apply v] es' e : es' -> loop h (e : res) es'- where v = h $ reverse res +{-# INLINE hasElims #-} -- | A view distinguishing the neutrals @Var@, @Def@, and @MetaV@ which -- can be projected. hasElims :: Term -> Maybe (Elims -> Term, Elims)@@ -1091,6 +1416,7 @@ DontCare{} -> Nothing Dummy{} -> Nothing + --------------------------------------------------------------------------- -- * Type family for type-directed operations. ---------------------------------------------------------------------------@@ -1112,6 +1438,130 @@ type instance TypeOf PlusLevel = () ---------------------------------------------------------------------------+-- * (Local) rewrite rules+---------------------------------------------------------------------------++-- | NLPat might become definitionally singular (after a substitution)+data DefSing+ = NeverSing+ -- ^ Never definitionally singular+ | MaybeSing+ -- ^ Might become definitionally singular after a substitution+ | AlwaysSing+ -- ^ Always definitionally singular (e.g. irrelevant or in |Prop|)+ deriving (Show, Generic, Enum, Bounded)++relToDefSing :: Relevance -> DefSing+relToDefSing r = if isIrrelevant r then AlwaysSing else NeverSing++-- Only approximate if both sides are |NotDefSingIfInj| with non-empty+-- injective constraints+minDefSing :: DefSing -> DefSing -> DefSing+minDefSing s s' = toEnum $ fromEnum s `min` fromEnum s'++maxDefSing :: DefSing -> DefSing -> DefSing+maxDefSing s s' = toEnum $ fromEnum s `max` fromEnum s'++isAlwaysSing :: DefSing -> Bool+isAlwaysSing AlwaysSing = True+isAlwaysSing _ = False++-- | Non-linear (non-constructor) first-order pattern.+data NLPat+ = PVar DefSing !Int [Arg Int]+ -- ^ Matches anything (modulo non-linearity) that only contains bound+ -- variables that occur in the given arguments.+ -- Tracks the definitional singularity of the surrounding pattern (not+ -- the type of the variable itself)+ | 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]+++type instance TypeOf NLPat = Type+type instance TypeOf [Elim' NLPat] = (Type, Elims -> Term)+++data NLPType = NLPType+ { nlpTypeSort :: NLPSort+ , nlpTypeUnEl :: NLPat+ } deriving (Show, Generic)+++data NLPSort+ = PUniv Univ NLPat+ | PInf Univ Integer+ | PSizeUniv+ | PLockUniv+ | PLevelUniv+ | PIntervalUniv+ deriving (Show, Generic)++pattern PType, PProp, PSSet :: NLPat -> NLPSort+pattern PType p = PUniv UType p+pattern PProp p = PUniv UProp p+pattern PSSet p = PUniv USSet p++{-# COMPLETE+ PType, PSSet, PProp, PInf,+ PSizeUniv, PLockUniv, PLevelUniv, PIntervalUniv #-}++data RewriteHead+ = RewDefHead QName+ | RewVarHead Nat+ -- ^ de Bruijn index of head symbol (excluding rewContext variables)+ deriving (Show, Generic, Eq)++headToPat :: Nat -> RewriteHead -> PElims -> NLPat+headToPat _ (RewDefHead f) = PDef f+headToPat telStart (RewVarHead x) = PBoundVar (x + telStart)++headToTerm :: Nat -> RewriteHead -> Elims -> Term+headToTerm _ (RewDefHead f) = Def f+headToTerm telStart (RewVarHead x) = Var (x + telStart)++-- | Undirected equational constraint ("the LHS and RHS+-- must be convertible in the calling context").+-- Admits arbitrary substitution.+data LocalEquation' t = LocalEquation+ { lEqContext :: !(Tele (Dom' t (Type'' t t)))+ , lEqLHS :: t+ , lEqRHS :: t+ , lEqType :: Type'' t t+ }+ deriving (Show, Generic)++type LocalEquation = LocalEquation' Term++-- | Directed rewrite rules generic over the type of head symbol.+-- Generally unstable under substitution.+data RewriteRule = RewriteRule+ { rewContext :: Telescope+ , rewHead :: RewriteHead+ , rewPats :: PElims -- patterns (including rewContext variables)+ , rewRHS :: Term+ , rewType :: Type+ }+ deriving (Show, Generic)++lrewHasProjectionPattern :: RewriteRule -> Bool+lrewHasProjectionPattern rew = any (isJust . isProjElim) $ rewPats rew++class LensLocalEquation a where+ getLocalEq :: a -> Maybe LocalEquation++--------------------------------------------------------------------------- -- * Null instances. --------------------------------------------------------------------------- @@ -1120,6 +1570,9 @@ null EmptyTel = True null ExtendTel{} = False +instance Null ClauseRecursive where+ empty = MaybeRecursive+ -- | A 'null' clause is one with no patterns and no rhs. -- Should not exist in practice. instance Null Clause where@@ -1203,7 +1656,7 @@ LockUniv -> 1 LevelUniv -> 1 IntervalUniv -> 1- PiSort a s1 s2 -> 1 + tsize a + tsize s1 + tsize s2+ PiSort _c a s1 s2 -> 1 + tsize a + tsize s1 + tsize s2 FunSort s1 s2 -> 1 + tsize s1 + tsize s2 UnivSort s -> 1 + tsize s MetaS _ es -> 1 + tsize es@@ -1228,11 +1681,8 @@ -- * KillRange instances. --------------------------------------------------------------------------- -instance KillRange DataOrRecord where- killRange = id- instance KillRange ConHead where- killRange (ConHead c d i fs) = killRangeN ConHead c d i fs+ killRange (ConHead c d i h fs) = killRangeN ConHead c d i h fs instance KillRange Term where killRange = \case@@ -1248,16 +1698,16 @@ DontCare mv -> killRangeN DontCare mv v@Dummy{} -> v -instance KillRange Level where+instance KillRange a => KillRange (Level' a) where killRange (Max n as) = killRangeN (Max n) as -instance KillRange PlusLevel where+instance KillRange a => KillRange (PlusLevel' a) where killRange (Plus n l) = killRangeN (Plus n) l -instance (KillRange a) => KillRange (Type' a) where+instance (KillRange a, KillRange b) => KillRange (Type'' a b) where killRange (El s v) = killRangeN El s v -instance KillRange Sort where+instance KillRange a => KillRange (Sort' a) where killRange = \case Inf u n -> Inf u n SizeUniv -> SizeUniv@@ -1265,7 +1715,7 @@ LevelUniv -> LevelUniv IntervalUniv -> IntervalUniv Univ u a -> killRangeN (Univ u) a- PiSort a s1 s2 -> killRangeN PiSort a s1 s2+ PiSort c a s1 s2 -> killRangeN PiSort c a s1 s2 FunSort s1 s2 -> killRangeN FunSort s1 s2 UnivSort s -> killRangeN UnivSort s MetaS x es -> killRangeN (MetaS x) es@@ -1281,13 +1731,23 @@ killRange (Lift n rho) = killRangeN (Lift n) rho instance KillRange PatOrigin where- killRange = id+ killRange = \case+ PatOSystem -> PatOSystem+ PatOSplit -> PatOSplit+ PatOSplitArg n -> killRangeN PatOSplitArg n+ PatOVar n -> killRangeN PatOVar n+ PatODot -> PatODot+ PatOWild -> PatOWild+ PatOCon -> PatOCon+ PatORec -> PatORec+ PatOLit -> PatOLit+ PatOAbsurd -> PatOAbsurd instance KillRange PatternInfo where killRange (PatternInfo o xs) = killRangeN PatternInfo o xs instance KillRange ConPatternInfo where- killRange (ConPatternInfo i mr b mt lz) = killRangeN (ConPatternInfo i mr b) mt lz+ killRange (ConPatternInfo i mr b mt lz prio) = killRangeN (ConPatternInfo i mr b) mt lz prio instance KillRange DBPatVar where killRange (DBPatVar x i) = killRangeN DBPatVar x i@@ -1303,10 +1763,48 @@ IApplyP o u t x -> killRangeN (IApplyP o) u t x DefP o q ps -> killRangeN (DefP o) q ps +instance KillRange ClauseRecursive where+ killRange = id+ instance KillRange Clause where killRange (Clause rl rf tel ps body t catchall recursive unreachable ell wm) = killRangeN Clause rl rf tel ps body t catchall recursive unreachable ell wm ++instance KillRange NLPat where+ killRange (PVar s x y) = killRangeN (PVar s) x y+ killRange (PDef x y) = killRangeN PDef x y+ killRange (PLam x y) = killRangeN PLam x y+ killRange (PPi x y) = killRangeN PPi x y+ killRange (PSort x) = killRangeN PSort x+ killRange (PBoundVar x y) = killRangeN PBoundVar x y+ killRange (PTerm x) = killRangeN PTerm x++instance KillRange NLPType where+ killRange (NLPType s a) = killRangeN NLPType s a++instance KillRange NLPSort where+ killRange (PUniv u l) = killRangeN (PUniv u) l+ killRange s@(PInf _f _n) = s+ killRange PSizeUniv = PSizeUniv+ killRange PLockUniv = PLockUniv+ killRange PLevelUniv = PLevelUniv+ killRange PIntervalUniv = PIntervalUniv++instance KillRange RewriteHead where+ killRange (RewVarHead a) =+ killRangeN RewVarHead a+ killRange (RewDefHead a) =+ killRangeN RewDefHead a++instance KillRange t => KillRange (LocalEquation' t) where+ killRange (LocalEquation a b c d) =+ killRangeN LocalEquation a b c d++instance KillRange RewriteRule where+ killRange (RewriteRule a b c d e) =+ killRangeN RewriteRule a b c d e+ instance KillRange a => KillRange (Tele a) where killRange = fmap killRange @@ -1316,6 +1814,8 @@ instance KillRange a => KillRange (Abs a) where killRange = fmap killRange +instance KillRange a => KillRange (BlockedDepCheck a) where+ ----------------------------------------------------------------------------- -- * Simple pretty printing -----------------------------------------------------------------------------@@ -1325,27 +1825,27 @@ where pr p rho = case rho of IdS -> "idS"- EmptyS err -> "emptyS"+ 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+ text ("strS " ++! show n) <+> pr 10 rho Wk n rho -> mparens (p > 9) $- text ("wkS " ++ show n) <+> pr 10 rho+ text ("wkS " ++! show n) <+> pr 10 rho Lift n rho -> mparens (p > 9) $- text ("liftS " ++ show n) <+> pr 10 rho+ text ("liftS " ++! show n) <+> pr 10 rho instance Pretty Term where prettyPrec p v = case v of- Var x els -> text ("@" ++ show x) `pApp` els+ Var x els -> text ("@" ++! show x) `pApp` els Lam ai b -> mparens (p > 0) $ sep [ "λ" <+> prettyHiding ai id (text . absName $ b) <+> "->" , nest 2 $ pretty (unAbs b) ] Lit l -> pretty l Def q els -> pretty q `pApp` els- Con c ci vs -> pretty (conName c) `pApp` vs+ Con c _ci vs -> pretty (conName c) `pApp` vs Pi a (NoAbs _ b) -> mparens (p > 0) $ sep [ pretty (getModality a) <+> prettyPrec 1 (unDom a) <+> "->" , nest 2 $ pretty b ]@@ -1356,15 +1856,22 @@ Level l -> prettyPrec p l MetaV x els -> pretty x `pApp` els DontCare v -> prettyPrec p v- Dummy s es -> parens (text s) `pApp` es++ Dummy kind es -> case kind of+ DummyNamed s -> parens (text s) `pApp` es+ DummyBrave hd -> pretty hd `pApp` es where pApp d els = mparens (not (null els) && p > 9) $- sep [d, nest 2 $ fsep (map (prettyPrec 10) els)]+ sep [d, nest 2 $ fsep (map' (prettyPrec 10) els)] instance Pretty t => Pretty (Abs t) where pretty (Abs x t) = "Abs" <+> (text x <> ".") <+> pretty t pretty (NoAbs x t) = "NoAbs" <+> (text x <> ".") <+> pretty t +instance Pretty t => Pretty (BlockedDepCheck t) where+ pretty (CodomainSortOld s) = "CodomainSortOld" <+> pretty s+ pretty CodomainSortSame = "CodomainSortSame"+ instance (Pretty t, Pretty e) => Pretty (Dom' t e) where pretty dom = pLock <+> pTac <+> pDom dom (pretty (getModality dom) <+> pretty (unDom dom)) where@@ -1380,10 +1887,16 @@ Hidden -> braces Instance{} -> braces . braces +instance Pretty ClauseRecursive where+ pretty = \case+ YesRecursive -> "+Rec"+ NotRecursive -> "-Rec"+ MaybeRecursive -> "?Rec"+ instance Pretty Clause where pretty Clause{clauseTel = tel, namedClausePats = ps, clauseBody = b, clauseType = t} = sep [ pretty tel <+> "|-"- , nest 2 $ sep [ fsep (map (prettyPrec 10) ps) <+> "="+ , nest 2 $ sep [ fsep (map' (prettyPrec 10) ps) <+> "=" , nest 2 $ pBody b t ] ] where pBody Nothing _ = "(absurd)"@@ -1406,7 +1919,7 @@ [] -> prettyN [a] | n == 0 -> prettyPrec p a _ -> mparens (p > 9) $ List.foldr1 (\a b -> "lub" <+> a <+> b) $- [ prettyN | n > 0 ] ++ map (prettyPrec 10) as+ [ prettyN | n > 0 ] ++! map' (prettyPrec 10) as where prettyN = prettyPrecLevelSucs p n (const "lzero") @@ -1418,12 +1931,12 @@ case s of Univ u (ClosedLevel n) -> text $ suffix n $ showUniv u Univ u l -> mparens (p > 9) $ text (showUniv u) <+> prettyPrec 10 l- Inf u n -> text $ suffix n $ showUniv u ++ "ω"+ Inf u n -> text $ suffix n $ showUniv u ++! "ω" SizeUniv -> "SizeUniv" LockUniv -> "LockUniv" LevelUniv -> "LevelUniv" IntervalUniv -> "IntervalUniv"- PiSort a s1 s2 -> mparens (p > 9) $+ PiSort c a s1 s2 -> mparens (p > 9) $ "piSort" <+> pDom (domInfo a) (text (absName s2) <+> ":" <+> pretty (unDom a) <+> ":" <+> pretty s1) <+> parens (pretty (unAbs s2)) FunSort a b -> mparens (p > 9) $@@ -1433,25 +1946,25 @@ DefS d es -> prettyPrec p $ Def d es DummyS s -> parens $ text s where- suffix n = applyWhen (n /= 0) (++ show n)+ suffix n = applyWhen (n /= 0) (++! show n) instance Pretty Type where prettyPrec p (El _ a) = prettyPrec p a instance Pretty DBPatVar where- prettyPrec _ x = text $ patVarNameToString (dbPatVarName x) ++ "@" ++ show (dbPatVarIndex x)+ prettyPrec _ x = text $ patVarNameToString (dbPatVarName x) ++! "@" ++! show (dbPatVarIndex x) instance Pretty a => Pretty (Pattern' a) where prettyPrec n (VarP _o x) = prettyPrec n x prettyPrec _ (DotP _o t) = "." <> prettyPrec 10 t prettyPrec n (ConP c i nps)= mparens (n > 0 && not (null nps)) $- (lazy <> pretty (conName c)) <+> fsep (map (prettyPrec 10) ps)- where ps = map (fmap namedThing) nps+ (lazy <> pretty (conName c)) <+> fsep (map' (prettyPrec 10) ps)+ where ps = map' (fmap namedThing) nps lazy | conPLazy i = "~" | otherwise = empty- prettyPrec n (DefP o q nps)= mparens (n > 0 && not (null nps)) $- pretty q <+> fsep (map (prettyPrec 10) ps)- where ps = map (fmap namedThing) nps+ prettyPrec n (DefP _o q nps)= mparens (n > 0 && not (null nps)) $+ pretty q <+> fsep (map' (prettyPrec 10) ps)+ where ps = map' (fmap namedThing) nps -- -- Version with printing record type: -- prettyPrec _ (ConP c i ps) = (if b then braces else parens) $ prTy $ -- text (show $ conName c) <+> fsep (map (pretty . namedArg) ps)@@ -1459,7 +1972,7 @@ -- b = maybe False (== ConOSystem) $ conPRecord i -- prTy d = caseMaybe (conPType i) d $ \ t -> d <+> ":" <+> pretty t prettyPrec _ (LitP _ l) = pretty l- prettyPrec _ (ProjP _o q) = text ("." ++ prettyShow q)+ prettyPrec _ (ProjP _o q) = text ("." ++! prettyShow q) 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 @@ -1469,6 +1982,9 @@ NotBlocked nb a -> pretty a <+> ("[ blocked on" <+> pretty nb <+> "]") Blocked b a -> pretty a <+> ("[ stuck on" <+> pretty b <+> "]") +instance Pretty a => Pretty (NoSubst t a) where+ pretty = pretty . unNoSubst+ ----------------------------------------------------------------------------- -- * NFData instances -----------------------------------------------------------------------------@@ -1500,7 +2016,7 @@ LockUniv -> () LevelUniv -> () IntervalUniv -> ()- PiSort a b c -> rnf (a, b, unAbs c)+ PiSort a b c d -> rnf (a, b, c, unAbs d) FunSort a b -> rnf (a, b) UnivSort a -> rnf a MetaS _ es -> rnf es@@ -1514,17 +2030,28 @@ rnf (Plus n l) = rnf (n, l) instance NFData e => NFData (Dom e) where- rnf (Dom a c d e f) = rnf a `seq` rnf c `seq` rnf d `seq` rnf e `seq` rnf f+ rnf (Dom a c d e f g) = rnf a `seq` rnf c `seq` rnf d `seq` rnf e `seq` rnf f `seq` rnf g instance NFData a => NFData (DataOrRecord' a) instance NFData ConHead instance NFData a => NFData (Abs a) instance NFData a => NFData (Tele a) instance NFData IsFibrant+instance NFData ClauseRecursive instance NFData Clause instance NFData PatternInfo instance NFData PatOrigin instance NFData x => NFData (Pattern' x) instance NFData DBPatVar instance NFData ConPatternInfo+instance NFData LitPatternInfo instance NFData a => NFData (Substitution' a)+instance NFData DefSing+instance NFData NLPat+instance NFData NLPType+instance NFData NLPSort+instance NFData RewriteHead+instance NFData LocalEquation+instance NFData RewriteRule+instance NFData RewDom+instance NFData a => NFData (BlockedDepCheck a)
src/full/Agda/Syntax/Internal/Blockers.hs view
@@ -5,7 +5,6 @@ import Data.Set (Set) import qualified Data.Set as Set-import Data.Semigroup import GHC.Generics (Generic) @@ -13,7 +12,8 @@ import Agda.Syntax.Abstract.Name (QName) import Agda.Syntax.Internal.Elim -import Agda.Syntax.Common.Pretty hiding ((<>))+import Agda.Syntax.Common.Pretty+import Agda.Utils.List import Agda.Utils.Functor ---------------------------------------------------------------------------@@ -71,11 +71,11 @@ -- | What is causing the blocking? Or in other words which metas or problems need to be solved to -- unblock the blocked computation/constraint.-data Blocker = UnblockOnAll (Set Blocker)- | UnblockOnAny (Set Blocker)- | UnblockOnMeta MetaId -- ^ Unblock if meta is instantiated- | UnblockOnProblem ProblemId- | UnblockOnDef QName -- ^ Unblock when function is defined+data Blocker = UnblockOnAll !(Set Blocker)+ | UnblockOnAny !(Set Blocker)+ | UnblockOnMeta {-# UNPACK #-} !MetaId -- ^ Unblock if meta is instantiated+ | UnblockOnProblem !ProblemId+ | UnblockOnDef !QName -- ^ Unblock when function is defined deriving (Show, Eq, Ord, Generic) instance NFData Blocker@@ -92,7 +92,7 @@ us | [u] <- Set.toList us -> u us -> UnblockOnAll us where- allViewS = Set.unions . map allView . Set.toList+ allViewS = Set.unions . map' allView . Set.toList allView (UnblockOnAll us) = allViewS us allView u = Set.singleton u @@ -103,7 +103,7 @@ us | Set.member alwaysUnblock us -> alwaysUnblock | otherwise -> UnblockOnAny us where- anyViewS = Set.unions . map anyView . Set.toList+ anyViewS = Set.unions . map' anyView . Set.toList anyView (UnblockOnAny us) = anyViewS us anyView u = Set.singleton u @@ -136,22 +136,22 @@ 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 (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 (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 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 (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@@ -167,8 +167,8 @@ -} 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 (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@@ -195,7 +195,7 @@ NotBlocked{} <> b@Blocked{} = b NotBlocked x a <> NotBlocked y b = NotBlocked (x <> y) (a <> b) -instance (Semigroup a, Monoid a) => Monoid (Blocked' t a) where+instance (Monoid a) => Monoid (Blocked' t a) where mempty = notBlocked mempty mappend = (<>)
src/full/Agda/Syntax/Internal/Defs.hs view
@@ -1,116 +1,140 @@ {-# OPTIONS_GHC -Wunused-imports #-}+-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-all -dno-suppress-type-signatures -ddump-to-file -dno-typeable-binds #-} -- | Extract used definitions from terms. module Agda.Syntax.Internal.Defs where -import Control.Monad.Reader-import Control.Monad.Writer--import qualified Data.Foldable as Fold- import Agda.Syntax.Common import Agda.Syntax.Internal---- | @getDefs' lookup emb a@ extracts all used definitions--- (functions, data/record types) from @a@, embedded into a monoid via @emb@.--- Instantiations of meta variables are obtained via @lookup@.------ Typical monoid instances would be @[QName]@ or @Set QName@.--- Note that @emb@ can also choose to discard a used definition--- by mapping to the unit of the monoid.-getDefs' :: (GetDefs a, Monoid b) => (MetaId -> Maybe Term) -> (QName -> b) -> a -> b-getDefs' lookup emb = execWriter . (`runReaderT` GetDefsEnv lookup emb) . getDefs---- | Inputs to and outputs of @getDefs'@ are organized as a monad.-type GetDefsM b = ReaderT (GetDefsEnv b) (Writer b)--data GetDefsEnv b = GetDefsEnv- { lookupMeta :: MetaId -> Maybe Term- , embDef :: QName -> b- }---- | What it takes to get the used definitions.-class Monad m => MonadGetDefs m where- doDef :: QName -> m ()- doMeta :: MetaId -> m ()+import Agda.Utils.ExpandCase+import Agda.Utils.StrictEndo+import Agda.Utils.Impossible -instance Monoid b => MonadGetDefs (GetDefsM b) where- doDef d = tell . ($ d) =<< asks embDef- doMeta x = getDefs . ($ x) =<< asks lookupMeta+-- | Get list of definitions, throw an error if any metavariable is encountered.+getDefListNoMetas :: Term -> [QName]+getDefListNoMetas a =+ getDefs (\_ -> __IMPOSSIBLE__) (\x -> Endo \xs -> x:xs) a `appEndo` [] -- | Getting the used definitions. -- -- Note: in contrast to 'Agda.Syntax.Internal.Generic.foldTerm' -- @getDefs@ also collects from sorts in terms. -- Thus, this is not an instance of @foldTerm@.- class GetDefs a where- getDefs :: MonadGetDefs m => a -> m () - default getDefs :: (MonadGetDefs m, Foldable f, GetDefs b, f b ~ a) => a -> m ()- getDefs = Fold.mapM_ getDefs+ -- | @getDefs lookup emb a@ extracts all used definitions+ -- (functions, data/record types) from @a@, embedded into a monoid via @emb@.+ -- Instantiations of meta variables are obtained via @lookup@.+ --+ -- Typical monoid instances would be @Endo [QName]@ or @Set QName@. Do not use @[QName]@+ -- because of obvious quadratic slowdown.+ -- Note that @emb@ can also choose to discard a used definition+ -- by mapping to the unit of the monoid.+ getDefs :: (Monoid m, ExpandCase m) => (MetaId -> Maybe Term) -> (QName -> m) -> a -> m + -- {-# INLINE getDefs #-}+ -- default getDefs ::+ -- (Foldable f, GetDefs b, f b ~ a, Monoid m, ExpandCase m)+ -- => (MetaId -> Maybe Term) -> (QName -> m) -> a -> m+ -- getDefs ms ds = foldMap (getDefs ms ds)+ instance GetDefs Clause where- getDefs = getDefs . clauseBody+ getDefs ms ds cl =+ expand \ret -> ret $ getDefs ms ds (clauseBody cl) instance GetDefs Term where- getDefs = \case- Def d vs -> doDef d >> getDefs vs- Con _ _ vs -> getDefs vs- Lit l -> return ()- Var i vs -> getDefs vs- Lam _ v -> getDefs v- Pi a b -> getDefs a >> getDefs b- Sort s -> getDefs s- Level l -> getDefs l- MetaV x vs -> getDefs x >> getDefs vs- DontCare v -> getDefs v- Dummy{} -> return ()+ getDefs ms ds t = expand \ret -> case t of+ Def d vs -> ret $ ds d <> getDefs ms ds vs+ Con _ _ vs -> ret $ getDefs ms ds vs+ Lit l -> ret $ mempty+ Var i vs -> ret $ getDefs ms ds vs+ Lam _ v -> ret $ getDefs ms ds v+ Pi a b -> ret $ getDefs ms ds a <> getDefs ms ds b+ Sort s -> ret $ getDefs ms ds s+ Level l -> ret $ getDefs ms ds l+ MetaV x vs -> ret $ getDefs ms ds x <> getDefs ms ds vs+ DontCare v -> ret $ getDefs ms ds v+ Dummy{} -> ret $ mempty instance GetDefs MetaId where- getDefs x = doMeta x+ getDefs ms ds x = getDefs ms ds (ms x) instance GetDefs Type where- getDefs (El s t) = getDefs s >> getDefs t+ getDefs ms ds a = expand \ret -> case a of+ El s t -> ret $ getDefs ms ds s <> getDefs ms ds t instance GetDefs Sort where- getDefs = \case- Univ _ l -> getDefs l- Inf _ _ -> return ()- SizeUniv -> return ()- LockUniv -> return ()- LevelUniv -> return ()- IntervalUniv -> return ()- PiSort a s1 s2 -> getDefs a >> getDefs s1 >> getDefs s2- FunSort s1 s2 -> getDefs s1 >> getDefs s2- UnivSort s -> getDefs s- MetaS x es -> getDefs x >> getDefs es- DefS d es -> doDef d >> getDefs es- DummyS{} -> return ()+ getDefs ms ds s = expand \ret -> case s of+ Univ _ l -> ret $ getDefs ms ds l+ Inf _ _ -> ret $ mempty+ SizeUniv -> ret $ mempty+ LockUniv -> ret $ mempty+ LevelUniv -> ret $ mempty+ IntervalUniv -> ret $ mempty+ PiSort c a s1 s2 -> ret $+ getDefs ms ds c <> getDefs ms ds a <> getDefs ms ds s1 <> getDefs ms ds s2+ FunSort s1 s2 -> ret $ getDefs ms ds s1 <> getDefs ms ds s2+ UnivSort s -> ret $ getDefs ms ds s+ MetaS x es -> ret $ getDefs ms ds x <> getDefs ms ds es+ DefS d es -> ret $ ds d <> getDefs ms ds es+ DummyS{} -> ret $ mempty +instance GetDefs a => GetDefs (BlockedDepCheck a) where+ getDefs ms ds c = expand \ret -> case c of+ CodomainSortOld s -> ret $ getDefs ms ds s+ CodomainSortSame -> ret $ mempty+ instance GetDefs Level where- getDefs (Max _ ls) = getDefs ls+ getDefs ms ds l = expand \ret -> case l of Max _ ls -> ret $ getDefs ms ds ls instance GetDefs PlusLevel where- getDefs (Plus _ l) = getDefs l+ getDefs ms ds l = expand \ret -> case l of Plus _ l -> ret $ getDefs ms ds l -- collection instances- instance GetDefs a => GetDefs (Maybe a) where-instance GetDefs a => GetDefs [a] where+ {-# INLINE getDefs #-}+ getDefs ms ds ma = expand \ret -> case ma of+ Nothing -> ret mempty+ Just a -> ret $ getDefs ms ds a++instance GetDefs a => GetDefs [a] where+ {-# INLINE getDefs #-}+ getDefs ms ds = go where+ go as = expand \ret -> case as of+ [] -> ret mempty+ a:as -> ret $ getDefs ms ds a <> go as+ instance GetDefs a => GetDefs (Elim' a) where-instance GetDefs a => GetDefs (Arg a) where-instance GetDefs a => GetDefs (Dom a) where-instance GetDefs a => GetDefs (Abs a) where+ {-# INLINE getDefs #-}+ getDefs ms ds e = expand \ret -> case e of+ Apply t -> ret $ getDefs ms ds t+ Proj _ _ -> ret $ mempty+ IApply l r t -> ret $ getDefs ms ds l <> getDefs ms ds r <> getDefs ms ds t +instance GetDefs a => GetDefs (Arg a) where+ {-# INLINE getDefs #-}+ getDefs ms ds a = expand \ret -> case a of+ Arg _ t -> ret $ getDefs ms ds t++instance GetDefs a => GetDefs (Dom a) where+ {-# INLINE getDefs #-}+ getDefs ms ds d = expand \ret -> case d of+ Dom _ _ _ _ _ t -> ret $ getDefs ms ds t++instance GetDefs a => GetDefs (Abs a) where+ {-# INLINE getDefs #-}+ getDefs ms ds a = expand \ret -> case a of+ Abs _ t -> ret $ getDefs ms ds t+ NoAbs _ t -> ret $ getDefs ms ds t+ instance (GetDefs a, GetDefs b) => GetDefs (a,b) where- getDefs (a,b) = getDefs a >> getDefs b+ {-# INLINE getDefs #-}+ getDefs ms ds ab = expand \ret -> case ab of (a,b) -> ret $ getDefs ms ds a <> getDefs ms ds b instance GetDefs Telescope where- getDefs = getDefs . telToList+ getDefs ms ds = getDefs ms ds . telToList -- no defs here- instance {-# OVERLAPPING #-} GetDefs String where- getDefs _ = return ()+ getDefs _ _ _ = mempty
src/full/Agda/Syntax/Internal/Elim.hs view
@@ -12,11 +12,12 @@ import Agda.Utils.Empty import Agda.Utils.Maybe import Agda.Utils.Tuple+import Agda.Utils.Impossible -- | Eliminations, subsuming applications and projections. -- data Elim' a- = Apply (Arg a) -- ^ Application.+ = Apply {-# UNPACK #-} !(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 (Show, Functor, Foldable, Traversable)@@ -32,12 +33,20 @@ mapOrigin f e@Proj{} = e mapOrigin f e@IApply{} = e +{-# INLINE isApplyElim #-} -- | Drop 'Apply' constructor. (Safe) isApplyElim :: Elim' a -> Maybe (Arg a) isApplyElim (Apply u) = Just u isApplyElim Proj{} = Nothing-isApplyElim (IApply _ _ r) = Just (defaultArg r)+isApplyElim (IApply _ _ r) = Just $! defaultArg r +{-# INLINE mustApplyElim #-}+-- | Drop 'Apply' constructor, fails with @__IMPOSSIBLE__@ on a projection.+mustApplyElim :: Elim' a -> Arg a+mustApplyElim (Apply u) = u+mustApplyElim Proj{} = __IMPOSSIBLE__+mustApplyElim (IApply _ _ r) = defaultArg r+ isApplyElim' :: Empty -> Elim' a -> Arg a isApplyElim' e = fromMaybe (absurd e) . isApplyElim @@ -52,9 +61,18 @@ allApplyElims :: [Elim' a] -> Maybe [Arg a] allApplyElims = mapM isApplyElim +-- | Drop 'Apply' constructors, fails with @__IMPOSSIBLE__@ if there's+-- a non-'Apply' entry.+mustAllApplyElims :: [Elim' a] -> [Arg a]+mustAllApplyElims [] = []+mustAllApplyElims (a:as) = case a of+ Apply a -> (a :) $! mustAllApplyElims as+ Proj{} -> __IMPOSSIBLE__+ IApply _ _ r -> let !a = defaultArg r in (a :) $! mustAllApplyElims as+ -- | Split at first non-'Apply' splitApplyElims :: [Elim' a] -> ([Arg a], [Elim' a])-splitApplyElims (Apply u : es) = mapFst (u :) $ splitApplyElims es+splitApplyElims (Apply u : es) = first (u :) $! splitApplyElims es splitApplyElims es = ([], es) class IsProjElim e where
src/full/Agda/Syntax/Internal/Generic.hs view
@@ -56,7 +56,7 @@ instance TermLike a => TermLike (Elim' a) where instance TermLike a => TermLike (Arg a) where-instance TermLike a => TermLike (Dom a) where+instance (TermLike a, TermLike b) => TermLike (Dom' a b) where instance TermLike a => TermLike [a] where instance TermLike a => TermLike (List1 a) where instance TermLike a => TermLike (Maybe a) where@@ -64,6 +64,7 @@ instance TermLike a => TermLike (Abs a) where instance TermLike a => TermLike (Tele a) where instance TermLike a => TermLike (WithHiding a) where+instance TermLike a => TermLike (BlockedDepCheck a) where -- Tuples @@ -117,7 +118,7 @@ traverseTermM f (Plus n l) = Plus n <$> traverseTermM f l foldTerm f (Plus _ l) = foldTerm f l -instance TermLike Type where+instance (TermLike b) => TermLike (Type'' a b) where traverseTermM f (El s t) = El s <$> traverseTermM f t foldTerm f (El s t) = foldTerm f t @@ -129,7 +130,9 @@ s@LockUniv -> pure s s@LevelUniv -> pure s s@IntervalUniv -> pure s- PiSort a b c -> PiSort <$> traverseTermM f a <*> traverseTermM f b <*> traverseTermM f c+ PiSort a b c d -> PiSort <$>+ traverseTermM f a <*> traverseTermM f b <*>+ traverseTermM f c <*> traverseTermM f d FunSort a b -> FunSort <$> traverseTermM f a <*> traverseTermM f b UnivSort a -> UnivSort <$> traverseTermM f a MetaS x es -> MetaS x <$> traverseTermM f es@@ -143,7 +146,8 @@ LockUniv -> mempty LevelUniv -> mempty IntervalUniv -> mempty- PiSort a b c -> foldTerm f a <> foldTerm f b <> foldTerm f c+ PiSort a b c d ->+ foldTerm f a <> foldTerm f b <> foldTerm f c <> foldTerm f d FunSort a b -> foldTerm f a <> foldTerm f b UnivSort a -> foldTerm f a MetaS _ es -> foldTerm f es
src/full/Agda/Syntax/Internal/MetaVars.hs view
@@ -21,18 +21,27 @@ -- Default instances instance AllMetas Term-instance AllMetas Type+instance (TermLike a, TermLike b) => AllMetas (Type'' a b) instance TermLike a => AllMetas (Elim' a) instance TermLike a => AllMetas (Tele a) -instance (AllMetas a, AllMetas b) => AllMetas (Dom' a b) where- allMetas f (Dom _ _ _ t e) = allMetas f t <> allMetas f e+instance (TermLike a, AllMetas a, AllMetas b) => AllMetas (Dom' a b) where+ allMetas f (Dom _ _ _ t r e) = allMetas f t <> allMetas f r <> 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 (TermLike a, AllMetas a) => AllMetas (RewDom' a) where+ allMetas f (RewDom a b) = allMetas f (a, b)++instance (TermLike a, AllMetas a) => AllMetas (LocalEquation' a) where+ allMetas f (LocalEquation a b c d) = allMetas f (a, b, c, d)++instance AllMetas RewriteRule where+ allMetas f (RewriteRule g _ _ es b) = allMetas f (g, es, b)+ instance {-# OVERLAPPING #-} AllMetas String where allMetas f _ = mempty @@ -63,7 +72,9 @@ sortMetas LockUniv{} = mempty sortMetas LevelUniv = 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 (PiSort c _ s1 s2) =+ -- the domain is a term so is covered by the fold+ foldMap sortMetas c <> sortMetas s1 <> sortMetas (unAbs s2) sortMetas (FunSort a b) = sortMetas a <> sortMetas b sortMetas (UnivSort s) = sortMetas s sortMetas (MetaS x _) = singl x
src/full/Agda/Syntax/Internal/Names.hs view
@@ -11,15 +11,16 @@ import Agda.Syntax.Common import Agda.Syntax.Literal import Agda.Syntax.Internal-import qualified Agda.Syntax.Concrete as C-import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Concrete qualified as C+import Agda.Syntax.Abstract qualified as A+import Agda.Syntax.Abstract (PatternSynDefn(..)) 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.Maybe.Strict qualified as Strict import Agda.Utils.Singleton import Agda.Utils.Impossible @@ -85,11 +86,11 @@ instance NamesIn a => NamesIn (WithArity a) instance NamesIn a => NamesIn (Open a) instance NamesIn a => NamesIn (C.FieldAssignment' a)+instance NamesIn a => NamesIn (BlockedDepCheck a) instance (NamesIn a, NamesIn b) => NamesIn (Dom' a b) where- namesAndMetasIn' sg (Dom _ _ _ t e) =- mappend (namesAndMetasIn' sg t) (namesAndMetasIn' sg e)-+ namesAndMetasIn' sg (Dom _ _ _ t r e) =+ namesAndMetasIn' sg (t, r, e) -- Specific collections instance NamesIn a => NamesIn (Tele a)@@ -144,30 +145,36 @@ instance NamesIn Bool where namesAndMetasIn' _ _ = mempty +instance NamesIn Int 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. instance NamesIn Definition where namesAndMetasIn' sg- (Defn _ _ t _ _ _ disp _ _ _ _ _ _ _ _ _ _ def) =+ (Defn _ _ t _ _ _ disp _ _ _ _ _ _ _ _ _ _ _ def) = namesAndMetasIn' sg (t, def, disp) instance NamesIn Defn where namesAndMetasIn' sg = \case Axiom _ -> mempty- DataOrRecSig _ -> 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 cl cc _ _ _ _ _ _ _ _ el _ _ _- -> namesAndMetasIn' sg (cl, cc, el)- Datatype _ _ cl cs s _ _ _ trX trD+ Function cl cc _ _ _ _ _ prj _ _ el _ _ _+ -- Andreas, 2025-11-18, issue #8037+ -- When copying the record type along with one of its projections in a module application,+ -- we need to make sure the record type has not been deleted as deadcode.+ -> namesAndMetasIn' sg (cl, cc, el, prj)+ Datatype _ _ cl cs s _ _ _ _ trX trD -> namesAndMetasIn' sg (cl, cs, s, trX, trD)- Record _ cl c _ fs recTel _ _ _ _ _ _ comp+ Record _ cl c _ fs recTel _ _ _ _ _ _ _ comp -> namesAndMetasIn' sg (cl, c, fs, recTel, comp)- Constructor _ _ c d _ kit fs _ _ _ _+ Constructor _ _ c d _ _ kit fs _ _ _ _ -> namesAndMetasIn' sg (c, d, kit, fs) Primitive _ _ cl _ cc _ -> namesAndMetasIn' sg (cl, cc)@@ -176,10 +183,25 @@ namesAndMetasIn' sg (Clause _ _ tel ps b t _ _ _ _ _) = namesAndMetasIn' sg (tel, ps, b, t) +instance NamesIn ProjectionLikenessMissing where+ {-# INLINE namesAndMetasIn' #-}+ namesAndMetasIn' _ = mempty++instance NamesIn Projection where+ {-# INLINE namesAndMetasIn' #-}+ namesAndMetasIn' sg p = namesAndMetasIn' sg (projProper p)++instance (NamesIn a, NamesIn b) => NamesIn (Either a b) where+ {-# INLINE namesAndMetasIn' #-}+ namesAndMetasIn' sg = \case+ Left a -> namesAndMetasIn' sg a+ Right b -> namesAndMetasIn' sg b+ instance NamesIn CompiledClauses where- namesAndMetasIn' sg (Case _ c) = namesAndMetasIn' sg c- namesAndMetasIn' sg (Done _ v) = namesAndMetasIn' sg v- namesAndMetasIn' sg (Fail _) = mempty+ namesAndMetasIn' sg = \case+ Case _ c -> namesAndMetasIn' sg c+ Done _ _ _ v -> namesAndMetasIn' sg v+ Fail _ -> mempty -- Andreas, 2017-07-27 -- Why ignoring the litBranches?@@ -197,10 +219,10 @@ ProjP _ f -> namesAndMetasIn' sg f IApplyP _ t u _ -> namesAndMetasIn' sg (t, u) -instance NamesIn a => NamesIn (Type' a) where+instance (NamesIn a, NamesIn b) => NamesIn (Type'' a b) where namesAndMetasIn' sg (El s t) = namesAndMetasIn' sg (s, t) -instance NamesIn Sort where+instance NamesIn a => NamesIn (Sort' a) where namesAndMetasIn' sg = \case Univ _ l -> namesAndMetasIn' sg l Inf _ _ -> mempty@@ -208,7 +230,7 @@ LockUniv -> mempty LevelUniv -> mempty IntervalUniv -> mempty- PiSort a b c -> namesAndMetasIn' sg (a, b, c)+ PiSort a b c d -> namesAndMetasIn' sg (a, b, c, d) FunSort a b -> namesAndMetasIn' sg (a, b) UnivSort a -> namesAndMetasIn' sg a MetaS x es -> namesAndMetasIn' sg (x, es)@@ -229,10 +251,10 @@ DontCare v -> namesAndMetasIn' sg v Dummy _ args -> namesAndMetasIn' sg args -instance NamesIn Level where+instance NamesIn a => NamesIn (Level' a) where namesAndMetasIn' sg (Max _ ls) = namesAndMetasIn' sg ls -instance NamesIn PlusLevel where+instance NamesIn a => NamesIn (PlusLevel' a) where namesAndMetasIn' sg (Plus _ l) = namesAndMetasIn' sg l -- For QName and Meta literals!@@ -288,7 +310,7 @@ instance NamesIn NLPat where namesAndMetasIn' sg = \case- PVar _ _ -> mempty+ PVar _ _ _ -> mempty PDef a b -> namesAndMetasIn' sg (a, b) PLam _ a -> namesAndMetasIn' sg a PPi a b -> namesAndMetasIn' sg (a, b)@@ -309,12 +331,27 @@ PLevelUniv -> mempty PIntervalUniv -> mempty -instance NamesIn RewriteRule where+instance NamesIn GlobalRewriteRule where namesAndMetasIn' sg = \case- RewriteRule a b c d e f _ _ ->+ GlobalRewriteRule a b c d e f _ _ -> namesAndMetasIn' sg (a, b, c, d, e, f) -instance (NamesIn a, NamesIn b) => NamesIn (HashMap a b) where+instance NamesIn a => NamesIn (LocalEquation' a) where+ namesAndMetasIn' sg (LocalEquation a b c d) = namesAndMetasIn' sg (a, b, c, d)++instance NamesIn RewriteHead where+ namesAndMetasIn' sg (RewVarHead a) = namesAndMetasIn' sg a+ namesAndMetasIn' sg (RewDefHead a) = namesAndMetasIn' sg a++instance NamesIn RewriteRule where+ namesAndMetasIn' sg (RewriteRule a b c d e) =+ namesAndMetasIn' sg (a, b, c, d, e)++instance NamesIn a => NamesIn (RewDom' a) where+ namesAndMetasIn' sg (RewDom a b) =+ namesAndMetasIn' sg (a, b)++instance (NamesIn b) => NamesIn (HashMap a b) where namesAndMetasIn' sg map = foldMap (namesAndMetasIn' sg) map instance NamesIn System where@@ -337,7 +374,7 @@ TLam t -> namesAndMetasIn' sg t TLit l -> namesAndMetasIn' sg l TCon x -> namesAndMetasIn' sg x- TLet t1 t2 -> namesAndMetasIn' sg (t1, t2)+ TLet _ t1 t2 -> namesAndMetasIn' sg (t1, t2) TCase _ c t ts -> namesAndMetasIn' sg (c, t, ts) TUnit -> mempty TSort -> mempty@@ -362,19 +399,18 @@ CTQName -> mempty instance NamesIn CaseInfo where- namesAndMetasIn' sg (CaseInfo _ _ t) = namesAndMetasIn' sg t+ 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- namesAndMetasIn' sg (PSyn (_args, p)) = namesAndMetasIn' sg p+instance NamesIn PatternSynDefn where+ namesAndMetasIn' sg (PatternSynDefn _args p) = namesAndMetasIn' sg p instance NamesIn ConPatternInfo where- namesAndMetasIn' sg (ConPatternInfo _ _ _ ty _) = namesAndMetasIn' sg ty+ namesAndMetasIn' sg (ConPatternInfo _ _ _ ty _ _) = namesAndMetasIn' sg ty instance NamesIn (A.Pattern' a) where namesAndMetasIn' sg = \case@@ -393,4 +429,4 @@ A.WithP _ p -> namesAndMetasIn' sg p instance NamesIn AmbiguousQName where- namesAndMetasIn' sg (AmbQ cs) = namesAndMetasIn' sg cs+ namesAndMetasIn' sg = namesAndMetasIn' sg . getAmbiguous
src/full/Agda/Syntax/Internal/Pattern.hs view
@@ -2,7 +2,6 @@ module Agda.Syntax.Internal.Pattern where -import Control.Arrow ( second ) import Control.Monad ( (>=>), forM ) import Control.Monad.State ( MonadState(..), State, evalState ) @@ -16,6 +15,7 @@ import Agda.Utils.List import Agda.Utils.Permutation import Agda.Utils.Size (size)+import Agda.Utils.Tuple ( second ) import Agda.Utils.Impossible @@ -26,7 +26,7 @@ -- -- Precondition: no projection patterns. clauseArgs :: Clause -> Args-clauseArgs cl = fromMaybe __IMPOSSIBLE__ $ allApplyElims $ clauseElims cl+clauseArgs cl = mustAllApplyElims $ clauseElims cl -- | Translate the clause patterns to an elimination spine -- with free variables bound by the clause telescope.@@ -49,7 +49,7 @@ -- | Get the number of common initial 'Apply' patterns in a list of clauses. instance {-# OVERLAPPING #-} FunArity [Clause] where funArity [] = 0- funArity cls = minimum $ map funArity cls+ funArity cls = minimum $ map' funArity cls -- * Tools for patterns @@ -165,17 +165,17 @@ patternToElim :: Arg DeBruijnPattern -> Elim patternToElim (Arg ai (VarP o x)) = Apply $ Arg ai $ var $ dbPatVarIndex x patternToElim (Arg ai (ConP c cpi ps)) = Apply $ Arg ai $ Con c ci $- map (patternToElim . fmap namedThing) ps+ map' (patternToElim . fmap namedThing) ps where ci = fromConPatternInfo cpi patternToElim (Arg ai (DefP o q ps)) = Apply $ Arg ai $ Def q $- map (patternToElim . fmap namedThing) ps+ map' (patternToElim . fmap namedThing) ps patternToElim (Arg ai (DotP o t) ) = Apply $ Arg ai t patternToElim (Arg ai (LitP o l) ) = Apply $ Arg ai $ Lit l patternToElim (Arg ai (ProjP o dest)) = Proj o dest patternToElim (Arg ai (IApplyP o t u x)) = IApply t u $ var $ dbPatVarIndex x patternsToElims :: [NamedArg DeBruijnPattern] -> [Elim]-patternsToElims ps = map build ps+patternsToElims ps = map' build ps where build :: NamedArg DeBruijnPattern -> Elim build = patternToElim . fmap namedThing@@ -228,6 +228,7 @@ -- ^ Combine a pattern and the value computed from its subpatterns. -> b -> m + {-# INLINE foldrPattern #-} default foldrPattern :: (Monoid m, Foldable f, PatternLike a p, f p ~ b) => (Pattern' a -> m -> m) -> b -> m@@ -315,9 +316,13 @@ countPatternVars p = case p of VarP{} -> 1+ LitP{} -> 0+ ProjP{} -> 0 ConP _ _ ps -> countPatternVars ps DotP{} -> 1 -- dot patterns are treated as variables in the clauses- _ -> 0+ -- Andreas, 2026-05-01, issue #7629, need to also count interval variables:+ IApplyP{} -> 1+ DefP _ _ ps -> countPatternVars ps -- Computing modalities of pattern variables ------------------------------ @@ -336,7 +341,7 @@ instance PatternVarModalities a => PatternVarModalities (Arg a) where type PatVar (Arg a) = PatVar a- patternVarModalities arg = map (second (composeModality m)) (patternVarModalities $ unArg arg)+ patternVarModalities arg = map' (second (composeModality m)) (patternVarModalities $ unArg arg) where m = getModality arg -- UNUSED:
src/full/Agda/Syntax/Internal/SanityCheck.hs view
@@ -4,7 +4,6 @@ module Agda.Syntax.Internal.SanityCheck where import Control.Monad-import qualified Data.IntSet as Set import Agda.Syntax.Internal import Agda.TypeChecking.Free@@ -14,11 +13,12 @@ import Agda.Syntax.Common.Pretty import Agda.Utils.Size import Agda.Utils.Impossible+import qualified Agda.Utils.VarSet as VarSet sanityCheckVars :: (Pretty a, Free a) => Telescope -> a -> TCM () sanityCheckVars tel v =- case filter bad (Set.toList $ allFreeVars v) of+ case filter bad (VarSet.toAscList $ freeVarSet v) of [] -> return () xs -> do alwaysReportSDoc "impossible" 1 . return $
src/full/Agda/Syntax/Literal.hs view
@@ -1,3 +1,6 @@+{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-} module Agda.Syntax.Literal where @@ -9,10 +12,9 @@ import qualified Data.Text as T import Agda.Syntax.Position-import Agda.Syntax.Common-import Agda.Syntax.Abstract.Name-import Agda.Syntax.TopLevelModuleName.Boot (TopLevelModuleName')-import Agda.Syntax.Position (Range)+import Agda.Syntax.Common ( Ranged, MetaId )+import Agda.Syntax.Abstract.Name ( QName )+import Agda.Syntax.TopLevelModuleName.Boot ( TopLevelModuleName' ) import Agda.Utils.Float ( doubleDenotEq, doubleDenotOrd ) import Agda.Syntax.Common.Pretty
src/full/Agda/Syntax/Notation.hs view
@@ -1,4 +1,6 @@ {-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-} {-| As a concrete name, a notation is a non-empty list of alternating 'IdPart's and holes. In contrast to concrete names, holes can be binders.@@ -13,7 +15,7 @@ module Agda.Syntax.Notation where -import Prelude hiding (null)+import Prelude hiding ( null, zip, zipWith ) import Control.DeepSeq import Control.Monad@@ -27,17 +29,19 @@ import Agda.Syntax.Common import Agda.Syntax.Common.Pretty import Agda.Syntax.Concrete.Name-import Agda.Syntax.Concrete.Pretty() import Agda.Syntax.Position import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.List1 ( List1, pattern (:|) ) import qualified Agda.Utils.List1 as List1+import Agda.Utils.ListInf ( pattern (:<) )+import qualified Agda.Utils.ListInf as ListInf import Agda.Utils.Set1 ( Set1 ) import qualified Agda.Utils.Set1 as Set1 import Agda.Utils.Null import Agda.Utils.Singleton+import Agda.Utils.Zip import Agda.Utils.Impossible @@ -102,6 +106,15 @@ (False, True ) -> PrefixNotation (False, False) -> NonfixNotation +-- | Analogue of 'isPrePostOrInfixOperator': prefix, infix, or postfix.+isPrePostOrInfixNotation :: Notation -> Bool+isPrePostOrInfixNotation n = case notationKind n of+ InfixNotation -> True+ PrefixNotation -> True+ PostfixNotation -> True+ NonfixNotation -> False+ NoNotation -> False+ -- | From notation with names to notation with indices. -- -- An example (with some parts of the code omitted):@@ -222,7 +235,7 @@ _ -> False) where noAdj [] = __IMPOSSIBLE__- noAdj [x] = True+ noAdj [_] = True noAdj (x:y:xs) = not (isAHole x && isAHole y) && noAdj (y:xs)@@ -276,7 +289,7 @@ -- @M.for x ∈ xs return e@, or @x ℕ.+ y@. notationNames :: NewNotation -> [QName] notationNames (NewNotation q _ _ parts _) =- zipWith ($) (reQualify : repeat QName) [simpleName $ rangedThing x | IdPart x <- parts ]+ zipWith ($) (reQualify :< ListInf.repeat QName) [ simpleName $ rangedThing x | IdPart x <- parts ] where -- The qualification of @q@. modules = List1.init (qnameParts q)@@ -296,7 +309,7 @@ -- numbering the holes from left to right. -- Result will have no 'BindingHole's. mkSyn :: Int -> [NamePart] -> Notation- mkSyn n [] = []+ mkSyn _ [] = [] mkSyn n (Hole : xs) = HolePart noRange (defaultNamedArg $ unranged n) : mkSyn (1 + n) xs mkSyn n (Id x : xs) = IdPart (unranged x) : mkSyn n xs
src/full/Agda/Syntax/Parser.hs view
@@ -3,8 +3,9 @@ ( -- * Types Parser -- * Parse functions- , Agda.Syntax.Parser.parse- , Agda.Syntax.Parser.parsePosString+ , parse+ , parsePosString+ , parseRangeString , parseFile -- * Parsers , moduleParser@@ -35,7 +36,10 @@ import Agda.Syntax.Common import Agda.Syntax.Position-import Agda.Syntax.Parser.Monad as M hiding (Parser, parseFlags)+import Agda.Syntax.Parser.Monad+ ( ParseError(..), ParseWarning(..), ParseResult(..), ParseFlags, LexState+ , ParseState (parseWarnings, parseAttributes), defaultParseFlags, parseKeepComments+ ) import qualified Agda.Syntax.Parser.Monad as M import qualified Agda.Syntax.Parser.Parser as P import Agda.Syntax.Parser.Lexer@@ -46,7 +50,7 @@ import Agda.Utils.FileName import Agda.Utils.IO.UTF8 (readTextFile)-import Agda.Utils.Maybe (forMaybe)+import Agda.Utils.Maybe (forMaybe, fromMaybe) import qualified Agda.Utils.Maybe.Strict as Strict ------------------------------------------------------------------------@@ -170,25 +174,37 @@ parsePosString :: Parser a -> Position -> String -> PM (a, Attributes) parsePosString p pos = wrapM . return . M.parsePosString pos (parseFlags p) normalLexState (parser p) +-- | Calls 'parsePosString' with 'Position' extracted from the Range.+parseRangeString :: Parser a -> Range -> String -> PM (a, Attributes)+parseRangeString p = parsePosString p . fromMaybe (startPos Nothing) . rStart+ -- | Extensions supported by `parseFile`. agdaFileExtensions :: [String]-agdaFileExtensions = ".agda" : (fst <$> literateProcessors)+agdaFileExtensions = ".agda" : literateExts -parseFile- :: Show a- => Parser a+-- | Parse a file.+--+-- The 'Bool' parameter controls whether only @```agda@ blocks+-- are treated as Agda code in Markdown/Typst files.+-- When @True@, only blocks marked @```agda@ are considered code.+-- When @False@, both @```@ and @```agda@ blocks are code (default).++parseFile ::+ Bool+ -- ^ When @True@, only treat @```agda@ blocks as code in Markdown/Typst.+ -> Parser a -> RangeFile -- ^ The file. -> String -- ^ The file contents. Note that the file is /not/ read from -- disk. -> PM ((a, Attributes), FileType)-parseFile p file input =+parseFile onlyAgdaBlocks p file input = if ".agda" `List.isSuffixOf` path then (, AgdaFileType) <$> parseFileFromString (Strict.Just file) p input else- go literateProcessors+ go (literateProcessors onlyAgdaBlocks) where path = filePath (rangeFilePath file)
src/full/Agda/Syntax/Parser/Alex.hs view
@@ -21,6 +21,7 @@ import Control.Monad.State import Data.Char import Data.Word+import GHC.Exts (oneShot) import Agda.Syntax.Position import Agda.Syntax.Parser.Monad@@ -32,7 +33,7 @@ data AlexInput = AlexInput { lexSrcFile :: !SrcFile -- ^ File. , lexPos :: !PositionWithoutFile -- ^ Current position.- , lexInput :: String -- ^ Current input.+ , lexInput :: !String -- ^ Current input. , lexPrevChar :: !Char -- ^ Previously read character. } @@ -79,7 +80,7 @@ alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) alexGetByte ai =- mapFst (fromIntegral . fromEnum . toASCII) <$> alexGetChar ai+ first (fromIntegral . fromEnum . toASCII) <$> alexGetChar ai where toASCII c | isSpace c && c /= '\t' && c /= '\n' = ' '@@ -119,25 +120,30 @@ type CurrentInput = AlexInput type TokenLength = Int --- | In the lexer, regular expressions are associated with lex actions who's--- task it is to construct the tokens.+-- | In the lexer, regular expressions are associated with lex actions whose+-- task is to construct the tokens. newtype LexAction r = LexAction { runLexAction :: PreviousInput -> CurrentInput -> TokenLength -> Parser r } deriving (Functor) instance Applicative LexAction where- pure r = LexAction $ \ _ _ _ -> pure r- mf <*> mr = LexAction $ \ a b c -> runLexAction mf a b c <*> runLexAction mr a b c+ {-# INLINE pure #-}+ pure r = LexAction (oneShot \ _ _ _ -> pure r)+ {-# INLINE (<*>) #-}+ mf <*> mr = LexAction (oneShot \ a b c -> runLexAction mf a b c <*> runLexAction mr a b c) instance Monad LexAction where return = pure- m >>= k = LexAction $ \ a b c -> do+ {-# INLINE (>>=) #-}+ m >>= k = LexAction (oneShot \ a b c -> do r <- runLexAction m a b c- runLexAction (k r) a b c+ runLexAction (k r) a b c) instance MonadState ParseState LexAction where- get = LexAction $ \ _ _ _ -> get- put s = LexAction $ \ _ _ _ -> put s+ {-# INLINE get #-}+ get = LexAction (oneShot (\ _ _ _ -> get))+ {-# INLINE put #-}+ put s = LexAction (oneShot (\ _ _ _ -> put s)) -- | Sometimes regular expressions aren't enough. Alex provides a way to do -- arbitrary computations to see if the input matches. This is done with a
src/full/Agda/Syntax/Parser/Comments.hs view
@@ -44,7 +44,7 @@ let p1 = lexPos inp; p2 = lexPos inp'' i = posToInterval (lexSrcFile inp) p1 p2 s = case (p1, p2) of- (Pn { posPos = p1 }, Pn { posPos = p2 }) ->+ (Pn' { posPos = p1 }, Pn' { posPos = p2 }) -> List.genericTake (p2 - p1) $ lexInput inp return $ TokComment (i, s) else
src/full/Agda/Syntax/Parser/Helpers.hs view
@@ -1,5 +1,7 @@ -- | Utility functions used in the Happy parser. +{-# OPTIONS_GHC -Wunused-matches #-}+ module Agda.Syntax.Parser.Helpers where import Prelude hiding (null)@@ -11,7 +13,7 @@ import Data.Char import qualified Data.List as List import Data.Maybe-import Data.Semigroup ((<>), sconcat)+import Data.Semigroup ( sconcat ) import Data.Text (Text) import qualified Data.Text as T @@ -33,60 +35,75 @@ import Agda.Utils.Hash import Agda.Utils.List ( spanJust, chopWhen, initLast ) import Agda.Utils.List1 ( List1, pattern (:|), (<|) )+import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Syntax.Common.Pretty hiding ((<>))+import Agda.Syntax.Common.Pretty import Agda.Utils.Singleton import qualified Agda.Utils.Maybe.Strict as Strict import qualified Agda.Utils.List1 as List1 import qualified Agda.Utils.List2 as List2 import Agda.Utils.Impossible---- | Grab leading OPTIONS pragmas.-takeOptionsPragmas :: [Declaration] -> Module-takeOptionsPragmas = uncurry Mod . spanJust (\ d -> case d of- Pragma p@OptionsPragma{} -> Just p- _ -> Nothing)+import Data.List (partition) -- | Insert a top-level module if there is none. -- Also fix-up for the case the declarations in the top-level module -- are not indented (this is allowed as a special case).-figureOutTopLevelModule :: [Declaration] -> [Declaration]-figureOutTopLevelModule ds =- case spanAllowedBeforeModule ds of- -- Andreas 2016-02-01, issue #1388.- -- We need to distinguish two additional cases.+figureOutTopLevelModule :: [Declaration] -> Module+figureOutTopLevelModule ds00 = Mod moduleName optionPragmas decls+ where+ -- First, we grab the leading OPTIONS pragmas.+ (optionPragmas, ds) = (`spanJust` ds00) \case+ Pragma p@OptionsPragma{} -> Just p+ _ -> Nothing - -- Case 1: Regular file layout: imports followed by one module. Nothing to do.- (ds0, [ Module{} ]) -> ds+ -- Then, we look for a top-level module and insert one if we cannot find one.+ (moduleName, decls) = case break isModule ds of - -- Case 2: The declarations in the module are not indented.- -- This is allowed for the top level module, and thus rectified here.- (ds0, Module r erased m tel [] : ds2) ->- ds0 ++ [Module r erased m tel ds2]+ -- Andreas, 2026-02-19, issue #7988:+ -- Case 1: If the first module is a qualified one, this must be the top-level module.+ (ds0, Module r erased m@Qual{} tel ds1 : ds2) ->+ (m, ds0 ++ Module r erased m tel ds1' : ds2')+ where (ds1', ds2') = rectifyNonIndentedDecls ds1 ds2 - -- Case 3: There is a module with indented declarations,- -- followed by non-indented declarations. This should be a- -- parse error and be reported later (see @toAbstract TopLevel{}@),- -- thus, we do not do anything here.- (ds0, Module r _ m tel ds1 : ds2) -> ds -- Gives parse error in scope checker.- -- OLD code causing issue 1388:- -- (ds0, Module r m tel ds1 : ds2) -> ds0 ++ [Module r m tel $ ds1 ++ ds2]+ -- Otherwise, we check what happens after the declarations that are allowed+ -- before the top-level module.+ _ -> case spanAllowedBeforeModule ds of - -- Case 4: a top-level module declaration is missing.- -- Andreas, 2017-01-01, issue #2229:- -- Put everything (except OPTIONS pragmas) into an anonymous module.- _ -> ds0 ++ [Module r defaultErased (QName $ noName r) [] ds1]- where- (ds0, ds1) = (`span` ds) $ \case- Pragma OptionsPragma{} -> True- _ -> False- -- Andreas, 2017-05-17, issue #2574.- -- Since the module noName will act as jump target, it needs a range.- -- We use the beginning of the file as beginning of the top level module.- r = beginningOfFile $ getRange ds1+ -- Andreas 2016-02-01, issue #1388.+ -- We need to distinguish two additional cases. + -- Case 2: Regular file layout: imports followed by one module.+ -- The declarations in the module may not be indented.+ -- This is allowed for the top level module, and thus rectified here.+ (ds0, Module r erased m tel ds1 : ds2) ->+ (m, ds0 ++ Module r erased m tel ds1' : ds2')+ where (ds1', ds2') = rectifyNonIndentedDecls ds1 ds2++ -- Case 3: a top-level module declaration is missing.+ -- Andreas, 2017-01-01, issue #2229:+ -- Put everything (except OPTIONS pragmas) into an anonymous module.+ _ -> (m, [Module r defaultErased m [] ds])+ where+ m = QName $ noName r+ -- Andreas, 2017-05-17, issue #2574.+ -- Since the module noName will act as jump target, it needs a range.+ -- We use the beginning of the file as beginning of the top level module.+ r = beginningOfFile $ getRange ds++ -- Helper to move unindented declarations into the top-level module.+ -- This is when an empty first module @null ds1@ is followed by (unindented) declarations @ds2@.+ -- If both ds1 and ds2 are non-empty, this will be an error in the scope checker;+ -- we can let it through here.+ rectifyNonIndentedDecls ds1 ds2 = if null ds1 then (ds2, []) else (ds1, ds2)++-- | Is the given declaration a module definition?+isModule :: Declaration -> Bool+isModule = \case+ Module{} -> True+ _ -> False+ -- | Create a name from a string. The boolean indicates whether a part -- of the name can be token 'constructor'. mkName' :: Bool -> (Interval, String) -> Parser Name@@ -120,43 +137,47 @@ isValidId con (Id y) = do let x = rawNameToString y err = "in the name " ++ s ++ ", the part " ++ x ++ " is not valid"- case parse defaultParseFlags [0] (lexer return) x of+ case parse defaultParseFlags [0] (lexer return) (x <> " ") of ParseOk _ TokId{} -> return () ParseFailed{} -> parseError err ParseOk _ TokEOF{} -> parseError err ParseOk _ (TokKeyword KwConstructor _) | con -> pure () ParseOk _ t -> parseError . ((err ++ " because it is ") ++) $ case t of TokQId{} -> "qualified"+ TokQual q _ _ -> case q of+ QualDo -> "a qualified do-block"+ QualOpenIdiom{} -> "a qualified idiom bracket"+ QualEmptyIdiom{} -> "a qualified empty idiom bracket" TokKeyword{} -> "a keyword" TokLiteral{} -> "a literal" TokSymbol s _ -> case s of- SymDot -> __IMPOSSIBLE__ -- "reserved"- SymSemi -> "used to separate declarations"- SymVirtualSemi -> __IMPOSSIBLE__- SymBar -> "used for with-arguments"- SymColon -> "part of declaration syntax"- SymArrow -> "the function arrow"- SymEqual -> "part of declaration syntax"- SymLambda -> "used for lambda-abstraction"- SymUnderscore -> "used for anonymous identifiers"- SymQuestionMark -> "a meta variable"- SymAs -> "used for as-patterns"- SymOpenParen -> "used to parenthesize expressions"- SymCloseParen -> "used to parenthesize expressions"- SymOpenIdiomBracket -> "an idiom bracket"- SymCloseIdiomBracket -> "an idiom bracket"- SymEmptyIdiomBracket -> "an empty idiom bracket"- SymDoubleOpenBrace -> "used for instance arguments"- SymDoubleCloseBrace -> "used for instance arguments"- SymOpenBrace -> "used for hidden arguments"- SymCloseBrace -> "used for hidden arguments"- SymOpenVirtualBrace -> __IMPOSSIBLE__- SymCloseVirtualBrace -> __IMPOSSIBLE__- SymOpenPragma -> "used for pragmas"- SymClosePragma -> "used for pragmas"- SymEllipsis -> "used for function clauses"- SymDotDot -> "a modality"- SymEndComment -> "the end-of-comment brace"+ SymDot -> __IMPOSSIBLE__ -- "reserved"+ SymSemi -> "used to separate declarations"+ SymVirtualSemi -> __IMPOSSIBLE__+ SymBar -> "used for with-arguments"+ SymColon -> "part of declaration syntax"+ SymArrow -> "the function arrow"+ SymEqual -> "part of declaration syntax"+ SymLambda -> "used for lambda-abstraction"+ SymUnderscore -> "used for anonymous identifiers"+ SymQuestionMark -> "a meta variable"+ SymAs -> "used for as-patterns"+ SymOpenParen -> "used to parenthesize expressions"+ SymCloseParen -> "used to parenthesize expressions"+ SymOpenIdiomBracket{} -> "an idiom bracket"+ SymCloseIdiomBracket{} -> "an idiom bracket"+ SymEmptyIdiomBracket -> "an empty idiom bracket"+ SymDoubleOpenBrace{} -> "used for instance arguments"+ SymDoubleCloseBrace{} -> "used for instance arguments"+ SymOpenBrace -> "used for hidden arguments"+ SymCloseBrace -> "used for hidden arguments"+ SymOpenVirtualBrace -> __IMPOSSIBLE__+ SymCloseVirtualBrace -> __IMPOSSIBLE__+ SymOpenPragma -> "used for pragmas"+ SymClosePragma -> "used for pragmas"+ SymEllipsis -> "used for function clauses"+ SymDotDot -> "a modality"+ SymEndComment -> "the end-of-comment brace" TokString{} -> __IMPOSSIBLE__ TokTeX{} -> __IMPOSSIBLE__ -- used by the LaTeX backend only TokMarkup{} -> __IMPOSSIBLE__ -- ditto@@ -235,10 +256,10 @@ where c0 = posCol (iStart i) - go cur [] = ""+ go _cur [] = "" go cur ((i, s) : xs) = padding cur (iStart i) ++ s ++ go (iEnd i) xs - padding Pn{ posLine = l1, posCol = c1 } Pn{ posLine = l2, posCol = c2 }+ padding (Pn _ _ l1 c1) (Pn _ _ l2 c2) | l1 < l2 = List.genericReplicate (l2 - l1) '\n' ++ List.genericReplicate (max 0 (c2 - c0)) ' ' | l1 == l2 = List.genericReplicate (c2 - c1) ' ' | otherwise = __IMPOSSIBLE__@@ -296,6 +317,7 @@ RelevanceAttribute{} -> unsup "Relevance" CohesionAttribute{} -> unsup "Cohesion" LockAttribute{} -> unsup "Lock"+ RewriteAttribute{} -> unsup "Rewrite" CA.TacticAttribute{} -> unsup "Tactic" PolarityAttribute{} -> unsup "Polarity" QuantityAttribute q -> maybe (unsup "Linearity") (return . Just) $ erasedFromQuantity q@@ -389,7 +411,7 @@ -- | Match a pattern-matching "assignment" statement @p <- e@ exprToAssignment :: Expr -> Parser (Maybe (Pattern, Range, Expr))-exprToAssignment e@(RawApp r es)+exprToAssignment e@(RawApp _r es) | (es1, arr : es2) <- List2.break isLeftArrow es = case filter isLeftArrow es2 of arr : _ -> parseError' (rStart' $ getRange arr) $ "Unexpected " ++ prettyShow arr@@ -456,7 +478,7 @@ buildDoStmt :: Expr -> [LamClause] -> Parser DoStmt buildDoStmt (Let r ds Nothing) [] = return $ DoLet r ds-buildDoStmt e@(RawApp r _) cs = do+buildDoStmt e@(RawApp _ _) cs = do mpatexpr <- exprToAssignment e case mpatexpr of Just (pat, r, expr) -> pure $ DoBind r pat expr cs@@ -514,7 +536,7 @@ case x of -- Invariant: fixity is not used here, and neither finiteness- Arg ai (Named mn (Binder mp _ (BName n fix mtac fin)))+ Arg _ (Named _ (Binder _ _ (BName _ fix _ fin))) | not $ null fix -> __IMPOSSIBLE__ | fin -> __IMPOSSIBLE__ @@ -531,14 +553,17 @@ case ai of -- Benign case:- ArgInfo h (Modality Relevant{} (Quantityω _) Continuous (PolarityModality { modPolarityAnn = MixedPolarity })) UserWritten UnknownFVs (Annotation IsNotLock) ->+ ArgInfo h (Modality Relevant{} (Quantityω _) Continuous (PolarityModality { modPolarityAnn = MixedPolarity })) UserWritten UnknownFVs (Annotation IsNotLock IsNotRewrite) -> return $ WithHiding h n -- Error cases:- ArgInfo _ _ _ _ (Annotation (IsLock _)) ->+ ArgInfo _ _ _ _ (Annotation (IsLock _) _) -> abort $ noAnn "Lock" - ArgInfo h (Modality r q c p) _ _ _+ ArgInfo _ _ _ _ (Annotation _ (IsRewrite _)) ->+ abort $ noAnn "Rewrite"++ ArgInfo _ (Modality r q c p) _ _ _ | not (isRelevant r) -> abort "Arguments to pattern synonyms must be relevant" | not (isQuantityω q) ->@@ -576,15 +601,24 @@ | TypeSigsRHS Expr deriving Show -patternToNames :: Pattern -> Parser (List1 (ArgInfo, Name))+patternToNames :: Pattern -> Parser (List1 (Arg Name)) patternToNames = \case- IdentP _ (QName i) -> return $ singleton (defaultArgInfo, i)- WildP r -> return $ singleton (defaultArgInfo, C.noName r)- DotP kwr _ (Ident (QName i)) -> return $ singleton (makeIrrelevant kwr defaultArgInfo, i)+ IdentP _ (QName i) -> return $ singleton $ defaultArg i+ WildP r -> return $ singleton $ defaultArg $ C.noName r+ DotP kwr _ _ (Ident (QName i)) -> return $ singleton $ makeIrrelevant kwr $ defaultArg i RawAppP _ ps -> sconcat . List2.toList1 <$> mapM patternToNames ps p -> parseError $ "Illegal name in type signature: " ++ prettyShow p +-- | Interpret leading dot as irrelevance++patternToArgPattern :: Pattern -> Arg Pattern+patternToArgPattern = \case+ DotP kwr _ _ (Ident x) -> makeIrrelevant kwr $ defaultArg $ IdentP True x+ DotP kwr _ _ (Underscore r _) -> makeIrrelevant kwr $ defaultArg $ WildP r+ p -> defaultArg p++ funClauseOrTypeSigs :: [Attr] -> ([RewriteEqn] -> [WithExpr] -> LHS) -> [Either RewriteEqn (List1 (Named Name Expr))] -> RHSOrTypeSigs@@ -595,15 +629,24 @@ -- traceShowM lhs case mrhs of JustRHS rhs -> do- unless (null attrs) $ parseWarning $ MisplacedAttributes (getRange attrs) "A function clause cannot have attributes"- return $ singleton $ FunClause lhs rhs wh empty+ whenJust (haveTacticAttr attrs) \ re ->+ parseWarning $ MisplacedAttributes (getRange re) $+ "Ignoring tactic attribute, illegal in function clauses"+ whenJust (haveRewAttr attrs) \ re ->+ parseWarning $ MisplacedAttributes (getRange re) $+ "Ignoring local rewrite attribute, illegal in function clauses"+ -- Andreas, 2025-07-09, issue #7989: extract irrelevance info from lhs pattern+ let (Arg info p) = patternToArgPattern $ lhsOriginalPattern lhs+ -- Andreas, 2025-07-10, issue #7988: allow attributes in function clause+ info <- applyAttrs attrs info+ return $ singleton $ FunClause info lhs{ lhsOriginalPattern = p } rhs wh empty TypeSigsRHS e -> case wh of NoWhere -> case lhs of LHS p _ _ | hasEllipsis p -> parseError "The ellipsis ... cannot have a type signature" LHS _ _ (_:_) -> parseError "Illegal: with in type signature" LHS _ (_:_) _ -> parseError "Illegal: rewrite in type signature" LHS p _ _ | hasWithPatterns p -> parseError "Illegal: with patterns in type signature"- LHS p [] [] -> forMM (patternToNames p) $ \ (info, x) -> do+ LHS p [] [] -> forMM (patternToNames p) $ \ (Arg info x) -> do info <- applyAttrs attrs info return $ typeSig info (getTacticAttr attrs) x e _ -> parseError "A type signature cannot have a where clause"@@ -648,13 +691,21 @@ toAttribute r e = do case exprToAttribute r e of Nothing -> Nothing <$ parseWarning (UnknownAttribute r s)- Just a -> do- let attr = Attr r s a- modify' \ st -> st{ parseAttributes = attr : parseAttributes st }- return $ Just attr+ Just a -> fmap Just $ theAttribute $ Attr r s a where s = prettyShow e +-- | Updates 'parseAttributes' and returns an @rewrite attribute+rewAttribute :: Range -> Parser (Maybe Attr)+rewAttribute r = fmap Just $ theAttribute $+ Attr r "rewrite" (RewriteAttribute $ IsRewrite r)++-- | Updates 'parseAttributes' and returns the attribute+theAttribute :: Attr -> Parser Attr+theAttribute attr = do+ modify' \ st -> st{ parseAttributes = attr : parseAttributes st }+ return attr+ -- | Apply an attribute to thing (usually `Arg`). -- This will fail if one of the attributes is already set -- in the thing to something else than the default value.@@ -667,6 +718,21 @@ -- Expects a reversed list of attributes. -- This will fail if one of the attributes is already set -- in the thing to something else than the default value.+applyAttrsDropTactic :: LensAttribute a => [Attr] -> a -> Parser a+applyAttrsDropTactic rattrs arg = do+ let (tactics, attrs) = partition isTactic rattrs+ unlessNull tactics \ ts ->+ parseWarning $ MisplacedAttributes (getRange ts) $+ "Ignoring misplaced @(tactic ...) attribute"+ applyAttrs attrs arg+ where+ isTactic :: Attr -> Bool+ isTactic = isJust . C.theTacticAttribute . isTacticAttribute . theAttr++-- | Apply attributes to thing (usually `Arg`).+-- Expects a reversed list of attributes.+-- This will fail if one of the attributes is already set+-- in the thing to something else than the default value. applyAttrs :: LensAttribute a => [Attr] -> a -> Parser a applyAttrs rattrs arg = do let attrs = reverse rattrs@@ -688,12 +754,23 @@ -- | Get the tactic attribute if present. getTacticAttr :: [Attr] -> TacticAttribute-getTacticAttr as = C.TacticAttribute $+getTacticAttr = C.TacticAttribute . haveTacticAttr++-- | Check if tactic attribute is present.+haveTacticAttr :: [Attr] -> Maybe (Ranged Expr)+haveTacticAttr as = case tacticAttributes [ a | Attr _ _ a <- as ] of [CA.TacticAttribute e] -> Just e [] -> Nothing _ -> __IMPOSSIBLE__ +haveRewAttr :: [Attr] -> Maybe RewriteAnn+haveRewAttr as =+ case rewAttributes $ theAttr <$> as of+ [CA.RewriteAttribute r] -> Just r+ [] -> Nothing+ _ -> __IMPOSSIBLE__+ -- | Report a parse error if two attributes in the list are of the same kind, -- thus, present conflicting information. checkForUniqueAttribute :: (Attribute -> Bool) -> [Attr] -> Parser ()@@ -730,3 +807,29 @@ applyAttributes attrs ai bs = do applyAttrs attrs ai <&> \ ai' -> fmap (setTacticAttr attrs . setArgInfo ai') bs++------------------------------------------------------------------------+-- * Brackets++-- | Turn a 'QualifiedToken' into a properly qualified name, and the+-- range of its keyword.+-- If the qualified token is an opening bracket, this also calls+-- 'openBracket'.+unqualifyToken :: QualifiedToken -> Parser (QName, Range)+unqualifyToken (QualifiedToken tok iss kw) = (,) <$> mkQName iss <*> case tok of+ QualOpenIdiom tok -> openBracket $ TokSymbol (SymOpenIdiomBracket tok) kw+ _ -> pure (getRange kw)++-- | Close a double brace from a pair of single closing braces.+--+-- This implements the rule described in the grammar that the braces+-- must be adjacent, and additionally acts as 'closeBracket', generating+-- the proper error if the opening braces were Unicode.+closeTwoBraces :: Interval -> Interval -> Parser Range+closeTwoBraces i1 i2 =+ let ivl = getIntervalFile i1 <$ fuseIntervals (void i1) (void i2) in+ if posPos (iEnd i2) - posPos (iStart i1) > 2+ then parseErrorRange i2 "Expecting '}}', found separated '}'s."+ -- We just call closeBracket with a fake token so as to not+ -- duplicate the hairy code below.+ else closeBracket (TokSymbol (SymDoubleCloseBrace False) ivl)
src/full/Agda/Syntax/Parser/LexActions.hs view
@@ -17,7 +17,7 @@ , begin_, end_ , lexError -- ** Specialized actions- , keyword, symbol, identifier, literal, literal', integer+ , keyword, symbol, qualifiedToken, literal, literal', integer -- * Lex predicates , followedBy, eof, inState ) where@@ -102,10 +102,10 @@ postToken (TokId (r, "\x03bb")) = TokSymbol SymLambda r postToken (TokId (r, "\x2026")) = TokSymbol SymEllipsis r postToken (TokId (r, "\x2192")) = TokSymbol SymArrow r-postToken (TokId (r, "\x2983")) = TokSymbol SymDoubleOpenBrace r-postToken (TokId (r, "\x2984")) = TokSymbol SymDoubleCloseBrace r-postToken (TokId (r, "\x2987")) = TokSymbol SymOpenIdiomBracket r-postToken (TokId (r, "\x2988")) = TokSymbol SymCloseIdiomBracket r+postToken (TokId (r, "\x2983")) = TokSymbol (SymDoubleOpenBrace True) r+postToken (TokId (r, "\x2984")) = TokSymbol (SymDoubleCloseBrace True) r+postToken (TokId (r, "\x2987")) = TokSymbol (SymOpenIdiomBracket True) r+postToken (TokId (r, "\x2988")) = TokSymbol (SymCloseIdiomBracket True) r postToken (TokId (r, "\x2987\x2988")) = TokSymbol SymEmptyIdiomBracket r postToken (TokId (r, "\x2200")) = TokKeyword KwForall r postToken t = t@@ -137,13 +137,16 @@ withInterval_ :: (Interval -> r) -> LexAction r withInterval_ f = withInterval (f . fst) +-- | Enter the layout state for the given keyword.+enterLayout :: Keyword -> Parser ()+enterLayout kw = do+ pushLexState layout+ modify \st -> st { parseLayKw = kw } -- | Executed for layout keywords. Enters the 'Agda.Syntax.Parser.Lexer.layout' -- state and performs the given action. withLayout :: Keyword -> LexAction r -> LexAction r-withLayout kw a = pushLexState layout `andThen` setLayoutKw `andThen` a- where- setLayoutKw = modify $ \ st -> st { parseLayKw = kw }+withLayout kw a = enterLayout kw `andThen` a infixr 1 `andThen` @@ -255,21 +258,40 @@ literal :: Read a => (a -> Literal) -> LexAction Token literal = literal' read --- | Parse an identifier. Identifiers can be qualified (see 'Name').--- Example: @Foo.Bar.f@-identifier :: LexAction Token-identifier = qualified $ either (TokId . second toList) (TokQId . map (second toList))+-- | Parse a potentially-qualified token. This action is responsible for+-- lexing both identifiers (which do not always have a qualifier, in+-- which case a 'TokId' is returned) *and* "qualified keywords", like+-- qualified @do@.+--+-- This action may thus modify the layout state of the parser, since+-- qualified @do@ is a layout "keyword".+--+-- Examples: @Foo.Bar.f@, @Foo.do@.+qualifiedToken :: LexAction Token+qualifiedToken = qualified $ either (pure . TokId . second toList) (qid . map (second toList)) where+ qid :: [(Interval, String)] -> Parser Token+ qid parts = case initLast parts of+ -- For qualified 'do', we have to pretend to be a layout keyword+ Just (initp, (i, "do")) ->+ TokQual QualDo initp i <$ enterLayout KwDo + Just (initp, (i, "(|)")) -> pure $ TokQual QualEmptyIdiom initp i+ Just (initp, (i, "\x2987\x2988")) -> pure $ TokQual QualEmptyIdiom initp i + Just (initp, (i, "(|")) -> pure $ TokQual (QualOpenIdiom False) initp i+ Just (initp, (i, "\x2987")) -> pure $ TokQual (QualOpenIdiom True) initp i++ _ -> pure $ TokQId parts+ -- | Parse a possibly qualified name.-qualified :: (Either (Interval, String1) [(Interval, String1)] -> a) -> LexAction a+qualified :: (Either (Interval, String1) [(Interval, String1)] -> Parser a) -> LexAction a qualified tok = token $ \s -> do i <- getParseInterval case mkName i $ List1.wordsBy (== '.') s of [] -> lexError "lex error on .."- [x] -> return $ tok $ Left x- xs -> return $ tok $ Right xs+ [x] -> tok $ Left x+ xs -> tok $ Right xs where -- Compute the ranges for the substrings (separated by '.') of -- a name. Dots are included: the intervals generated for
src/full/Agda/Syntax/Parser/LexActions.hs-boot view
@@ -25,12 +25,12 @@ begin_ :: LexState -> LexAction Token end_ :: LexAction Token -keyword :: Keyword -> LexAction Token-symbol :: Symbol -> LexAction Token-identifier :: LexAction Token-literal :: Read a => (a -> Literal) -> LexAction Token-literal' :: (String -> a) -> (a -> Literal) -> LexAction Token-integer :: String -> Integer+keyword :: Keyword -> LexAction Token+symbol :: Symbol -> LexAction Token+qualifiedToken :: LexAction Token+literal :: Read a => (a -> Literal) -> LexAction Token+literal' :: (String -> a) -> (a -> Literal) -> LexAction Token+integer :: String -> Integer followedBy :: Char -> LexPredicate eof :: LexPredicate
src/full/Agda/Syntax/Parser/Lexer.x view
@@ -1,14 +1,8 @@ {-#if __GLASGOW_HASKELL__ > 800 {-# OPTIONS_GHC -Wno-error=deprecated-flags #-} {-# OPTIONS_GHC -Wno-error=missing-signatures #-} {-# OPTIONS_GHC -Wno-error=tabs #-} {-# OPTIONS_GHC -Wno-error=unused-imports #-}-#endif-{-# OPTIONS_GHC -fno-warn-deprecated-flags #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}-{-# OPTIONS_GHC -fno-warn-tabs #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-} {-| The lexer is generated by Alex (<http://www.haskell.org/alex>) and is an adaptation of GHC's lexer. The main lexing function 'lexer' is called by@@ -86,6 +80,7 @@ <pragma_> "FOREIGN" { endWith $ beginWith fpragma $ keyword KwFOREIGN } <pragma_> "DISPLAY" { keyword KwDISPLAY } <pragma_> "ETA" { keyword KwETA }+<pragma_> "ETA_EQUALITY" { keyword KwETA_EQUALITY } <pragma_> "IMPOSSIBLE" { keyword KwIMPOSSIBLE } <pragma_> "INJECTIVE" { keyword KwINJECTIVE } <pragma_> "INJECTIVE_FOR_INFERENCE" { keyword KwINJECTIVE_FOR_INFERENCE }@@ -114,6 +109,13 @@ <fpragma_> . # [ $white ] + { withInterval $ TokString } -- Comments+<0,code,bol_,layout_,empty_layout_,imp_dir_>+ "--" .* / { keepComments .&&. (followedBy '\n' .||. eof) }+ { confirmLayout `andThen` withInterval TokComment }+<0,code,bol_,layout_,empty_layout_,imp_dir_>+ "--" .* / { followedBy '\n' .||. eof }+ { confirmLayout `andThen` skip }+ -- We need to rule out pragmas here. Usually longest match would take -- precedence, but in some states pragmas aren't valid but comments are. <0,code,bol_,layout_,empty_layout_,imp_dir_>@@ -122,14 +124,6 @@ "-}" { symbol SymEndComment } @ident "-}" { symbol SymEndComment } --- Dashes followed by a name symbol should be parsed as a name.-<0,code,bol_,layout_,empty_layout_,imp_dir_>- "--" .* / { keepComments .&&. (followedBy '\n' .||. eof) }- { confirmLayout `andThen` withInterval TokComment }-<0,code,bol_,layout_,empty_layout_,imp_dir_>- "--" .* / { followedBy '\n' .||. eof }- { confirmLayout `andThen` skip }- -- Note: we need to confirm tentative layout columns whenever we meet -- a newline character ('\n'). -- The exception is the newline after a layout keyword.@@ -156,26 +150,28 @@ <empty_layout_> () { emptyLayout } -- Keywords+-- Wrapping all our keywords which are also Haskell keywords in quotes+-- allows this file to basically syntax highlight as Haskell correctly <0,code> abstract { keyword KwAbstract } <0,code> codata { keyword KwCoData } <0,code> coinductive { keyword KwCoInductive } <0,code> constructor { keyword KwConstructor } <0,code> data { keyword KwData }-<0,code> do { keyword KwDo }+<0,code> "do" { keyword KwDo } <0,code> "eta-equality" { keyword KwEta } <0,code> field { keyword KwField } <0,code> forall { keyword KwForall } <0,code> import { keyword KwImport }-<0,code> in { keyword KwIn }+<0,code> "in" { keyword KwIn } <0,code> inductive { keyword KwInductive } <0,code> infix { keyword KwInfix } <0,code> infixl { keyword KwInfixL } <0,code> infixr { keyword KwInfixR } <0,code> instance { keyword KwInstance } <0,code> interleaved { keyword KwInterleaved }-<0,code> let { keyword KwLet }+<0,code> "let" { keyword KwLet } <0,code> macro { keyword KwMacro }-<0,code> module { keyword KwModule }+<0,code> "module" { keyword KwModule } <0,code> mutual { keyword KwMutual } <0,code> "no-eta-equality" { keyword KwNoEta } <0,code> open { keyword KwOpen }@@ -194,7 +190,7 @@ <0,code> unquoteDecl { keyword KwUnquoteDecl } <0,code> unquoteDef { keyword KwUnquoteDef } <0,code> variable { keyword KwVariable }-<0,code> where { keyword KwWhere }+<0,code> "where" { keyword KwWhere } <0,code> with { keyword KwWith } <0,code> opaque { keyword KwOpaque } <0,code> unfolding { keyword KwUnfolding }@@ -221,15 +217,15 @@ <0,code> "_" { symbol SymUnderscore } <0,code> "?" { symbol SymQuestionMark } <0,code> "|" { symbol SymBar }-<0,code> "(|" /[$white] { symbol SymOpenIdiomBracket }-<0,code> "|)" { symbol SymCloseIdiomBracket }+<0,code> "(|" /[$white] { symbol (SymOpenIdiomBracket False) }+<0,code> "|)" { symbol (SymCloseIdiomBracket False) } <0,code> "(|)" { symbol SymEmptyIdiomBracket } <0,code> "(" { symbol SymOpenParen } <0,code> ")" { symbol SymCloseParen } <0,code> "->" { symbol SymArrow } <0,code> "\" { symbol SymLambda } -- " <0,code> "@" { symbol SymAs }-<0,code> "{{" /[^[!\-]] { symbol SymDoubleOpenBrace }+<0,code> "{{" /[^[!\-]] { symbol (SymDoubleOpenBrace False) } -- Andreas, 2019-08-08, issue #3962, don't lex '{{' if followed by '-' -- since this will be confused with '{-' (start of comment) by Emacs. @@ -247,11 +243,18 @@ -- Literals <0,code> \' { litChar } <0,code,pragma_> \" { litString }+-- " -- ← this silly incantation lets the rest of this file correctly+-- syntax highlight as Haskell (otherwise it's all a string literal)+ <0,code> @integer { literal' integer LitNat } <0,code> @float { literal LitFloat } --- Identifiers-<0,code,imp_dir_> @q_ident { identifier }+-- Qualified tokens, like identifiers, qualified @do@, and qualified+-- idiom brackets, are all handled by the same 'qualifiedToken' action.+<0,code> @namespace "(|" /[$white] { qualifiedToken }+<0,code> @namespace "(|)" { qualifiedToken }++<0,code,imp_dir_> @q_ident { qualifiedToken } -- Andreas, 2013-02-21, added identifiers to the 'imp_dir_' state. -- This is to fix issue 782: 'toz' should not be lexed as 'to' -- (followed by 'z' after leaving imp_dir_).
src/full/Agda/Syntax/Parser/Literate.hs view
@@ -4,7 +4,7 @@ module Agda.Syntax.Parser.Literate ( literateProcessors- , literateExtsShortList+ , literateExts , literateTeX , literateRsT , literateMd@@ -32,9 +32,7 @@ import Agda.Syntax.Position import Agda.Utils.List-import Agda.Utils.List1 (List1) import qualified Agda.Utils.List1 as List1-import Agda.Utils.Singleton import Agda.Utils.Impossible @@ -91,21 +89,30 @@ -- -- If you add new extensions, remember to update test/Utils.hs so -- that test cases ending in the new extensions are found.+--+-- The 'Bool' parameter controls whether only @```agda@ blocks+-- are treated as Agda code in Markdown/Typst files.+-- When @True@, only blocks marked @```agda@ are considered code.+-- When @False@, both @```@ and @```agda@ blocks are code (default). -literateProcessors :: [(String, (Processor, FileType))]-literateProcessors =+literateProcessors :: Bool -> [(String, (Processor, FileType))]+literateProcessors onlyAgdaBlocks = ((,) <$> (".lagda" ++) . fst <*> snd) <$> [ ("" , (literateTeX, TexFileType)) , (".rst", (literateRsT, RstFileType)) , (".tex", (literateTeX, TexFileType))- , (".md", (literateMd, MdFileType ))+ , (".md", (literateMd onlyAgdaBlocks, MdFileType )) , (".org", (literateOrg, OrgFileType)) , (".tree", (literateTree, TreeFileType)) -- For now, treat typst as markdown because they use the same -- syntax for code blocks.- , (".typ", (literateMd, TypstFileType))+ , (".typ", (literateMd onlyAgdaBlocks, TypstFileType)) ] +-- | List of valid literate file extensions.+literateExts :: [String]+literateExts = fst <$> literateProcessors False+ -- | Returns @True@ if the role corresponds to Agda code. isCode :: LayerRole -> Bool@@ -139,12 +146,6 @@ isBlank :: Char -> Bool isBlank = (&&) <$> isSpace <*> (/= '\n') --- | Short list of extensions for literate Agda files.--- For display purposes.--literateExtsShortList :: List1 String-literateExtsShortList = singleton ".lagda"- -- | Returns a tuple consisting of the first line of the input, and the rest -- of the input. @@ -196,15 +197,23 @@ r_end = rex "([[:blank:]]*)(\\\\end\\{code\\})(.*)" -- | Preprocessor for Markdown.+--+-- The 'Bool' parameter controls whether only @```agda@ blocks+-- are treated as Agda code.+-- When @True@, only blocks explicitly marked @```agda@ are considered code.+-- When @False@, both unmarked @```@ and @```agda@ blocks are code (default). -literateMd :: Processor-literateMd pos s = mkLayers pos $ md s+literateMd :: Bool -> Processor+literateMd onlyAgdaBlocks pos s = mkLayers pos $ md s where md :: String -> [(LayerRole, String)] md = caseLine [] $ \ line rest -> case md_begin `matchM` line of- Just (getAllTextSubmatches -> [_, pre, markup, _]) ->- (Comment, pre) : (Markup, markup) : code rest+ Just (getAllTextSubmatches -> [_, pre, markup, tag]) ->+ -- When onlyAgdaBlocks is True, only treat blocks with "agda" tag as code+ if onlyAgdaBlocks && null tag+ then (Comment, pre) : (Comment, markup) : code_other rest+ else (Comment, pre) : (Markup, markup) : code rest Just _ -> __IMPOSSIBLE__ Nothing -> (Comment, line) :
src/full/Agda/Syntax/Parser/Monad.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnboxedSums #-} module Agda.Syntax.Parser.Monad ( -- * The parser monad@@ -6,6 +9,7 @@ , ParseState(..) , ParseError(..), ParseWarning(..) , LexState+ , OpenBracket(..) , LayoutBlock(..), LayoutContext, LayoutStatus(..) , Column , ParseFlags (..)@@ -24,6 +28,8 @@ , topBlock, popBlock, pushBlock , getContext, setContext, modifyContext , resetLayoutStatus+ -- ** Brackets+ , openBracket, closeBracket -- ** Errors , parseWarning, parseWarningName , parseError, parseErrorAt, parseError', parseErrorRange@@ -31,26 +37,36 @@ ) where +import Prelude hiding ( null )+ import Control.DeepSeq import Control.Exception ( displayException )-import Control.Monad.Except-import Control.Monad.State+import Control.Monad.Except (MonadError(..))+import Control.Monad.State (MonadState(..), modify', modify, gets)+import Control.Monad -import Data.Maybe ( listToMaybe )-import Data.Word ( Word32)+import Data.Maybe ( listToMaybe, fromMaybe )+import Data.Word ( Word32 )+import Data.List ( uncons ) +import GHC.Exts (oneShot)+ import Agda.Interaction.Options.Warnings +import Agda.Syntax.Common.Pretty import Agda.Syntax.Concrete.Attribute import Agda.Syntax.Position-import Agda.Syntax.Parser.Tokens ( Keyword( KwMutual ) )+import Agda.Syntax.Parser.Tokens ( Keyword( KwMutual ), Token(..), Symbol(..), QualifiableToken (QualOpenIdiom) ) import Agda.TypeChecking.Positivity.Occurrence ( pattern Mixed ) +import Agda.Utils.Function ( applyUnless )+import Agda.Utils.Functor ( (<&>) ) import Agda.Utils.IO ( showIOException ) import Agda.Utils.List ( tailWithDefault )-import qualified Agda.Utils.Maybe.Strict as Strict-import Agda.Syntax.Common.Pretty+import Agda.Utils.Maybe.Strict qualified as Strict+import Agda.Utils.Null+import Agda.Utils.Word (packW64, splitW64) import Agda.Utils.Impossible @@ -58,29 +74,72 @@ The parse monad --------------------------------------------------------------------------} --- | The parse monad.-newtype Parser a = P { _runP :: StateT ParseState (Either ParseError) a }- deriving (Functor, Applicative, Monad, MonadState ParseState, MonadError ParseError)+type ParseRes a = (# ParseError | (# a , ParseState #) #)+pattern PErr :: ParseError -> ParseRes a+pattern PErr e <- (# e | #) where PErr !e = (# e | #)+pattern POk :: a -> ParseState -> ParseRes a+pattern POk a s <- (# | (# a, s #) #) where POk !a !s = (# | (# a, s #) #)+{-# INLINE PErr #-}+{-# INLINE POk #-}+{-# COMPLETE PErr, POk #-} +newtype Parser a = Parser {_runP :: ParseState -> ParseRes a}++instance Functor Parser where+ {-# INLINE fmap #-}+ fmap f (Parser g) = Parser (oneShot \s -> case g s of+ POk a s -> POk (f a) s+ PErr e -> PErr e)++instance Applicative Parser where+ {-# INLINE pure #-}+ pure a = Parser (\s -> POk a s)+ {-# INLINE (<*>) #-}+ (<*>) (Parser pf) (Parser pa) = Parser (oneShot \s -> case pf s of+ POk f s -> case pa s of+ POk a s -> POk (f a) s+ PErr e -> PErr e+ PErr e -> PErr e)++instance Monad Parser where+ return = pure+ {-# INLINE (>>=) #-}+ Parser pa >>= f = Parser (oneShot \s -> case pa s of+ POk a s -> _runP (f a) s+ PErr e -> PErr e)++instance MonadState ParseState Parser where+ {-# INLINE get #-}+ get = Parser (oneShot \s -> POk s s)+ {-# INLINE put #-}+ put s = Parser (oneShot \_ -> POk () s)++instance MonadError ParseError Parser where+ {-# INLINE throwError #-}+ throwError e = Parser \_ -> PErr e+ {-# INLINE catchError #-}+ catchError (Parser pa) f = Parser (oneShot \s -> case pa s of+ POk a s -> POk a s+ PErr e -> _runP (f e) s)+ -- | The parser state. Contains everything the parser and the lexer could ever -- need. data ParseState = PState- { parseSrcFile :: !SrcFile- , parsePos :: !PositionWithoutFile -- ^ position at current input location- , parseLastPos :: !PositionWithoutFile -- ^ position of last token- , parseInp :: String -- ^ the current input- , parsePrevChar :: !Char -- ^ the character before the input- , parsePrevToken:: String -- ^ the previous token- , parseLayout :: LayoutContext -- ^ the stack of layout blocks- , parseLayStatus:: LayoutStatus -- ^ the status of the coming layout block- , parseLayKw :: Keyword -- ^ the keyword for the coming layout block- , parseLexState :: [LexState] -- ^ the state of the lexer- -- (states can be nested so we need a stack)- , parseFlags :: ParseFlags -- ^ parametrization of the parser- , parseWarnings :: ![ParseWarning] -- ^ In reverse order.- , parseAttributes- :: !Attributes- -- ^ Every encountered attribute.+ { parseSrcFile :: !SrcFile+ , parsePos :: !PositionWithoutFile -- ^ position at current input location+ , parseLastPos :: !PositionWithoutFile -- ^ position of last token+ , parseInp :: !String -- ^ the current input+ , parsePrevChar :: !Char -- ^ the character before the input+ , parsePrevToken :: !String -- ^ the previous token+ , parseLayout :: !LayoutContext -- ^ the stack of layout blocks+ , parseLayStatus :: !LayoutStatus -- ^ the status of the coming layout block+ , parseLayKw :: !Keyword -- ^ the keyword for the coming layout block+ , parseLexState :: ![LexState] -- ^ the state of the lexer+ -- (states can be nested so we need a stack)+ , parseFlags :: !ParseFlags -- ^ parametrization of the parser+ , parseWarnings :: ![ParseWarning] -- ^ In reverse order.+ , parseBrackets :: ![OpenBracket] -- ^ stack of open unicode/ASCII brackets+ , parseAttributes :: !Attributes -- ^ Every encountered attribute. } deriving Show @@ -124,9 +183,28 @@ -- a smaller column. deriving (Eq, Show) +-- | Information about an opening unicode-able bracket necessary for+-- correctly parsing its closing delimiter.+data OpenBracket+ -- | An opening idiom bracket.+ = OpenIdiomBracket+ { openBracketUnicode :: Bool -- ^ 'True' if the user wrote @⦇@.+ , openBracketInterval :: Interval -- ^ Position of the opening bracket.+ }+ -- | An opening double brace.+ | OpenDoubleBrace+ { openBracketUnicode :: Bool -- ^ 'True' if the user wrote @⦃@.+ , openBracketInterval :: Interval -- ^ Position of the opening bracket.+ }+ deriving (Eq, Show)++instance NFData OpenBracket where+ rnf (OpenIdiomBracket x _) = rnf x+ rnf (OpenDoubleBrace x _) = rnf x+ -- | Parser flags. data ParseFlags = ParseFlags- { parseKeepComments :: Bool+ { parseKeepComments :: !Bool -- ^ Should comment tokens be returned by the lexer? } deriving Show@@ -136,21 +214,19 @@ -- | Errors that arise at a specific position in the file = ParseError- { errSrcFile :: !SrcFile- -- ^ The file in which the error occurred.- , errPos :: !PositionWithoutFile+ { errPos :: !Position -- ^ Where the error occurred.- , errInput :: String+ , errInput :: !String -- ^ The remaining input.- , errPrevToken :: String+ , errPrevToken :: !String -- ^ The previous token.- , errMsg :: String+ , errMsg :: !String -- ^ Hopefully an explanation of what happened. } -- | Parse errors that concern a range in a file. | OverlappingTokensError- { errRange :: !(Range' SrcFile)+ { errRange :: !Range -- ^ The range of the bigger overlapping token } @@ -158,17 +234,24 @@ | InvalidExtensionError { errPath :: !RangeFile -- ^ The file which the error concerns.- , errValidExts :: [String]+ , errValidExts :: ![String] } | ReadFileError { errPath :: !RangeFile- , errIOError :: IOError+ , errIOError :: !IOError } deriving Show +instance KillRange ParseError where+ killRange = \case+ ParseError _ inp tok msg -> ParseError empty inp tok msg+ OverlappingTokensError _ -> OverlappingTokensError empty+ InvalidExtensionError _ exts -> InvalidExtensionError empty exts+ ReadFileError _ err -> ReadFileError empty err+ instance NFData ParseError where rnf = \case- ParseError _f _r inp tok msg -> rnf inp `seq` rnf tok `seq` rnf msg+ ParseError _r inp tok msg -> rnf inp `seq` rnf tok `seq` rnf msg OverlappingTokensError _r -> () InvalidExtensionError _r exts -> rnf exts ReadFileError _r _err -> ()@@ -180,17 +263,20 @@ { warnRange :: !(Range' SrcFile) -- ^ The range of the bigger overlapping token. }- | MisplacedAttributes Range String+ | MisplacedAttributes Range !String -- ^ The 'String' is the error message.- | UnknownPolarity Range String+ | UnknownPolarity Range !String -- ^ Unknown polarity, ignored.- | UnknownAttribute Range String+ | UnknownAttribute Range !String -- ^ Unknown attribute, ignored. -- The 'Range' includes the "@", the 'String' not. | UnsupportedAttribute Range !(Maybe String) -- ^ Unsupported attribute. | MultipleAttributes Range !(Maybe String) -- ^ Multiple attributes.+ | MismatchedBrackets Range !OpenBracket+ -- ^ The closing bracket (at the 'Range') was closed with a+ -- unicode-ness that doesn't match that of the 'OpenBracket'. deriving Show instance NFData ParseWarning where@@ -200,6 +286,7 @@ rnf (UnknownAttribute _ s) = rnf s rnf (UnsupportedAttribute _ s) = rnf s rnf (MultipleAttributes _ s) = rnf s+ rnf (MismatchedBrackets _ s) = rnf s parseWarningName :: ParseWarning -> WarningName parseWarningName = \case@@ -209,6 +296,7 @@ UnknownAttribute{} -> UnknownAttribute_ UnsupportedAttribute{} -> UnsupportedAttribute_ MultipleAttributes{} -> MultipleAttributes_+ MismatchedBrackets{} -> MismatchedBrackets_ -- | The result of parsing something. data ParseResult a@@ -218,17 +306,16 @@ -- | Old interface to parser. unP :: Parser a -> ParseState -> ParseResult a-unP (P m) s = case runStateT m s of- Left err -> ParseFailed err- Right (a, s) -> ParseOk s a+unP (Parser m) s = case m s of+ PErr e -> ParseFailed e+ POk a s -> ParseOk s a -- | Throw a parse error at the current position. parseError :: String -> Parser a parseError msg = do s <- get throwError $ ParseError- { errSrcFile = parseSrcFile s- , errPos = parseLastPos s+ { errPos = parseLastPos s <&> const (parseSrcFile s) , errInput = parseInp s , errPrevToken = parsePrevToken s , errMsg = msg@@ -245,8 +332,8 @@ --------------------------------------------------------------------------} instance Pretty ParseError where- pretty ParseError{errPos,errSrcFile,errMsg,errPrevToken,errInput} = vcat- [ (pretty errPos{ srcFile = errSrcFile } <> colon) <+> "error: [ParseError]"+ pretty ParseError{ errPos, errMsg, errPrevToken, errInput } = vcat+ [ applyUnless (null errPos) ((pretty errPos <> colon) <+>) "error: [ParseError]" , if not $ null errMsg then text errMsg else sep -- Happy errors have no message, so we print the context instead [ text $ errPrevToken ++ "<ERROR>"@@ -254,22 +341,22 @@ ] ] pretty OverlappingTokensError{errRange} = vcat- [ (pretty errRange <> colon) <+> "error: [OverlappingTokensError]"+ [ applyUnless (null errRange) ((pretty errRange <> colon) <+>) "error: [OverlappingTokensError]" , "Multi-line comment spans one or more literate text blocks." ] pretty InvalidExtensionError{errPath,errValidExts} = vcat- [ (pretty errPath <> colon) <+> "error: [InvalidExtensionError]"+ [ applyUnless (null errPath) ((pretty errPath <> colon) <+>) "error: [InvalidExtensionError]" , "Unsupported extension." , "Supported extensions are:" <+> prettyList_ errValidExts ]- pretty ReadFileError{errPath,errIOError} = vcat- [ "Cannot read file" <+> pretty errPath- , "Error:" <+> text (showIOException errIOError)+ pretty ReadFileError{errPath,errIOError} = vcat $ concat+ [ [ "Cannot read file" <+> pretty errPath | not (null errPath) ]+ , [ "Error:" <+> text (showIOException errIOError) ] ] instance HasRange ParseError where getRange err = case err of- ParseError{ errSrcFile, errPos = p } -> posToRange' errSrcFile p p+ ParseError{ errPos = p } -> posToRange p p OverlappingTokensError{ errRange } -> errRange InvalidExtensionError{} -> errPathRange ReadFileError{} -> errPathRange@@ -300,6 +387,15 @@ , "are not supported here." ] + MismatchedBrackets _r brk ->+ let+ (nm, op, cl) = case brk of+ OpenIdiomBracket True _ -> ("Idiom brackets", "\x2987", "\x2988")+ OpenIdiomBracket False _ -> ("Idiom brackets", "(|", "|)")+ OpenDoubleBrace True _ -> ("Double braces", "\x2983", "\x2984")+ OpenDoubleBrace False _ -> ("Double braces", "{{", "}}")+ in nm <> " opened with `" <> op <> "` must be closed with `" <> cl <> "`."+ MultipleAttributes _r ms -> hsep [ "Multiple", pretty ms, "attributes (ignored)." ] @@ -311,6 +407,7 @@ getRange (UnknownAttribute r _) = r getRange (UnsupportedAttribute r _) = r getRange (MultipleAttributes r _) = r+ getRange (MismatchedBrackets r _) = r {-------------------------------------------------------------------------- Running the parser@@ -333,6 +430,7 @@ , parseFlags = flags , parseWarnings = [] , parseAttributes = []+ , parseBrackets = [] } where pos' = pos { srcFile = () }@@ -359,6 +457,11 @@ ParseResult a parsePosString pos flags st p input = unP p (initStatePos pos flags input st) +-- | Calls 'parsePosString' with 'Position' extracted from the Range.+parseRangeString :: Range -> ParseFlags -> [LexState] -> Parser a -> String ->+ ParseResult a+parseRangeString = parsePosString . fromMaybe (startPos Nothing) . rStart+ -- | Parses a string as if it were the contents of the given file -- Useful for integrating preprocessors. parseFromSrc :: ParseFlags -> [LexState] -> Parser a -> SrcFile -> String@@ -371,13 +474,13 @@ --------------------------------------------------------------------------} setParsePos :: PositionWithoutFile -> Parser ()-setParsePos p = modify $ \s -> s { parsePos = p }+setParsePos p = modify' $ \s -> s { parsePos = p } setLastPos :: PositionWithoutFile -> Parser ()-setLastPos p = modify $ \s -> s { parseLastPos = p }+setLastPos p = modify' $ \s -> s { parseLastPos = p } setPrevToken :: String -> Parser ()-setPrevToken t = modify $ \s -> s { parsePrevToken = t }+setPrevToken t = modify' $ \s -> s { parsePrevToken = t } getLastPos :: Parser PositionWithoutFile getLastPos = gets parseLastPos@@ -393,10 +496,10 @@ -- UNUSED Liang-Ting Chen 2019-07-16 --setLexState :: [LexState] -> Parser ()---setLexState ls = modify $ \ s -> s { parseLexState = ls }+--setLexState ls = modify' $ \ s -> s { parseLexState = ls } modifyLexState :: ([LexState] -> [LexState]) -> Parser ()-modifyLexState f = modify $ \ s -> s { parseLexState = f (parseLexState s) }+modifyLexState f = modify' $ \ s -> s { parseLexState = f (parseLexState s) } pushLexState :: LexState -> Parser () pushLexState l = modifyLexState (l:)@@ -446,7 +549,7 @@ setContext = modifyContext . const modifyContext :: (LayoutContext -> LayoutContext) -> Parser ()-modifyContext f = modify $ \ s -> s { parseLayout = f (parseLayout s) }+modifyContext f = modify' $ \ s -> s { parseLayout = f (parseLayout s) } -- | Return the current layout block. topBlock :: Parser (Maybe LayoutBlock)@@ -464,4 +567,46 @@ -- | When we see a layout keyword, by default we expect a 'Tentative' block. resetLayoutStatus :: Parser ()-resetLayoutStatus = modify $ \ s -> s { parseLayStatus = Tentative }+resetLayoutStatus = modify' $ \ s -> s { parseLayStatus = Tentative }++------------------------------------------------------------------------+-- * Brackets++-- | Push the 'OpenBracket' state corresponding to an opening token.+openBracket :: Token -> Parser Range+openBracket tok =+ case tok of+ TokSymbol (SymOpenIdiomBracket u) r -> push r $ OpenIdiomBracket u+ TokSymbol (SymDoubleOpenBrace u) r -> push r $ OpenDoubleBrace u+ TokQual (QualOpenIdiom u) _ r -> push r $ OpenIdiomBracket u++ -- These are the only tokens we call this for.+ _ -> __IMPOSSIBLE__+ where push rng k = getRange rng <$ modify' \s -> s { parseBrackets = k rng:parseBrackets s}++-- | Pop an 'OpenBracket' from the parser state, and generate the+-- 'MismatchedBrackets' warning if the given 'Token' does not match what+-- was expected.+closeBracket :: Token -> Parser Range+closeBracket (TokSymbol sym ivl) = do+ let+ rng = getRange ivl+ match a b xs = rng <$ do+ unless (openBracketUnicode a == b) $ parseWarning $ MismatchedBrackets rng a+ modify' \s -> s { parseBrackets = xs }++ -- Since Happy won't call the action if the rule doesn't match, and we+ -- call this function from the *parser*, this function is guaranteed+ -- to only run if the parser is expecting a closing delimiter of the+ -- right type.+ gets parseBrackets >>= \case+ open@OpenIdiomBracket{}:xs+ | SymCloseIdiomBracket uC <- sym -> match open uC xs+ | otherwise -> __IMPOSSIBLE__+ open@OpenDoubleBrace{}:xs+ | SymDoubleCloseBrace uC <- sym -> match open uC xs+ | otherwise -> __IMPOSSIBLE__+ [] -> __IMPOSSIBLE__++-- Only symbols can be closing delimiters.+closeBracket _ = __IMPOSSIBLE__
src/full/Agda/Syntax/Parser/Parser.y view
@@ -160,6 +160,7 @@ 'CATCHALL' { TokKeyword KwCATCHALL $$ } 'DISPLAY' { TokKeyword KwDISPLAY $$ } 'ETA' { TokKeyword KwETA $$ }+ 'ETA_EQUALITY' { TokKeyword KwETA_EQUALITY $$ } 'FOREIGN' { TokKeyword KwFOREIGN $$ } 'COMPILE' { TokKeyword KwCOMPILE $$ } 'IMPOSSIBLE' { TokKeyword KwIMPOSSIBLE $$ }@@ -203,11 +204,24 @@ '|' { TokSymbol SymBar $$ } '(' { TokSymbol SymOpenParen $$ } ')' { TokSymbol SymCloseParen $$ }- '(|' { TokSymbol SymOpenIdiomBracket $$ }- '|)' { TokSymbol SymCloseIdiomBracket $$ }- '(|)' { TokSymbol SymEmptyIdiomBracket $$ }- '{{' { TokSymbol SymDoubleOpenBrace $$ }- '}}' { TokSymbol SymDoubleCloseBrace $$ }++ -- Handling of Unicode brackets: the actual terminals produced by+ -- the lexer get the "i_" prefix, for internal.+ --+ -- These should not be used anywhere other than the Token+ -- production!!! Other non-terminals that need these delimiters+ -- should use the unprefixed versions, e.g. "{{". Those will+ -- automatically handle generating the MismatchedBrackets warnings+ -- when appropriate.+ --+ -- Note that the "}}" nonterminal also handles the special case for+ -- closing a "{{" with a pair of consecutive '}' '}'.+ "i_(|" { $$@(TokSymbol SymOpenIdiomBracket{} _) }+ "i_|)" { $$@(TokSymbol SymCloseIdiomBracket{} _) }+ "i_{{" { $$@(TokSymbol SymDoubleOpenBrace{} _) }+ "i_}}" { $$@(TokSymbol SymDoubleCloseBrace{} _) }++ "(|)" { TokSymbol SymEmptyIdiomBracket $$ } '{' { TokSymbol SymOpenBrace $$ } '}' { TokSymbol SymCloseBrace $$ } -- ':{' { TokSymbol SymColonBrace $$ }@@ -219,7 +233,11 @@ id { TokId $$ } q_id { TokQId $$ }+ q_do { TokQual_ $$@(QualifiedToken QualDo _ _) } + q_idiom { TokQual_ $$@(QualifiedToken QualOpenIdiom{} _ _) }+ q_idiomE { TokQual_ $$@(QualifiedToken QualEmptyIdiom _ _) }+ string { TokString $$ } literal { TokLiteral $$ } @@ -297,6 +315,7 @@ | 'COMPILE' { TokKeyword KwCOMPILE $1 } | 'DISPLAY' { TokKeyword KwDISPLAY $1 } | 'ETA' { TokKeyword KwETA $1 }+ | 'ETA_EQUALITY' { TokKeyword KwETA_EQUALITY $1 } | 'FOREIGN' { TokKeyword KwFOREIGN $1 } | 'IMPOSSIBLE' { TokKeyword KwIMPOSSIBLE $1 } | 'INCOHERENT' { TokKeyword KwINCOHERENT $1 }@@ -339,11 +358,11 @@ | '|' { TokSymbol SymBar $1 } | '(' { TokSymbol SymOpenParen $1 } | ')' { TokSymbol SymCloseParen $1 }- | '(|' { TokSymbol SymOpenIdiomBracket $1 }- | '|)' { TokSymbol SymCloseIdiomBracket $1 }- | '(|)' { TokSymbol SymEmptyIdiomBracket $1 }- | '{{' { TokSymbol SymDoubleOpenBrace $1 }- | '}}' { TokSymbol SymDoubleCloseBrace $1 }+ | "i_(|" { $1 }+ | "i_|)" { $1 }+ | "i_{{" { $1 }+ | "i_}}" { $1 }+ | "(|)" { TokSymbol SymEmptyIdiomBracket $1 } | '{' { TokSymbol SymOpenBrace $1 } | '}' { TokSymbol SymCloseBrace $1 } | vopen { TokSymbol SymOpenVirtualBrace $1 }@@ -354,6 +373,9 @@ | id { TokId $1 } | q_id { TokQId $1 }+ | q_do { TokQual_ $1 }+ | q_idiom { TokQual_ $1 }+ | q_idiomE { TokQual_ $1 } | string { TokString $1 } | literal { TokLiteral $1 }@@ -363,7 +385,7 @@ --------------------------------------------------------------------------} File :: { Module }-File : vopen TopLevel maybe_vclose { takeOptionsPragmas $2 }+File : vopen TopDeclarations maybe_vclose { figureOutTopLevelModule $2 } maybe_vclose :: { () } maybe_vclose : {- empty -} { () }@@ -411,6 +433,30 @@ } } +-- See "Handling of Unicode brackets" above.+"(|" :: { Range } : "i_(|" {% openBracket $1 }+"|)" :: { Range } : "i_|)" {% closeBracket $1 }+"{{" :: { Range } : "i_{{" {% openBracket $1 }+"}}" :: { Range }+ : "i_}}" {% closeBracket $1 }++ -- To support closing nested records without whitespace between the+ -- closing braces, as in+ --+ -- record {a = record{}}+ --+ -- the lexer will always turn "}" into '}' tokens, regardless of how+ -- many there are in a row. When looking for a closing brace, we+ -- handle the Unicode version (lexed as a single token, above), or+ -- *two* of the ASCII closing tokens.+ -- The closeTwoBraces helper makes sure that the closing tokens are+ -- next to eachother in the source file.+ | '}' '}' {% closeTwoBraces $1 $2 }++-- Parse a 'QualifiedToken'-valued terminal into the qualifying module+-- name and the range of the actual keyword/symbol.+Q_(p) :: { (QName, Range) } : p {% unqualifyToken $1 }+ {-------------------------------------------------------------------------- Names --------------------------------------------------------------------------}@@ -426,22 +472,6 @@ : Id SpaceIds { $1 <| $2 } | Id { singleton $1 } --- When looking for a double closed brace, we accept either a single token '}}'--- (which is what the unicode character "RIGHT WHITE CURLY BRACKET" is--- postprocessed into in LexActions.hs), but also two consecutive tokens '}'--- (which a string '}}' is lexed to). This small hack allows us to keep--- "record { a = record { }}" working. In the second case, we check that the two--- tokens '}' are immediately consecutive.-DoubleCloseBrace :: { Range }-DoubleCloseBrace- : '}}' { getRange $1 }- | '}' '}' {%- if posPos (fromJust (rEnd' (getRange $2))) -- posPos (fromJust (rStart' (getRange $1))) > 2- then parseErrorRange $2 "Expecting '}}', found separated '}'s."- else return $ getRange ($1, $2)- }- -- A possibly dotted identifier. MaybeDottedId :: { Arg Name } MaybeDottedId@@ -459,31 +489,34 @@ -- be surrounded by braces or dotted. ArgIds :: { List1 (Arg Name) } ArgIds- : MaybeDottedId ArgIds { $1 <| $2 }- | MaybeDottedId { singleton $1 }- | '{{' MaybeDottedIds DoubleCloseBrace ArgIds { fmap makeInstance $2 <> $4 }- | '{{' MaybeDottedIds DoubleCloseBrace { fmap makeInstance $2 }- | '{' MaybeDottedIds '}' ArgIds { fmap hide $2 <> $4 }- | '{' MaybeDottedIds '}' { fmap hide $2 }- | '.' '{' SpaceIds '}' ArgIds { fmap (hide . defaultIrrelevantArg $1) $3 <> $5 }- | '.' '{' SpaceIds '}' { fmap (hide . defaultIrrelevantArg $1) $3 }- | '.' '{{' SpaceIds DoubleCloseBrace ArgIds { fmap (makeInstance . defaultIrrelevantArg $1) $3 <> $5 }- | '.' '{{' SpaceIds DoubleCloseBrace { fmap (makeInstance . defaultIrrelevantArg $1) $3 }- | '..' '{' SpaceIds '}' ArgIds { fmap (hide . defaultShapeIrrelevantArg $1) $3 <> $5 }- | '..' '{' SpaceIds '}' { fmap (hide . defaultShapeIrrelevantArg $1) $3 }- | '..' '{{' SpaceIds DoubleCloseBrace ArgIds { fmap (makeInstance . defaultShapeIrrelevantArg $1) $3 <> $5 }- | '..' '{{' SpaceIds DoubleCloseBrace { fmap (makeInstance . defaultShapeIrrelevantArg $1) $3 }+ : MaybeDottedId ArgIds { $1 <| $2 }+ | MaybeDottedId { singleton $1 }+ | "{{" MaybeDottedIds "}}" ArgIds { fmap makeInstance $2 <> $4 }+ | "{{" MaybeDottedIds "}}" { fmap makeInstance $2 }+ | '{' MaybeDottedIds '}' ArgIds { fmap hide $2 <> $4 }+ | '{' MaybeDottedIds '}' { fmap hide $2 }+ | '.' '{' SpaceIds '}' ArgIds { fmap (hide . defaultIrrelevantArg $1) $3 <> $5 }+ | '.' '{' SpaceIds '}' { fmap (hide . defaultIrrelevantArg $1) $3 }+ | '.' "{{" SpaceIds "}}" ArgIds { fmap (makeInstance . defaultIrrelevantArg $1) $3 <> $5 }+ | '.' "{{" SpaceIds "}}" { fmap (makeInstance . defaultIrrelevantArg $1) $3 }+ | '..' '{' SpaceIds '}' ArgIds { fmap (hide . defaultShapeIrrelevantArg $1) $3 <> $5 }+ | '..' '{' SpaceIds '}' { fmap (hide . defaultShapeIrrelevantArg $1) $3 }+ | '..' "{{" SpaceIds "}}" ArgIds { fmap (makeInstance . defaultShapeIrrelevantArg $1) $3 <> $5 }+ | '..' "{{" SpaceIds "}}" { fmap (makeInstance . defaultShapeIrrelevantArg $1) $3 } --- Modalities preceeding identifiers+-- Modalities preceding identifiers -ModalArgIds :: { ([Attr], List1 (Arg Name)) }-ModalArgIds : Attributes ArgIds {% ($1,) `fmap` mapM (applyAttrs $1) $2 }+ModalArgIds :: { (TacticAttribute, List1 (Arg Name)) }+ModalArgIds : Attributes ArgIds {% (getTacticAttr $1,) `fmap` mapM (applyAttrs $1) $2 } -- Attributes are parsed as '@' followed by an atomic expression. -- Unknown attributes cast a warning and are ignored. Attribute :: { Maybe Attr }-Attribute : '@' ExprOrAttr {% toAttribute (getRange ($1,$2)) $2 }+Attribute+ : '@' 'rewrite' {% rewAttribute (getRange ($1,$2)) }+ -- ^ 'rewrite' is a keyword so does not get parsed as an identifier in ExprOrAttr+ | '@' ExprOrAttr {% toAttribute (getRange ($1,$2)) $2 } -- Parse a reverse list of modalities @@ -627,7 +660,7 @@ | Application3 '->' Expr { Fun (getRange ($1,$2,$3)) (defaultArg $ rawApp $1) $3 }- | Attributes1 Application3 '->' Expr {% applyAttrs $1 (defaultArg $ rawApp $2) <&> \ dom ->+ | Attributes1 Application3 '->' Expr {% applyAttrsDropTactic $1 (defaultArg $ rawApp $2) <&> \ dom -> Fun (getRange ($1,$2,$3,$4)) dom $4 } | Expr1 %prec LOWEST { $1 } @@ -665,10 +698,12 @@ | ExtendedOrAbsurdLam { $1 } | 'forall' ForallBindings Expr { forallPi $2 $3 } | 'let' Declarations LetBody { Let (getRange ($1,$2,$3)) $2 $3 }- | 'do' vopen DoStmts close { DoBlock (getRange ($1, $3)) $3 } | Expr3 { $1 } | 'tactic' Application3 { Tactic (getRange ($1, $2)) (rawApp $2) } + | 'do' vopen DoStmts close { DoBlock (kwRange $1) Nothing $3 }+ | Q_(q_do) vopen DoStmts close { DoBlock (kwRange (snd $1)) (Just (fst $1)) $3 }+ LetBody :: { Maybe Expr } LetBody : 'in' Expr { Just $2 } | {- empty -} { Nothing }@@ -699,10 +734,10 @@ -- Level 3: Atoms Expr3Curly :: { Expr } Expr3Curly- : '{' Expr4 '}' {% HiddenArg (getRange ($1,$2,$3)) `fmap` maybeNamed $2 }- | '{' '}' { let r = fuseRange $1 $2 in HiddenArg r $ unnamed $ Absurd r }- | '{{' Expr4 DoubleCloseBrace {% InstanceArg (getRange ($1,$2,$3)) `fmap` maybeNamed $2 }- | '{{' DoubleCloseBrace { let r = fuseRange $1 $2 in InstanceArg r $ unnamed $ Absurd r }+ : '{' Expr4 '}' {% HiddenArg (getRange ($1,$2,$3)) `fmap` maybeNamed $2 }+ | '{' '}' { let r = fuseRange $1 $2 in HiddenArg r $ unnamed $ Absurd r }+ | "{{" Expr4 "}}" {% InstanceArg (getRange ($1,$2,$3)) `fmap` maybeNamed $2 }+ | "{{" "}}" { let r = fuseRange $1 $2 in InstanceArg r $ unnamed $ Absurd r } Expr3NoCurly :: { Expr } Expr3NoCurly@@ -711,17 +746,31 @@ | 'quote' { Quote (getRange $1) } | 'quoteTerm' { QuoteTerm (getRange $1) } | 'unquote' { Unquote (getRange $1) }- | '(|' UnnamedWithExprs '|)' { IdiomBrackets (getRange ($1,$2,$3)) (List1.toList $2) }- | '(|)' { IdiomBrackets (getRange $1) [] }++ | IdiomBrackets { $1 }+ | '(' ')' { Absurd (fuseRange $1 $2) } | Id '@' Expr3 { As (getRange ($1,$2,$3)) $1 $3 } | '.' Expr3 { Dot (kwRange $1) $2 } | '..' Expr3 { DoubleDot (kwRange $1) $2 }- | 'record' '{' RecordAssignments '}' { Rec (kwRange $1) (getRange ($1,$2,$3,$4)) $3 }- | 'record' Expr3NoCurly '{' FieldAssignments '}' { RecUpdate (kwRange $1) (getRange ($1,$2,$3,$4,$5)) $2 $4 }++ | 'record' '{' RecordAssignments '}'+ { Rec (kwRange $1) (getRange ($1,$2,$3,$4)) $3 }+ | 'record' Expr3NoCurly '{' FieldAssignments '}'+ { RecUpdate (kwRange $1) (getRange ($1,$2,$3,$4,$5)) $2 $4 }+ | '...' { Ellipsis (getRange $1) } | ExprOrAttr { $1 } +IdiomBrackets :: { Expr }+ : "(|" UnnamedWithExprs "|)" { IdiomBrackets (getRange ($1,$2,$3)) Nothing (List1.toList $2) }+ | "(|)" { IdiomBrackets (getRange $1) Nothing [] }++ | Q_(q_idiom) UnnamedWithExprs "|)"+ { IdiomBrackets (getRange (snd $1,$2,$3)) (Just (fst $1)) (List1.toList $2) }+ | Q_(q_idiomE)+ { IdiomBrackets (getRange $1) (Just (fst $1)) [] }+ -- Level 4: Maybe named, or cubical faces Expr4 :: { Expr } Expr4 : Expr1 '=' Expr { Equal (getRange ($1, $2, $3)) $1 $3 }@@ -794,54 +843,37 @@ -- Andreas, 2011-04-27: or ..(x1 .. xn : A) or ..{y1 .. ym : B} TypedBinding :: { TypedBinding } TypedBinding- : '(' Open ')' { TLet (getRange ($1,$3)) $2 }+ : '(' Open ')' { TLet (getRange ($1,$3)) (singleton $2) } | '(' 'let' Declarations ')' { TLet (getRange ($1,$4)) $3 }+ -- relevant- | '(' TBindWithHiding ')' { setRange (getRange ($1,$2,$3)) $- $2 }- | '{' TBind '}' { setRange (getRange ($1,$2,$3)) $- hide $2 }- | '{{' TBind DoubleCloseBrace { setRange (getRange ($1,$2,$3)) $- makeInstance $2 }+ | '(' TBindWithHiding ')' { setRange (getRange ($1,$2,$3)) $ $2 }+ | '{' TBind '}' { setRange (getRange ($1,$2,$3)) $ hide $2 }+ | "{{" TBind "}}" { setRange (getRange ($1,$2,$3)) $ makeInstance $2 }+ -- irrelevant- | '.' '(' TBindWithHiding ')' { setRange (getRange ($2,$3,$4)) $- makeIrrelevant $1 $3 }- | '.' '{' TBind '}' { setRange (getRange ($2,$3,$4)) $- hide $- makeIrrelevant $1 $3 }- | '.' '{{' TBind DoubleCloseBrace { setRange (getRange ($2,$3,$4)) $- makeInstance $- makeIrrelevant $1 $3 }+ | '.' '(' TBindWithHiding ')' { setRange (getRange ($2,$3,$4)) $ makeIrrelevant $1 $3 }+ | '.' '{' TBind '}' { setRange (getRange ($2,$3,$4)) $ hide $ makeIrrelevant $1 $3 }+ | '.' "{{" TBind "}}" { setRange (getRange ($2,$3,$4)) $ makeInstance $ makeIrrelevant $1 $3 }+ -- shape-irrelevant- | '..' '(' TBindWithHiding ')' { setRange (getRange ($2,$3,$4)) $- makeShapeIrrelevant $1 $3 }- | '..' '{' TBind '}' { setRange (getRange ($2,$3,$4)) $- hide $- makeShapeIrrelevant $1 $3 }- | '..' '{{' TBind DoubleCloseBrace { setRange (getRange ($2,$3,$4)) $- makeInstance $- makeShapeIrrelevant $1 $3 }+ | '..' '(' TBindWithHiding ')' { setRange (getRange ($2,$3,$4)) $ makeShapeIrrelevant $1 $3 }+ | '..' '{' TBind '}' { setRange (getRange ($2,$3,$4)) $ hide $ makeShapeIrrelevant $1 $3 }+ | '..' "{{" TBind "}}" { setRange (getRange ($2,$3,$4)) $ makeInstance $ makeShapeIrrelevant $1 $3 }+ -- attributes, relevant- | '(' ModalTBindWithHiding ')' { setRange (getRange ($1,$2,$3)) $- $2 }- | '{{' ModalTBind DoubleCloseBrace { setRange (getRange ($1,$2,$3)) $- makeInstance $2 }- | '{' ModalTBind '}' { setRange (getRange ($1,$2,$3)) $- hide $2 }+ | '(' ModalTBindWithHiding ')' { setRange (getRange ($1,$2,$3)) $ $2 }+ | "{{" ModalTBind "}}" { setRange (getRange ($1,$2,$3)) $ makeInstance $2 }+ | '{' ModalTBind '}' { setRange (getRange ($1,$2,$3)) $ hide $2 }+ -- attributes, irrelevant- | '.' '(' ModalTBindWithHiding ')' {% setRange (getRange ($2,$3,$4)) <\$>- makeIrrelevantM $1 $3 }- | '.' '{' ModalTBind '}' {% setRange (getRange ($2,$3,$4)) . hide <\$>- makeIrrelevantM $1 $3 }- | '.' '{{' ModalTBind DoubleCloseBrace {% setRange (getRange ($2,$3,$4)) . makeInstance <\$>- makeIrrelevantM $1 $3 }+ | '.' '(' ModalTBindWithHiding ')' {% setRange (getRange ($2,$3,$4)) <\$> makeIrrelevantM $1 $3 }+ | '.' '{' ModalTBind '}' {% setRange (getRange ($2,$3,$4)) . hide <\$> makeIrrelevantM $1 $3 }+ | '.' "{{" ModalTBind "}}" {% setRange (getRange ($2,$3,$4)) . makeInstance <\$> makeIrrelevantM $1 $3 } -- attributes, shape-irrelevant- | '..' '(' ModalTBindWithHiding ')' {% setRange (getRange ($2,$3,$4)) <\$>- makeShapeIrrelevantM $1 $3 }- | '..' '{' ModalTBind '}' {% setRange (getRange ($2,$3,$4)) . hide <\$>- makeShapeIrrelevantM $1 $3 }- | '..' '{{' ModalTBind DoubleCloseBrace {% setRange (getRange ($2,$3,$4)) . makeInstance <\$>- makeShapeIrrelevantM $1 $3 }+ | '..' '(' ModalTBindWithHiding ')' {% setRange (getRange ($2,$3,$4)) <\$> makeShapeIrrelevantM $1 $3 }+ | '..' '{' ModalTBind '}' {% setRange (getRange ($2,$3,$4)) . hide <\$> makeShapeIrrelevantM $1 $3 }+ | '..' "{{" ModalTBind "}}" {% setRange (getRange ($2,$3,$4)) . makeInstance <\$> makeShapeIrrelevantM $1 $3 } -- x1 .. xn : A@@ -895,26 +927,28 @@ -- absurd lambda is represented by @Left hiding@ LamBinds :: { LamBinds } LamBinds- : DomainFreeBinding LamBinds { fmap (map DomainFree (List1.toList $1) ++) $2 }- | TypedBinding LamBinds { fmap (DomainFull $1 :) $2 }- | DomainFreeBinding { mkLamBinds $ map DomainFree $ List1.toList $1 }- | TypedBinding { mkLamBinds [DomainFull $1] }- | '(' ')' { mkAbsurdBinding NotHidden }- | '{' '}' { mkAbsurdBinding Hidden }- | '{{' DoubleCloseBrace { mkAbsurdBinding (Instance NoOverlap) }+ : DomainFreeBinding LamBinds { fmap (map DomainFree (List1.toList $1) ++) $2 }+ | TypedBinding LamBinds { fmap (DomainFull $1 :) $2 }+ | DomainFreeBinding { mkLamBinds $ map DomainFree $ List1.toList $1 }+ | TypedBinding { mkLamBinds [DomainFull $1] }+ | '(' ')' { mkAbsurdBinding NotHidden }+ | '{' '}' { mkAbsurdBinding Hidden }+ | "{{" "}}" { mkAbsurdBinding (Instance NoOverlap) } -- Like LamBinds, but could also parse an absurd LHS of an extended lambda @{ p1 ... () }@ LamBindsAbsurd :: { Either LamBinds (List1 Expr) } LamBindsAbsurd- : DomainFreeBinding LamBinds { Left $ fmap (map DomainFree (List1.toList $1) ++) $2 }- | TypedBinding LamBinds { Left $ fmap (DomainFull $1 :) $2 }- | DomainFreeBindingAbsurd { case $1 of- Left lb -> Left $ mkLamBinds (map DomainFree $ List1.toList lb)- Right es -> Right es }- | TypedBinding { Left $ mkLamBinds [DomainFull $1] }- | '(' ')' { Left $ mkAbsurdBinding NotHidden }- | '{' '}' { Left $ mkAbsurdBinding Hidden }- | '{{' DoubleCloseBrace { Left $ mkAbsurdBinding (Instance NoOverlap) }+ : DomainFreeBinding LamBinds { Left $ fmap (map DomainFree (List1.toList $1) ++) $2 }+ | TypedBinding LamBinds { Left $ fmap (DomainFull $1 :) $2 }+ | TypedBinding { Left $ mkLamBinds [DomainFull $1] }+ | '(' ')' { Left $ mkAbsurdBinding NotHidden }+ | '{' '}' { Left $ mkAbsurdBinding Hidden }+ | "{{" "}}" { Left $ mkAbsurdBinding (Instance NoOverlap) }+ | DomainFreeBindingAbsurd {+ case $1 of+ Left lb -> Left $ mkLamBinds (map DomainFree $ List1.toList lb)+ Right es -> Right es+ } -- FNF, 2011-05-05: No where-clauses in extended lambdas for now. -- Andreas, 2020-03-28: And also not in sight either nine years later.@@ -996,12 +1030,13 @@ : BId MaybeAsPattern { Left . singleton $ mkDomainFree_ id $2 $1 } | '.' BId MaybeAsPattern { Left . singleton $ mkDomainFree_ (makeIrrelevant $1) $3 $2 } | '..' BId MaybeAsPattern { Left . singleton $ mkDomainFree_ (makeShapeIrrelevant $1) $3 $2 }+ -- just parentheses- | '(' Application ')' {% exprToPattern (rawApp $2) >>= \ p ->- pure . Left . singleton $ mkDomainFree_ id (Just p) $ simpleHole }- | '{' CommaBIdAndAbsurds '}'- { first (fmap hide) $2 }- | '{{' CommaBIds DoubleCloseBrace { Left $ fmap makeInstance $2 }+ | '(' Application ')' {% exprToPattern (rawApp $2) >>= \ p ->+ pure . Left . singleton $ mkDomainFree_ id (Just p) $ simpleHole }+ | '{' CommaBIdAndAbsurds '}' { first (fmap hide) $2 }+ | "{{" CommaBIds "}}" { Left $ fmap makeInstance $2 }+ -- additonal attributes, e.g. @tactic | '(' Attributes1 CommaBIdAndAbsurds ')' {% applyAttrs $2 defaultArgInfo <&> \ ai ->@@ -1009,29 +1044,33 @@ | '{' Attributes1 CommaBIdAndAbsurds '}' {% applyAttrs $2 defaultArgInfo <&> \ ai -> first (fmap (hide . setTacticAttr $2 . setArgInfo ai)) $3 }- | '{{' Attributes1 CommaBIds DoubleCloseBrace+ | "{{" Attributes1 CommaBIds "}}" {% Left <\$> applyAttributes $2 (makeInstance defaultArgInfo) $3 }+ -- additional irrelevance- | '.' '(' CommaBIds ')' { Left $ fmap (makeIrrelevant $1) $3 }- | '.' '{' CommaBIds '}' { Left $ fmap (hide . makeIrrelevant $1) $3 }- | '.' '{{' CommaBIds DoubleCloseBrace { Left $ fmap (makeInstance . makeIrrelevant $1) $3 }+ | '.' '(' CommaBIds ')' { Left $ fmap (makeIrrelevant $1) $3 }+ | '.' '{' CommaBIds '}' { Left $ fmap (hide . makeIrrelevant $1) $3 }+ | '.' "{{" CommaBIds "}}" { Left $ fmap (makeInstance . makeIrrelevant $1) $3 }+ -- additional shape-irrelevance- | '..' '(' CommaBIds ')' { Left $ fmap (makeShapeIrrelevant $1) $3 }- | '..' '{' CommaBIds '}' { Left $ fmap (hide . makeShapeIrrelevant $1) $3 }- | '..' '{{' CommaBIds DoubleCloseBrace { Left $ fmap (makeInstance . makeShapeIrrelevant $1) $3 }+ | '..' '(' CommaBIds ')' { Left $ fmap (makeShapeIrrelevant $1) $3 }+ | '..' '{' CommaBIds '}' { Left $ fmap (hide . makeShapeIrrelevant $1) $3 }+ | '..' "{{" CommaBIds "}}" { Left $ fmap (makeInstance . makeShapeIrrelevant $1) $3 }+ -- additional irrelevance and attributes | '.' '(' Attributes1 CommaBIds ')' {% Left <\$> applyAttributes $3 (makeIrrelevant $1 defaultArgInfo) $4 } | '.' '{' Attributes1 CommaBIds '}' {% Left <\$> applyAttributes $3 (makeIrrelevant $1 $ hide defaultArgInfo) $4 }- | '.' '{{' Attributes1 CommaBIds DoubleCloseBrace+ | '.' "{{" Attributes1 CommaBIds "}}" {% Left <\$> applyAttributes $3 (makeIrrelevant $1 $ makeInstance defaultArgInfo) $4 }+ -- additional shape-irrelevance and attributes | '..' '(' Attributes1 CommaBIds ')' {% Left <\$> applyAttributes $3 (makeShapeIrrelevant $1 defaultArgInfo) $4 } | '..' '{' Attributes1 CommaBIds '}' {% Left <\$> applyAttributes $3 (makeShapeIrrelevant $1 $ hide defaultArgInfo) $4 }- | '..' '{{' Attributes1 CommaBIds DoubleCloseBrace+ | '..' "{{" Attributes1 CommaBIds "}}" {% Left <\$> applyAttributes $3 (makeShapeIrrelevant $1 $ makeInstance defaultArgInfo) $4 } @@ -1182,7 +1221,8 @@ | Macro { singleton $1 } | Postulate { singleton $1 } | Primitive { singleton $1 }- | Open { $1 }+ | Import { singleton $1 }+ | Open { singleton $1 } | ModuleMacro { singleton $1 } | Module { singleton $1 } | Pragma { singleton $1 }@@ -1202,22 +1242,27 @@ -- {n1 .n2} n3 .n4 {n5} .{n6 n7} ... : Type. ArgTypeSigs :: { List1 (Arg Declaration) } ArgTypeSigs- : ModalArgIds ':' Expr { let (attrs, xs) = $1 in- fmap (fmap (\ x -> typeSig defaultArgInfo (getTacticAttr attrs) x $3)) xs }+ : ModalArgIds ':' Expr { let (tac, xs) = $1 in+ fmap (fmap (\ x -> typeSig defaultArgInfo tac x $3)) xs } | 'overlap' ModalArgIds ':' Expr {%- let (attrs, xs) = $2+ let (tac, xs) = $2 setOverlap x = case getHiding x of Instance _ -> return $ makeInstance' YesOverlap x _ -> parseErrorRange $1 "The 'overlap' keyword only applies to instance fields (fields marked with {{ }})"- in T.traverse (setOverlap . fmap (\ x -> typeSig defaultArgInfo (getTacticAttr attrs) x $4)) xs }+ in T.traverse (setOverlap . fmap (\ x -> typeSig defaultArgInfo tac x $4)) xs } | 'instance' ArgTypeSignatures { let setInstance (TypeSig info tac x t) = TypeSig (makeInstance info) tac x t setInstance _ = __IMPOSSIBLE__ in fmap (fmap setInstance) $2 } +ModalArgTypeSigs :: { List1 Declaration }+ModalArgTypeSigs+ : ModalArgIds ':' Expr { let (tac, xs) = $1 in+ fmap (\ (Arg ai x) -> typeSig ai tac x $3) xs }+ -- Function declarations. The left hand side is parsed as an expression to allow -- declarations like 'x::xs ++ ys = e', when '::' has higher precedence than '++'. -- FunClause also handle possibly dotted type signatures.@@ -1330,10 +1375,8 @@ -- Variable declarations for automatic generalization Generalize :: { Declaration }-Generalize : 'variable' ArgTypeSignaturesOrEmpty- { let- toGeneralize (Arg info (TypeSig _ tac x t)) = TypeSig info tac x t- in Generalize (kwRange $1) (map toGeneralize $2) }+Generalize : 'variable' Block0(ModalArgTypeSigs)+ { Generalize (kwRange $1) (List1.concat $2) } -- Mutually recursive declarations. Mutual :: { Declaration }@@ -1359,17 +1402,19 @@ Macro :: { Declaration } Macro : 'macro' Declarations0 { Macro (kwRange $1) $2 } - -- Postulates.+--+-- Checked in nicifier:+-- Can only contain type signatures, possibly in instance and private blocks. Postulate :: { Declaration } Postulate : 'postulate' Declarations0 { Postulate (kwRange $1) $2 } --- Primitives. Can only contain type signatures.+-- Primitives.+--+-- Checked in nicifier:+-- Can only contain type signatures, possibly in instance and private blocks. Primitive :: { Declaration }-Primitive : 'primitive' ArgTypeSignaturesOrEmpty {- let { setArg (Arg info (TypeSig _ tac x t)) = TypeSig info tac x t- ; setArg _ = __IMPOSSIBLE__ } in- Primitive (kwRange $1) (map setArg $2) }+Primitive : 'primitive' Declarations0 { Primitive (kwRange $1) $2 } -- Unquoting declarations. UnquoteDecl :: { Declaration }@@ -1419,11 +1464,11 @@ HoleName :: { NamedArg HoleName } HoleName- : SimpleTopHole { defaultNamedArg $1 }- | '{' SimpleHole '}' { hide $ defaultNamedArg $2 }- | '{{' SimpleHole '}}' { makeInstance $ defaultNamedArg $2 }+ : SimpleTopHole { defaultNamedArg $1 }+ | '{' SimpleHole '}' { hide $ defaultNamedArg $2 }+ | "{{" SimpleHole "}}" { makeInstance $ defaultNamedArg $2 } | '{' SimpleId '=' SimpleHole '}' { hide $ defaultArg $ userNamed $2 $4 }- | '{{' SimpleId '=' SimpleHole '}}' { makeInstance $ defaultArg $ userNamed $2 $4 }+ | "{{" SimpleId '=' SimpleHole "}}" { makeInstance $ defaultArg $ userNamed $2 $4 } SimpleTopHole :: { HoleName } SimpleTopHole@@ -1446,97 +1491,50 @@ : SimpleId { $1 } | '_' { Ranged (getRange $1) "_" } -MaybeOpen :: { Maybe Range }-MaybeOpen : 'open' { Just (getRange $1) }- | {- empty -} { Nothing }+MaybeOpen :: { OpenShortHand }+MaybeOpen : 'open' { DoOpen (kwRange $1) }+ | {- empty -} { DontOpen } --- Open-Open :: { List1 Declaration }-Open : MaybeOpen 'import' ModuleName OpenArgs ImportDirective {%- let- { doOpen = maybe DontOpen (const DoOpen) $1- ; m = $3- ; es = $4- ; dir = $5- ; r = getRange ($1, $2, m, es, dir)- ; mr = getRange m- ; unique = hashString $ prettyShow $ (Strict.Nothing :: Strict.Maybe ()) <$ r- -- turn range into unique id, but delete file path- -- which is absolute and messes up suite of failing tests- -- (different hashs on different installations)- -- TODO: Don't use (insecure) hashes in this way.- ; fresh = Name mr NotInScope $ singleton $ Id $ stringToRawName $ ".#" ++ prettyShow m ++ "-" ++ show unique- ; fresh' = Name mr NotInScope $ singleton $ Id $ stringToRawName $ ".#" ++ prettyShow m ++ "-" ++ show (unique + 1)- ; impStm asR = Import (getRange ($2, $3)) m (Just (AsName (Right fresh) asR)) DontOpen defaultImportDir- ; appStm m' es =- Private empty Inserted- [ ModuleMacro r defaultErased m'- (SectionApp (getRange es) [] (QName fresh) es)- doOpen dir- ]- ; (initArgs, last2Args) = splitAt (length es - 2) es- ; parseAsClause = case last2Args of- { [ Ident (QName (Name asR InScope (Id x :| [])))- , e- -- Andreas, 2018-11-03, issue #3364, accept anything after 'as'- -- but require it to be a 'Name' in the scope checker.- ] | rawNameToString x == "as" -> Just . (asR,) $- if | Ident (QName m') <- e -> Right m'- | otherwise -> Left e- ; _ -> Nothing- }- } in- case es of- { [] -> return $ singleton $ Import r m Nothing doOpen dir- ; _ | Just (asR, m') <- parseAsClause -> return $- if null initArgs then singleton- ( Import (getRange (m, asR, m', dir)) m- (Just (AsName m' asR)) doOpen dir- )- else impStm asR :| [ appStm (fromRight (const fresh') m') initArgs ]- -- Andreas, 2017-05-13, issue #2579- -- Nisse reports that importing with instantation but without open- -- could be usefule for bringing instances into scope.- -- Ulf, 2018-12-6: Not since fixes of #1913 and #2489 which require- -- instances to be in scope.- | DontOpen <- doOpen -> parseErrorRange $2 "An import statement with module instantiation is useless without either an `open' keyword or an `as` binding giving a name to the instantiated module."- | otherwise -> return $- impStm noRange :|- appStm (noName $ beginningOf $ getRange m) es :- []- }- }- |'open' ModuleName OpenArgs ImportDirective {+-- Import with possible opening.+Import :: { Declaration }+Import+ : MaybeOpen 'import' ModuleName OpenArgs ImportDirective+ { Import $1 (kwRange $2) $3 (Right $4) $5 }++-- Open without import.+Open :: { Declaration }+Open+ : 'open' ModuleName OpenArgs ImportDirective { let { m = $2 ; es = $3 ; dir = $4 ; r = getRange ($1, m, es, dir)- } in singleton $+ } in case es of- { [] -> Open r m dir+ { [] -> Open (kwRange $1) m dir ; _ -> Private empty Inserted [ ModuleMacro r defaultErased (noName $ beginningOf $ getRange m) (SectionApp (getRange (m , es)) [] m es)- DoOpen dir+ (DoOpen (kwRange $1)) dir ] }- }- | 'open' ModuleName '{{' '...' DoubleCloseBrace ImportDirective {- let r = getRange $2 in singleton $+ }+ | 'open' ModuleName "{{" '...' "}}" ImportDirective {+ let r = getRange $2 in Private empty Inserted- [ ModuleMacro r defaultErased (noName $ beginningOf $ getRange $2)- (RecordModuleInstance r $2) DoOpen $6+ [ ModuleMacro r defaultErased (noName $ beginningOf r)+ (RecordModuleInstance r $2) (DoOpen (kwRange $1)) $6 ]- }+ } OpenArgs :: { [Expr] } OpenArgs : {- empty -} { [] } | Expr3 OpenArgs { $1 : $2 } ModuleApplication :: { Telescope -> Parser ModuleApplication }-ModuleApplication : ModuleName '{{' '...' DoubleCloseBrace { (\ts ->+ModuleApplication : ModuleName "{{" '...' "}}" { (\ts -> if null ts then return $ RecordModuleInstance (getRange ($1,$2,$3,$4)) $1 else parseError "No bindings allowed for record module with non-canonical implicits" ) }@@ -1561,7 +1559,7 @@ {% do { ma <- $7 (map addType $5) ; erased <- onlyErased $3 ; return $ ModuleMacro (getRange ($1, $2, $3, $4, ma, $8))- erased $4 ma DoOpen $8+ erased $4 ma (DoOpen (kwRange $1)) $8 } } -- Module@@ -1581,9 +1579,6 @@ Underscore :: { Name } Underscore : '_' { noName (getRange $1) } -TopLevel :: { [Declaration] }-TopLevel : TopDeclarations { figureOutTopLevelModule $1 }- Pragma :: { Declaration } Pragma : DeclarationPragma { Pragma $1 } @@ -1610,6 +1605,7 @@ | CatchallPragma { $1 } | DisplayPragma { $1 } | EtaPragma { $1 }+ | EtaEqualityPragma { $1 } | NoPositivityCheckPragma { $1 } | NoUniverseCheckPragma { $1 } | PolarityPragma { $1 }@@ -1698,6 +1694,11 @@ : '{-#' 'ETA' PragmaQName '#-}' { EtaPragma (getRange ($1,$2,$3,$4)) $3 } +EtaEqualityPragma :: { Pragma }+EtaEqualityPragma+ : '{-#' 'ETA_EQUALITY' '#-}'+ { EtaEqualityPragma (getRange ($1,$2,$3)) }+ NoTerminationCheckPragma :: { Pragma } NoTerminationCheckPragma : '{-#' 'NO_TERMINATION_CHECK' '#-}'@@ -1781,6 +1782,25 @@ Sequences of declarations --------------------------------------------------------------------------} +-- A nonempty block of things.+Block1(p) -- :: List1 p+ : vopen Block1i(p) close { List1.reverse $2 }++-- Inside the layout block.+Block1i(p) -- :: List1 p+ : Block1i(p) semi p { $3 <| $1 }+ | p { singleton $1 }++-- A possibly empty block of things+Block0(p) -- :: [p]+ : vopen Block0i(p) close { reverse $2 }++-- Inside the layout block.+Block0i(p)+ : Block0i(p) semi p { $3 : $1 }+ | p { [ $1 ] }+ | {- empty -} { [] }+ -- A variant of TypeSignatures which uses ArgTypeSigs instead of -- TypeSigs. ArgTypeSignatures :: { List1 (Arg TypeSignature) }@@ -1907,7 +1927,7 @@ -> Parser Pragma parseDisplayPragma r pos s = case parsePosString pos defaultParseFlags [normal] funclauseParser s of- ParseOk s (FunClause (LHS lhs [] []) (RHS rhs) NoWhere ca :| []) | null (parseInp s) ->+ ParseOk s (FunClause defaultArgInfo (LHS lhs [] []) (RHS rhs) NoWhere ca :| []) | null (parseInp s) -> return $ DisplayPragma r lhs rhs _ -> parseError "Invalid DISPLAY pragma. Should have form {-# DISPLAY LHS = RHS #-}."
src/full/Agda/Syntax/Parser/Tokens.hs view
@@ -1,7 +1,8 @@ {-# OPTIONS_GHC -Wunused-imports #-} module Agda.Syntax.Parser.Tokens- ( Token(..)+ ( Token(.., TokQual)+ , QualifiableToken(..), QualifiedToken(..) , Keyword(..) , layoutKeywords , Symbol(..)@@ -28,6 +29,7 @@ | KwFOREIGN | KwCOMPILE | KwIMPOSSIBLE | KwSTATIC | KwINJECTIVE | KwINJECTIVE_FOR_INFERENCE | KwINLINE | KwNOINLINE | KwETA+ | KwETA_EQUALITY | KwNO_TERMINATION_CHECK | KwTERMINATING | KwNON_TERMINATING | KwNOT_PROJECTION_LIKE | KwNON_COVERING@@ -67,18 +69,53 @@ ] data Symbol- = SymDot | SymSemi | SymVirtualSemi | SymBar- | SymColon | SymArrow | SymEqual | SymLambda- | SymUnderscore | SymQuestionMark | SymAs- | SymOpenParen | SymCloseParen- | SymOpenIdiomBracket | SymCloseIdiomBracket | SymEmptyIdiomBracket- | SymDoubleOpenBrace | SymDoubleCloseBrace- | SymOpenBrace | SymCloseBrace- | SymOpenVirtualBrace | SymCloseVirtualBrace- | SymOpenPragma | SymClosePragma | SymEllipsis | SymDotDot- | SymEndComment -- ^ A misplaced end-comment "-}".- deriving (Eq, Show)+ = SymDot -- ^ @.@+ | SymSemi -- ^ @;@+ | SymVirtualSemi -- ^ layout-implied @;@+ | SymBar -- ^ @|@+ | SymColon -- ^ @:@+ | SymArrow -- ^ @->@ or @→@+ | SymEqual -- ^ @=@+ | SymLambda -- ^ @\@ or @λ@+ | SymUnderscore -- ^ @_@+ | SymQuestionMark -- ^ @?@+ | SymAs -- ^ @@@+ | SymOpenParen -- ^ @(@+ | SymCloseParen -- ^ @)@ + | SymEmptyIdiomBracket -- ^ @(|)@ or @⦇⦈@+ | SymOpenIdiomBracket Bool -- ^ @(|@ or @⦇@, 'True' if unicode+ | SymCloseIdiomBracket Bool -- ^ @|)@ or @⦈@, 'True' if unicode++ | SymDoubleOpenBrace Bool -- ^ @{{@ or @⦃@, 'True' if unicode+ | SymDoubleCloseBrace Bool -- ^ @{{@ or @⦄@, 'True' if unicode+ | SymOpenBrace -- ^ @{@+ | SymCloseBrace -- ^ @}@+ | SymOpenVirtualBrace -- ^ layout-implied @{@+ | SymCloseVirtualBrace -- ^ layout-implied @}@+ | SymOpenPragma -- ^ @{-#@+ | SymClosePragma -- ^ @#-}@+ | SymEllipsis -- ^ @...@ or @…@+ | SymDotDot -- ^ @..@+ | SymEndComment -- ^ A misplaced end-comment "-}".+ deriving (Eq, Show)++-- | "Tokens" which may appear qualified.+data QualifiableToken+ = QualDo -- ^ qualified @do@+ | QualEmptyIdiom -- ^ qualified @(|)@ or @⦇⦈@+ | QualOpenIdiom Bool -- ^ qualified @(|@ or @⦇@, 'True' if unicode+ deriving (Eq, Show)++-- | A "qualified token", i.e. a sequence of (module) names followed by+-- one of the allowed ('QualifiableToken') keywords/symbols.+data QualifiedToken+ = QualifiedToken+ QualifiableToken -- ^ The token itself.+ [(Interval, String)] -- ^ Parts for the qualifying identifier, together with their ranges.+ Interval -- ^ Range of the token being qualified.+ deriving (Eq, Show)+ data Token -- Keywords = TokKeyword Keyword Interval@@ -87,6 +124,7 @@ | TokQId [(Interval, String)] -- Non-empty namespace. The intervals for -- "A.B.x" correspond to "A.", "B." and "x".+ | TokQual_ QualifiedToken -- Literals | TokLiteral RLiteral -- Special symbols@@ -102,10 +140,19 @@ | TokEOF Interval deriving (Eq, Show) +pattern TokQual :: QualifiableToken -> [(Interval, String)] -> Interval -> Token+pattern TokQual clz iss j = TokQual_ (QualifiedToken clz iss j)++{-# COMPLETE TokKeyword, TokId, TokQId, TokQual, TokLiteral, TokSymbol, TokString, TokTeX, TokMarkup, TokComment, TokDummy, TokEOF #-}++instance HasRange QualifiedToken where+ getRange (QualifiedToken _ iss j) = getRange (map fst iss, j)+ instance HasRange Token where getRange (TokKeyword _ i) = getRange i getRange (TokId (i, _)) = getRange i getRange (TokQId iss) = getRange (map fst iss)+ getRange (TokQual_ q) = getRange q getRange (TokLiteral lit) = getRange lit getRange (TokSymbol _ i) = getRange i getRange (TokString (i, _)) = getRange i
src/full/Agda/Syntax/Position.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} -- Due to KILLRANGE vararg typeclass +{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+ {-| Position information for syntax. Crucial for giving good error messages. -} @@ -9,6 +12,9 @@ Position , PositionWithoutFile , Position'(..)+ , pattern Pn+ , posLine+ , posCol , SrcFile , RangeFile(..) , mkRangeFile@@ -22,6 +28,9 @@ -- * Intervals , Interval , IntervalWithoutFile+ , IntervalWithoutFile'+ , pattern PackIWF+ , unpackIWF , Interval'(Interval, iStart', iEnd') , intervalInvariant , iStart@@ -77,16 +86,14 @@ import qualified Data.Foldable as Fold import Data.Function (on)-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.Sequence (Seq) import qualified Data.Sequence as Seq-import Data.Semigroup (Semigroup(..)) import Data.Void-import Data.Word (Word32)+import Data.Word (Word32, Word64) import GHC.Generics (Generic) @@ -96,16 +103,21 @@ import Agda.Utils.List import Agda.Utils.List1 (List1) import Agda.Utils.List2 (List2)-import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.Maybe.Strict qualified as Strict+import Agda.Utils.Map1 (Map1) import Agda.Utils.Null import Agda.Utils.Permutation import Agda.Utils.Set1 (Set1)-import qualified Agda.Utils.Set1 as Set1+import Agda.Utils.Set1 qualified as Set1 import Agda.Utils.TypeLevel (IsBase, All, Domains) import Agda.Utils.Tuple (sortPair)+import Agda.Utils.Word (packW64, splitW64)+import Agda.Utils.Hash (combineWord) import Agda.Utils.Impossible+import Data.Hashable (Hashable(..)) + {-------------------------------------------------------------------------- Types and classes --------------------------------------------------------------------------}@@ -119,18 +131,36 @@ -- messages for the user. -- -- Note the invariant which positions have to satisfy: 'positionInvariant'.-data Position' a = Pn+data Position' a = Pn' { srcFile :: !a -- ^ File. , posPos :: !Word32 -- ^ Position, counting from 1.- , posLine :: !Word32- -- ^ Line number, counting from 1.- , posCol :: !Word32- -- ^ Column number, counting from 1.+ , posLineCol :: !Word64 -- ^ Line and position numbers as Word32, both counting from 1. }- deriving (Show, Functor, Foldable, Traversable, Generic)+ deriving (Functor, Foldable, Traversable, Generic) +instance Show a => Show (Position' a) where+ showsPrec :: Int -> Position' a -> ShowS+ showsPrec i (Pn a p l c) = showParen (i > 10) $+ showString "Pn " .+ showsPrec 11 a . showChar ' ' .+ showsPrec 11 p . showChar ' ' .+ showsPrec 11 l . showChar ' ' .+ showsPrec 11 c++pattern Pn :: a -> Word32 -> Word32 -> Word32 -> Position' a+pattern Pn a p l c <- Pn' a p (splitW64 -> (l, c)) where+ Pn a p l c = Pn' a p (packW64 l c)+{-# COMPLETE Pn #-}+{-# INLINE Pn #-}++posLine :: Position' a -> Word32+posLine (Pn' _ _ lc) = case splitW64 lc of (x, _) -> x++posCol :: Position' a -> Word32+posCol (Pn' _ _ lc) = case splitW64 lc of (_, x) -> x+ positionInvariant :: Position' a -> Bool positionInvariant p = posPos p > 0 && posLine p > 0 && posCol p > 0@@ -144,6 +174,10 @@ instance Ord a => Ord (Position' a) where compare = compare `on` importantPart +instance Null a => Null (Position' a) where+ null (Pn' f p lc) = null f && null p && null lc+ empty = Pn' empty 0 0+ type SrcFile = Strict.Maybe RangeFile -- | File information used in the 'Position', 'Interval' and 'Range'@@ -185,6 +219,10 @@ instance Ord RangeFile where compare = compare `on` rangeFileName +instance Null RangeFile where+ null (RangeFile file n) = null file && null n+ empty = RangeFile empty empty+ instance NFData RangeFile where rnf (RangeFile _ n) = rnf n @@ -239,6 +277,35 @@ iLength :: Interval' a -> Word32 iLength i = posPos (iEnd i) - posPos (iStart i) +-- | Tolerably efficient representation of 'IntervalWithoutFile'+data IntervalWithoutFile' = IWF !Word64 !Word64 !Word64+ deriving (Eq)++instance NFData IntervalWithoutFile' where+ rnf x = seq x ()++instance Hashable IntervalWithoutFile' where+ hashWithSalt h (IWF a b c) = fromIntegral $+ fromIntegral h `combineWord` fromIntegral a+ `combineWord` fromIntegral b+ `combineWord` fromIntegral c++pattern PackIWF :: IntervalWithoutFile -> IntervalWithoutFile'+pattern PackIWF x <- ((\(IWF ps lc0 lc1) -> case splitW64 ps of+ (p0, p1) -> Interval () (Pn' () p0 lc0) (Pn' () p1 lc1)) -> x) where+ PackIWF (Interval _ (Pn' _ p0 lc0) (Pn' _ p1 lc1)) = IWF (packW64 p0 p1) lc0 lc1+{-# INLINE PackIWF #-}+{-# COMPLETE PackIWF #-}++unpackIWF :: IntervalWithoutFile' -> IntervalWithoutFile+unpackIWF (PackIWF x) = x++instance Ord IntervalWithoutFile' where+ compare (PackIWF x) (PackIWF y) = compare x y++instance Show IntervalWithoutFile' where+ showsPrec i (PackIWF x) = showsPrec i x+ -- | A range is a file name, plus a sequence of intervals, assumed to -- point to the given file. The intervals should be consecutive and -- separated.@@ -246,10 +313,12 @@ -- Note the invariant which ranges have to satisfy: 'rangeInvariant'. data Range' a = NoRange- | Range !a (Seq IntervalWithoutFile)+ | Range !a (Seq IntervalWithoutFile') deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +-- TODO: custom Eq, Ord, Hashable using better Seq functions+ type Range = Range' SrcFile type RangeWithoutFile = Range' () @@ -272,18 +341,26 @@ mempty = empty mappend = (<>) +-- TODO: efficient Seq function+ -- | The intervals that make up the range. The intervals are -- consecutive and separated ('consecutiveAndSeparated').+rangeIntervals' :: Range' a -> [IntervalWithoutFile']+rangeIntervals' NoRange = []+rangeIntervals' (Range _ is) = Fold.toList is++-- | The intervals that make up the range. The intervals are+-- consecutive and separated ('consecutiveAndSeparated'). rangeIntervals :: Range' a -> [IntervalWithoutFile] rangeIntervals NoRange = []-rangeIntervals (Range _ is) = Fold.toList is+rangeIntervals (Range _ is) = map unpackIWF $ Fold.toList is -- | Turns a file name plus a list of intervals into a range. -- -- Precondition: 'consecutiveAndSeparated'. intervalsToRange :: a -> [IntervalWithoutFile] -> Range' a intervalsToRange _ [] = NoRange-intervalsToRange f is = Range f (Seq.fromList is)+intervalsToRange f is = Range f (Seq.fromList $ map PackIWF is) -- | Are the intervals consecutive and separated, do they all point to -- the same file, and do they satisfy the interval invariant?@@ -296,7 +373,7 @@ allConsecutive (\ i j -> iEnd i < iStart j) is -- | Range invariant.-rangeInvariant :: Ord a => Range' a -> Bool+rangeInvariant :: Range' a -> Bool rangeInvariant r = consecutiveAndSeparated (rangeIntervals r) &&@@ -325,10 +402,10 @@ -- | Conflate a range to its right margin. rightMargin :: Range -> Range-rightMargin r@NoRange = r-rightMargin r@(Range f is) = case Seq.viewr is of+rightMargin r@NoRange = r+rightMargin (Range f is) = case Seq.viewr is of Seq.EmptyR -> __IMPOSSIBLE__- _ Seq.:> Interval () s e -> intervalToRange f (Interval () e e)+ _ Seq.:> PackIWF (Interval () _s e) -> intervalToRange f (Interval () e e) -- | Wrapper to indicate that range should be printed. newtype PrintRange a = PrintRange a@@ -422,6 +499,9 @@ instance HasRangeWithoutFile RangeWithoutFile where getRangeWithoutFile = id +instance HasRangeWithoutFile Range where+ getRangeWithoutFile = void . getRange+ instance HasRangeWithoutFile () where getRangeWithoutFile _ = noRange @@ -526,6 +606,7 @@ instance {-# OVERLAPPABLE #-} KillRange a => KillRange [a] instance {-# OVERLAPPABLE #-} KillRange a => KillRange (Map k a)+instance {-# OVERLAPPABLE #-} KillRange a => KillRange (Map1 k a) instance KillRange a => KillRange (Drop a) instance KillRange a => KillRange (List1 a)@@ -560,12 +641,7 @@ -- | The first position in a file: position 1, line 1, column 1. startPos' :: a -> Position' a-startPos' f = Pn- { srcFile = f- , posPos = 1- , posLine = 1- , posCol = 1- }+startPos' f = Pn f 1 1 1 -- | The first position in a file: position 1, line 1, column 1. startPos :: Maybe RangeFile -> Position@@ -587,7 +663,7 @@ -- character in the next line. Any other character moves the -- position to the next column. movePos :: Position' a -> Char -> Position' a-movePos (Pn f p l c) '\n' = Pn f (p + 1) (l + 1) 1+movePos (Pn f p l _) '\n' = Pn f (p + 1) (l + 1) 1 movePos (Pn f p l c) _ = Pn f (p + 1) l (c + 1) -- | Advance the position by a string.@@ -610,20 +686,20 @@ -- | Converts two positions to a range. -- -- Precondition: The positions have to point to the same file.-posToRange :: Position' a -> Position' a -> Range' a+posToRange :: Position' a -> Position' b -> Range' a posToRange p1 p2 = posToRange' (srcFile p1) (p1 { srcFile = () }) (p2 { srcFile = () }) -- | Converts a file name and an interval to a range. intervalToRange :: a -> IntervalWithoutFile -> Range' a-intervalToRange f i = Range f (Seq.singleton i)+intervalToRange f i = Range f (Seq.singleton (PackIWF i)) -- | Converts a range to an interval, if possible. rangeToIntervalWithFile :: Range' a -> Maybe (Interval' a) rangeToIntervalWithFile NoRange = Nothing rangeToIntervalWithFile (Range f is) = case (Seq.viewl is, Seq.viewr is) of- (head Seq.:< _, _ Seq.:> last) -> Just $ Interval f (iStart head) (iEnd last)+ (PackIWF head Seq.:< _, _ Seq.:> PackIWF last) -> Just $ Interval f (iStart head) (iEnd last) _ -> __IMPOSSIBLE__ -- | Converts a range to an interval, if possible.@@ -638,16 +714,17 @@ maybe __IMPOSSIBLE__ (intervalToRange f) $ rangeToInterval r -- | Removes gaps between intervals on the same line.-continuousPerLine :: Ord a => Range' a -> Range' a+continuousPerLine :: Range' a -> Range' a continuousPerLine r@NoRange = r continuousPerLine r@(Range f _) =- Range f (Seq.unfoldr step (rangeIntervals r))+ Range f (Seq.unfoldr step (rangeIntervals' r)) where+ step :: [IntervalWithoutFile'] -> Maybe (IntervalWithoutFile', [IntervalWithoutFile']) step [] = Nothing step [i] = Just (i, [])- step (i : is@(j : js))- | sameLine = step (fuseIntervals i j : js)- | otherwise = Just (i, is)+ step (pi@(PackIWF i) : is@(PackIWF j : js))+ | sameLine = let !ij = PackIWF (fuseIntervals i j) in step (ij : js)+ | otherwise = Just (pi, is) where sameLine = posLine (iEnd i) == posLine (iStart j) @@ -679,16 +756,17 @@ -- Meaning it finds the least range @r0@ that covers @r@ and @r'@. -- -- Precondition: The ranges must point to the same file (or be empty).-fuseRanges :: (Ord a) => Range' a -> Range' a -> Range' a+fuseRanges :: Range' a -> Range' a -> Range' a fuseRanges NoRange is2 = is2 fuseRanges is1 NoRange = is1 fuseRanges (Range f is1) (Range _ is2) = Range f (fuse is1 is2) where+ fuse :: Seq IntervalWithoutFile' -> Seq IntervalWithoutFile' -> Seq IntervalWithoutFile' fuse is1 is2 = case (Seq.viewl is1, Seq.viewr is1, Seq.viewl is2, Seq.viewr is2) of (Seq.EmptyL, _, _, _) -> is2 (_, _, Seq.EmptyL, _) -> is1- (s1 Seq.:< r1, l1 Seq.:> e1, s2 Seq.:< r2, l2 Seq.:> e2)+ (PackIWF s1 Seq.:< r1, l1 Seq.:> PackIWF e1, PackIWF s2 Seq.:< r2, l2 Seq.:> PackIWF e2) -- Special cases. | iEnd e1 < iStart s2 -> is1 Seq.>< is2 | iEnd e2 < iStart s1 -> is2 Seq.>< is1@@ -703,18 +781,23 @@ mergeTouching l e s r = l Seq.>< i Seq.<| r where- i = Interval () (iStart e) (iEnd s)+ !i = PackIWF (Interval () (iStart e) (iEnd s)) -- The following two functions could use binary search instead of -- linear.-- outputLeftPrefix s1 r1 s2 is2 = s1 Seq.<| r1' Seq.>< fuse r1'' is2+ outputLeftPrefix :: IntervalWithoutFile -> Seq IntervalWithoutFile' -> IntervalWithoutFile -> Seq IntervalWithoutFile'+ -> Seq IntervalWithoutFile'+ outputLeftPrefix s1 r1 s2 is2 = s1' Seq.<| r1' Seq.>< fuse r1'' is2 where- (r1', r1'') = Seq.spanl (\s -> iEnd s < iStart s2) r1+ !s1' = PackIWF s1+ (!r1', !r1'') = Seq.spanl (\(PackIWF s) -> iEnd s < iStart s2) r1 - fuseSome s1 r1 s2 r2 = fuse r1' (fuseIntervals s1 s2 Seq.<| r2)+ fuseSome :: IntervalWithoutFile -> Seq IntervalWithoutFile' -> IntervalWithoutFile -> Seq IntervalWithoutFile'+ -> Seq IntervalWithoutFile'+ fuseSome s1 r1 s2 r2 = fuse r1' (s12 Seq.<| r2) where- r1' = Seq.dropWhileL (\s -> iEnd s <= iEnd s2) r1+ !s12 = PackIWF (fuseIntervals s1 s2)+ !r1' = Seq.dropWhileL (\(PackIWF s) -> iEnd s <= iEnd s2) r1 {-# INLINE fuseRange #-} -- | Precondition: The ranges must point to the same file (or be@@ -796,3 +879,24 @@ (a:) <$> go as' bs else (b:) <$> go as bs'++-- Hashable instances++instance Hashable RangeFile where+ {-# INLINE hashWithSalt #-}+ hashWithSalt h (RangeFile x y) = h `hashWithSalt` x `hashWithSalt` y++instance Hashable a => Hashable (Position' a) where+ {-# INLINE hashWithSalt #-}+ hashWithSalt h (Pn' a b c) =+ fromIntegral (fromIntegral (hashWithSalt h a) `combineWord` fromIntegral b `combineWord` fromIntegral c)++instance Hashable a => Hashable (Interval' a) where+ {-# INLINE hashWithSalt #-}+ hashWithSalt h (Interval a b c) = h `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c++instance Hashable a => Hashable (Range' a) where+ {-# INLINE hashWithSalt #-}+ hashWithSalt h = \case+ NoRange -> h + 1+ Range a b -> h + 2 `hashWithSalt` a `hashWithSalt` b
src/full/Agda/Syntax/Reflected.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS_GHC -fwarn-missing-signatures #-}+{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-} module Agda.Syntax.Reflected where @@ -9,10 +11,9 @@ import Agda.Syntax.Abstract.Name import Agda.Syntax.Internal (Dom) -import Agda.Utils.List1 (List1, pattern (:|))-import qualified Agda.Utils.List1 as List1+import Agda.Utils.List1 (List1) -type Args = [Arg Term]+type Args = [Arg Term] data Elim' a = Apply (Arg a) -- no record projections for now deriving (Show)
src/full/Agda/Syntax/Scope/Base.hs view
@@ -5,49 +5,55 @@ import Prelude hiding ( null, length ) -import Control.Arrow (first, second, (&&&)) import Control.DeepSeq import Control.Monad -import Data.Either (partitionEithers)-import Data.Foldable ( length, toList )-import Data.Function (on)-import qualified Data.List as List-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Set (Set)-import qualified Data.Set as Set+import Data.Either ( partitionEithers )+import Data.Foldable ( length, toList, foldl' )+import Data.Function ( on )+import Data.HashMap.Strict ( HashMap )+import Data.HashMap.Strict qualified as HMap+import Data.Hashable ( Hashable, hashWithSalt )+import Data.IntMap ( IntMap )+import Data.List qualified as List+import Data.Map.Strict ( Map )+import Data.Map.Strict qualified as Map import Data.Maybe-import Data.Semigroup ( Semigroup(..) )+import Data.Ord ( Down(..) ) import GHC.Generics (Generic) import Agda.Benchmarking -import Agda.Syntax.Position+import Agda.Syntax.Abstract.Name as A import Agda.Syntax.Common-import Agda.Syntax.Fixity-import Agda.Syntax.Abstract.Name as A-import Agda.Syntax.Concrete.Name as C-import qualified Agda.Syntax.Concrete as C+import Agda.Syntax.Concrete qualified as C import Agda.Syntax.Concrete.Fixity as C+import Agda.Syntax.Concrete.Name as C+import Agda.Syntax.Fixity+import Agda.Syntax.Position -import Agda.Utils.AssocList (AssocList)-import qualified Agda.Utils.AssocList as AssocList+import Agda.Syntax.Common.Pretty+import Agda.Utils.AssocList ( AssocList )+import Agda.Utils.AssocList qualified as AssocList+import Agda.Utils.Function ( applyWhen, applyUnless ) import Agda.Utils.Functor 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.List1 ( List1, pattern (:|) )+import Agda.Utils.List1 qualified as List1+import Agda.Utils.List2 ( List2 )+import Agda.Utils.List2 qualified as List2+import Agda.Utils.Map qualified as Map+import Agda.Utils.Maybe ( predicateToMaybe ) import Agda.Utils.Null-import Agda.Syntax.Common.Pretty hiding ((<>))-import qualified Agda.Syntax.Common.Pretty as P-import Agda.Utils.Set1 ( Set1 )+import Agda.Utils.Set ( Set )+import Agda.Utils.Set qualified as Set+import Agda.Utils.Set1 ( Set1 ) import Agda.Utils.Singleton-import qualified Agda.Utils.Map as Map+import Agda.Utils.StrictState2 qualified as St2+import Agda.Utils.Tuple ( first, second )+import Agda.Utils.Tuple.Strict ( (&!&) ) import Agda.Utils.Impossible @@ -120,30 +126,27 @@ , _scopeInScope :: InScopeSet , _scopeFixities :: C.Fixities -- ^ Maps concrete names C.Name to fixities , _scopePolarities :: C.Polarities -- ^ Maps concrete names C.Name to polarities- , _scopeRecords :: Map A.QName (A.QName, Maybe Induction)- -- ^ Maps the name of a record to the name of its (co)constructor. } deriving (Show, Generic) -- | For the sake of highlighting, the '_scopeInverseName' map also stores -- the 'KindOfName' of an @A.QName@. data NameMapEntry = NameMapEntry- { qnameKind :: KindOfName -- ^ The 'anameKind'.- , qnameConcrete :: List1 C.QName -- ^ Possible renderings of the abstract name.+ { qnameKind :: !KindOfName -- ^ The 'anameKind'.+ , qnameConcrete :: !(List1 C.QName) -- ^ Possible renderings of the abstract name. } deriving (Show, Generic) -- | Invariant: the 'KindOfName' components should be equal--- whenever we have to concrete renderings of an abstract name.+-- whenever we have two concrete renderings of an abstract name. instance Semigroup NameMapEntry where NameMapEntry k xs <> NameMapEntry _ ys = NameMapEntry k (xs <> ys) -type NameMap = Map A.QName NameMapEntry-type ModuleMap = Map A.ModuleName [C.QName]--- type ModuleMap = Map A.ModuleName (List1 C.QName)+type NameMap = HashMap NameId NameMapEntry+type ModuleMap = HashMap A.ModuleName [C.QName] instance Eq ScopeInfo where- ScopeInfo c1 m1 v1 l1 p1 _ _ _ _ _ _ == ScopeInfo c2 m2 v2 l2 p2 _ _ _ _ _ _ =+ ScopeInfo c1 m1 v1 l1 p1 _ _ _ _ _ == ScopeInfo c2 m2 v2 l2 p2 _ _ _ _ _ = c1 == c2 && m1 == m2 && v1 == v2 && l1 == l2 && p1 == p2 -- | Local variables.@@ -197,11 +200,11 @@ -- | We show shadowed variables as prefixed by a ".", as not in scope. instance Pretty LocalVar where pretty (LocalVar x _ []) = pretty x- pretty (LocalVar x _ xs) = "." P.<> pretty x+ pretty (LocalVar x _ xs) = "." <> pretty x -- | Shadow a local name by a non-empty list of imports. shadowLocal :: List1 AbstractName -> LocalVar -> LocalVar-shadowLocal ys (LocalVar x b zs) = LocalVar x b (List1.toList ys ++ zs)+shadowLocal ys (LocalVar x b zs) = LocalVar x b (List1.toList ys ++! zs) -- | Treat patternBound variable as a module parameter patternToModuleBound :: LocalVar -> LocalVar@@ -270,11 +273,6 @@ f (_scopePolarities s) <&> \x -> s { _scopePolarities = x } -scopeRecords :: Lens' ScopeInfo (Map A.QName (A.QName, Maybe Induction))-scopeRecords f s =- f (_scopeRecords s) <&>- \x -> s { _scopeRecords = x }- scopeFixitiesAndPolarities :: Lens' ScopeInfo (C.Fixities, C.Polarities) scopeFixitiesAndPolarities f s = f' (_scopeFixities s) (_scopePolarities s) <&>@@ -319,6 +317,15 @@ data NameSpace = NameSpace { nsNames :: NamesInScope -- ^ Maps concrete names to a list of abstract names.+ -- If this is part of a scope produced by an 'ImportDirective',+ -- the concrete names should (where possible) match those of the directive.+ -- E.g., if the directive mentions @using (x)@, then the concrete @x@+ -- in the map should be this @x@ rather then the @x@ from the original+ -- scope that is restricted by the import directive.+ -- This is important for the highlighting of the 'UnusedImports' warning.+ , nsNameParts :: NamePartsInScope+ -- ^ Maps name parts to a list of abstract names in which the name+ -- part occurs. , nsModules :: ModulesInScope -- ^ Maps concrete module names to a list of abstract module names. , nsInScope :: InScopeSet@@ -327,10 +334,11 @@ } deriving (Eq, Show, Generic) -type ThingsInScope a = Map C.Name (List1 a)-type NamesInScope = ThingsInScope AbstractName-type ModulesInScope = ThingsInScope AbstractModule-type InScopeSet = Set A.QName+type ThingsInScope a = Map C.Name (List1 a)+type NamesInScope = ThingsInScope AbstractName+type NamePartsInScope = Map RawName NamesInScope+type ModulesInScope = ThingsInScope AbstractModule+type InScopeSet = Set A.QName -- | Set of types consisting of exactly 'AbstractName' and 'AbstractModule'. --@@ -362,35 +370,146 @@ deriving (Eq, Ord, Show, Enum, Bounded, Generic) ------------------------------------------------------------------------+-- * Operator parsing+------------------------------------------------------------------------++-- | Names that are relevant to operator parsing.+data OperatorScope = OpScope {+ osHasOps :: !Bool -- ^ Are there any operators or notations in scope?+ , osScope :: (Map C.QName (List1 AbstractName)) -- ^ All relevant names in global scope.+ , osLocals :: !(AssocList C.Name A.Name) -- ^ Relevant names in local scope.+ } deriving (Eq, Show, Generic)++instance Null OperatorScope where+ empty = OpScope empty empty empty++instance Pretty OperatorScope where+ prettyPrec x (OpScope _ scope locals) = prettyPrec x (scope, locals)++instance NFData OperatorScope++------------------------------------------------------------------------+-- * Live names and copy trimming+------------------------------------------------------------------------++-- | A set of module and definition names that were explicitly referred+-- to during scope checking.+data LiveNames =+ -- | We encountered these names during scope-checking, so they should+ -- be preserved.+ SomeLiveNames+ { liveModules :: !(Set ModuleName)+ , liveNames :: !(Set A.QName)+ }+ -- | An interaction point can see this copy, so we should preserve+ -- every name.+ | AllLiveNames+ deriving (Eq)++instance Semigroup LiveNames where+ SomeLiveNames a b <> SomeLiveNames a' b' = SomeLiveNames (a <> a') (b <> b')+ SomeLiveNames{} <> AllLiveNames = AllLiveNames+ AllLiveNames <> _ = AllLiveNames++instance Monoid LiveNames where+ mempty = SomeLiveNames mempty mempty++instance Pretty LiveNames where+ pretty AllLiveNames = "*"+ pretty (SomeLiveNames mod name) = braces $ vcat+ [ "mods: " <+> pretty mod+ , "names:" <+> pretty name+ ]++-- | Is the given name alive in this set?+--+-- Note: a qualified name can be kept alive by liveness of any of the+-- modules it belongs to.+isNameAlive :: A.QName -> LiveNames -> Bool+isNameAlive _ AllLiveNames = True+isNameAlive qn@(A.QName mod _) live@(SomeLiveNames mods names)+ | qn `Set.member` names = True+ | otherwise = isModuleAlive mod live++-- | Is the given module (or one of its parents) a member of the set?+isModuleAlive :: A.ModuleName -> LiveNames -> Bool+isModuleAlive _ AllLiveNames = True+isModuleAlive (A.MName mod) (SomeLiveNames mods _) =+ any ((`Set.member` mods) . A.MName) (List.inits mod)++------------------------------------------------------------------------+-- * Unused imports+------------------------------------------------------------------------++-- | Information gathered during scope checking for the unused-imports warning+-- when a module is opened.+data OpenedModule = OpenedModule+ { openedRange :: KwRange+ -- ^ 'Range' of the @open@ keyword.+ , openedModule :: A.ModuleName+ -- ^ Module we opened.+ , openedParent :: A.ModuleName+ -- ^ Parent module into which we merged the opened module.+ , openedHasDir :: Bool+ -- ^ Whether the @open@ statement comes with @using@ or @renaming@.+ , openedNameScope :: NamesInScope+ -- ^ The names imported by the @open@ statement.+ -- The keys ('C.Name') of this map should be the concrete names of+ -- the opening directive, if such was given.+ , openedModuleScope :: ModulesInScope+ -- ^ The modules imported by the @open@ statement.+ -- The keys ('C.Name') of this map should be the concrete names of+ -- the opening directive, if such was given.+ , openedCompanions :: Set C.Name+ -- ^ Modules among 'openedModuleScope' that accompany a name+ -- in 'openedNameScope' (e.g. the module of a data type or record type)+ -- and are not mentioned explicitly in the opening directive.+ -- These are not reported individually when unused.+ } deriving (Generic)++instance Null OpenedModule where+ empty = OpenedModule empty empty empty empty empty empty empty+ null (OpenedModule _ _ _ _ s ms _) = null s && null ms++-- | Information gathered during scope checking for the unused-imports warning.+data UnusedImportsState = UnusedImportsState+ { unambiguousLookups :: ![AbstractName]+ -- ^ Names that were unambiguously resolved from a concrete name in the source.+ , ambiguousLookups :: !(IntMap (List2 AbstractName))+ -- ^ Names that were ambiguously resolved from a concrete name in the source.+ -- They are stored with their position in the file+ -- that is matched with disambiguation information produced by the type checker.+ , moduleLookups :: ![AbstractModule]+ -- ^ Modules that were resolved from a concrete name in the source,+ -- either directly or as the qualifier of a qualified name.+ , openedModules :: !(IntMap OpenedModule)+ -- ^ Log of module @open@s with the names they brought into scope.+ } deriving (Generic)++instance Null UnusedImportsState where+ empty = UnusedImportsState empty empty empty empty+ null (UnusedImportsState u a m o) = null u && null a && null m && null o++lensUnambiguousLookups :: Lens' UnusedImportsState [AbstractName]+lensUnambiguousLookups f s = f (unambiguousLookups s) <&> \ !x -> s { unambiguousLookups = x }++lensAmbiguousLookups :: Lens' UnusedImportsState (IntMap (List2 AbstractName))+lensAmbiguousLookups f s = f (ambiguousLookups s) <&> \ !x -> s { ambiguousLookups = x }++lensModuleLookups :: Lens' UnusedImportsState [AbstractModule]+lensModuleLookups f s = f (moduleLookups s) <&> \ !x -> s { moduleLookups = x }++lensOpenedModules :: Lens' UnusedImportsState (IntMap OpenedModule)+lensOpenedModules f s = f (openedModules s) <&> \ !x -> s { openedModules = x }++------------------------------------------------------------------------ -- * Decorated names -- -- - What kind of name? (defined, constructor...) -- - Where does the name come from? (to explain to user) ------------------------------------------------------------------------ --- | For the sake of parsing left-hand sides, we distinguish--- constructor and record field names from defined names.---- Note: order does matter in this enumeration, see 'isDefName'.-data KindOfName- = ConName -- ^ Constructor name ('Inductive' or don't know).- | CoConName -- ^ Constructor name (definitely 'CoInductive').- | FldName -- ^ Record field name.- | PatternSynName -- ^ Name of a pattern synonym.- | GeneralizeName -- ^ Name to be generalized- | DisallowedGeneralizeName -- ^ Generalizable variable from a let open- | MacroName -- ^ Name of a macro- | QuotableName -- ^ A name that can only be quoted.- -- Previous category @DefName@:- -- (Refined in a flat manner as Enum and Bounded are not hereditary.)- | DataName -- ^ Name of a @data@.- | RecName -- ^ Name of a @record@.- | FunName -- ^ Name of a defined function.- | AxiomName -- ^ Name of a @postulate@.- | 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, Enum, Bounded, Generic)+-- Agda.Syntax.Abstract.Name.KindOfName -- | All kinds of regular definitions. defNameKinds :: [KindOfName]@@ -462,70 +581,7 @@ , kindedThing :: a } deriving (Show, Eq, Ord, Functor, Foldable, Traversable) --- | Where does a name come from?------ This information is solely for reporting to the user,--- see 'Agda.Interaction.InteractionTop.whyInScope'.-data WhyInScope- = Defined- -- ^ Defined in this module.- | Opened C.QName WhyInScope- -- ^ Imported from another module.- | Applied C.QName WhyInScope- -- ^ Imported by a module application.- deriving (Show, Generic) --- | A decoration of 'Agda.Syntax.Abstract.Name.QName'.-data AbstractName = AbsName- { anameName :: A.QName- -- ^ The resolved qualified name.- , anameKind :: KindOfName- -- ^ The kind (definition, constructor, record field etc.).- , anameLineage :: WhyInScope- -- ^ Explanation where this name came from.- , anameMetadata :: NameMetadata- -- ^ Additional information needed during scope checking. Currently used- -- for generalized data/record params.- }- deriving (Show, Generic)--data NameMetadata = NoMetadata- | GeneralizedVarsMetadata (Map A.QName A.Name)- deriving (Show, Generic)---- | A decoration of abstract syntax module names.-data AbstractModule = AbsModule- { amodName :: A.ModuleName- -- ^ The resolved module name.- , amodLineage :: WhyInScope- -- ^ Explanation where this name came from.- }- deriving (Show, Generic)--instance Eq AbstractName where- (==) = (==) `on` anameName--instance Ord AbstractName where- compare = compare `on` anameName--instance LensFixity AbstractName where- lensFixity = lensAnameName . lensFixity---- | Van Laarhoven lens on 'anameName'.-lensAnameName :: Lens' AbstractName A.QName-lensAnameName f am = f (anameName am) <&> \ m -> am { anameName = m }--instance Eq AbstractModule where- (==) = (==) `on` amodName--instance Ord AbstractModule where- compare = compare `on` amodName---- | Van Laarhoven lens on 'amodName'.-lensAmodName :: Lens' AbstractModule A.ModuleName-lensAmodName f am = f (amodName am) <&> \ m -> am { amodName = m }-- data ResolvedName = -- | Local variable bound by λ, Π, module telescope, pattern, @let@. VarName@@ -560,10 +616,6 @@ PatternSynResName x -> "pattern" <+> pretty x UnknownName -> "<unknown name>" -instance Pretty A.Suffix where- 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.@@ -603,6 +655,14 @@ [AbstractModule] -- ^ The modules that @x@ could denote. +whyInScopeDataFromAmbiguousQName :: C.QName -> AmbiguousQName -> Maybe WhyInScopeData+whyInScopeDataFromAmbiguousQName q x = case ambAbstractNames x of+ [] -> Nothing+ xs -> Just $ WhyInScopeData q empty Nothing xs empty++whyInScopeDataFromAbstractName :: C.QName -> AbstractName -> WhyInScopeData+whyInScopeDataFromAbstractName q x = WhyInScopeData q empty Nothing [x] empty+ whyInScopeDataFromAmbiguousNameReason :: C.QName -> AmbiguousNameReason -> WhyInScopeData whyInScopeDataFromAmbiguousNameReason q = \case AmbiguousLocalVar x ys -> WhyInScopeData q empty (Just x) (toList ys) empty@@ -622,7 +682,7 @@ -- | The empty name space. emptyNameSpace :: NameSpace-emptyNameSpace = NameSpace Map.empty Map.empty Set.empty+emptyNameSpace = NameSpace Map.empty Map.empty Map.empty Set.empty -- | Map functions over the names and modules in a name space.@@ -637,14 +697,16 @@ } -- | Zip together two name spaces.-zipNameSpace :: (NamesInScope -> NamesInScope -> NamesInScope ) ->- (ModulesInScope -> ModulesInScope -> ModulesInScope) ->- (InScopeSet -> InScopeSet -> InScopeSet ) ->+zipNameSpace :: (NamesInScope -> NamesInScope -> NamesInScope ) ->+ (NamePartsInScope -> NamePartsInScope -> NamePartsInScope) ->+ (ModulesInScope -> ModulesInScope -> ModulesInScope ) ->+ (InScopeSet -> InScopeSet -> InScopeSet ) -> NameSpace -> NameSpace -> NameSpace-zipNameSpace fd fm fs ns1 ns2 =- ns1 { nsNames = nsNames ns1 `fd` nsNames ns2- , nsModules = nsModules ns1 `fm` nsModules ns2- , nsInScope = nsInScope ns1 `fs` nsInScope ns2+zipNameSpace fd fnps fm fs ns1 ns2 =+ ns1 { nsNames = nsNames ns1 `fd` nsNames ns2+ , nsNameParts = nsNameParts ns1 `fnps` nsNameParts ns2+ , nsModules = nsModules ns1 `fm` nsModules ns2+ , nsInScope = nsInScope ns1 `fs` nsInScope ns2 } -- | Map monadic function over a namespace.@@ -719,12 +781,11 @@ , _scopeVarsToBind = [] , _scopeLocals = [] , _scopePrecedence = []- , _scopeInverseName = Map.empty- , _scopeInverseModule = Map.empty+ , _scopeInverseName = HMap.empty+ , _scopeInverseModule = HMap.empty , _scopeInScope = Set.empty , _scopeFixities = Map.empty , _scopePolarities = Map.empty- , _scopeRecords = Map.empty } -- | Map functions over the names and modules in a scope.@@ -772,16 +833,15 @@ -- | Zip together two scopes. The resulting scope has the same name as the -- first scope.-zipScope :: (NameSpaceId -> NamesInScope -> NamesInScope -> NamesInScope ) ->- (NameSpaceId -> ModulesInScope -> ModulesInScope -> ModulesInScope) ->- (NameSpaceId -> InScopeSet -> InScopeSet -> InScopeSet ) ->+zipScope :: (NameSpaceId -> NamesInScope -> NamesInScope -> NamesInScope ) ->+ (NameSpaceId -> NamePartsInScope -> NamePartsInScope -> NamePartsInScope) ->+ (NameSpaceId -> ModulesInScope -> ModulesInScope -> ModulesInScope ) ->+ (NameSpaceId -> InScopeSet -> InScopeSet -> InScopeSet ) -> Scope -> Scope -> Scope-zipScope fd fm fs s1 s2 =+zipScope fd fnps fm fs s1 s2 = s1 { scopeNameSpaces = [ (nsid, zipNS nsid ns1 ns2)- | ((nsid, ns1), (nsid', ns2)) <-- fromMaybe __IMPOSSIBLE__ $- zipWith' (,) (scopeNameSpaces s1) (scopeNameSpaces s2)+ | ((nsid, ns1), (nsid', ns2)) <- zipWith' (,) (scopeNameSpaces s1) (scopeNameSpaces s2) , assert (nsid == nsid') ] , scopeImports = (Map.union `on` scopeImports) s1 s2@@ -789,23 +849,24 @@ where assert True = True assert False = __IMPOSSIBLE__- zipNS acc = zipNameSpace (fd acc) (fm acc) (fs acc)+ zipNS acc = zipNameSpace (fd acc) (fnps acc) (fm acc) (fs acc) -- | Same as 'zipScope' but applies the same function to both the public and -- private name spaces.-zipScope_ :: (NamesInScope -> NamesInScope -> NamesInScope ) ->- (ModulesInScope -> ModulesInScope -> ModulesInScope) ->- (InScopeSet -> InScopeSet -> InScopeSet ) ->+zipScope_ :: (NamesInScope -> NamesInScope -> NamesInScope ) ->+ (NamePartsInScope -> NamePartsInScope -> NamePartsInScope) ->+ (ModulesInScope -> ModulesInScope -> ModulesInScope ) ->+ (InScopeSet -> InScopeSet -> InScopeSet ) -> Scope -> Scope -> Scope-zipScope_ fd fm fs = zipScope (const fd) (const fm) (const fs)+zipScope_ fd fnps fm fs = zipScope (const fd) (const fnps) (const fm) (const fs) -- | Recompute the inScope sets of a scope. recomputeInScopeSets :: Scope -> Scope-recomputeInScopeSets = updateScopeNameSpaces (map $ second recomputeInScope)+recomputeInScopeSets = updateScopeNameSpaces (map' (second recomputeInScope)) where- recomputeInScope ns = ns { nsInScope = allANames $ nsNames ns }+ recomputeInScope ns = ns { nsInScope = billToPure [Scoping, InverseInScopeRecompute] (allANames $ nsNames ns) } allANames :: NamesInScope -> InScopeSet- allANames = Set.fromList . map anameName . List1.concat . Map.elems+ allANames = foldl' (\acc -> foldl' (\acc n -> Set.insert (anameName n) acc) acc) mempty -- | Filter a scope keeping only concrete names matching the predicates. -- The first predicate is applied to the names and the second to the modules.@@ -814,14 +875,26 @@ -- We don't have enough information in the in scope set to do an -- incremental update here, so just recompute it from the name map. +-- | Filter a scope keeping only concrete names matching the predicates.+-- The first predicate is applied to the names and the second to the modules.+mapScopeMaybe :: (C.Name -> Maybe C.Name) -> (C.Name -> Maybe C.Name) -> Scope -> Scope+mapScopeMaybe pd pm = recomputeInScopeSets . mapScope_ (Map.mapKeysMaybe pd) (Map.mapKeysMaybe pm) id+ -- We don't have enough information in the in scope set to do an+ -- incremental update here, so just recompute it from the name map.++-- allNamePartsInScope :: Scope -> NamePartsInScope+-- allNamePartsInScope =+-- Map.unionsWith (<>) . map (nsNameParts . snd) . scopeNameSpaces+ -- | Return all names in a scope. allNamesInScope :: InScope a => Scope -> ThingsInScope a-allNamesInScope = mergeNamesMany . map (inNameSpace . snd) . scopeNameSpaces+allNamesInScope = mergeNamesMany . map' (inNameSpace . snd) . scopeNameSpaces allNamesInScope' :: InScope a => Scope -> ThingsInScope (a, Access) allNamesInScope' s =- mergeNamesMany [ fmap (, nameSpaceAccess nsId) <$> inNameSpace ns- | (nsId, ns) <- scopeNameSpaces s ]+ mergeNamesMany $+ map' (\(nsId, ns) -> let !acc = nameSpaceAccess nsId in fmap (,acc) <$> inNameSpace ns)+ (scopeNameSpaces s) -- | Look up a single name in the current scope. --@@ -838,27 +911,35 @@ exportedNamesInScope :: InScope a => Scope -> ThingsInScope a exportedNamesInScope = namesInScope [PublicNS, ImportedNS] +-- namePartsInScope :: [NameSpaceId] -> Scope -> NamePartsInScope+-- namePartsInScope ids s =+-- Map.unionsWith (<>)+-- [nsNameParts ns | (nsid, ns) <- scopeNameSpaces s, elem nsid ids]+ namesInScope :: InScope a => [NameSpaceId] -> Scope -> ThingsInScope a namesInScope ids s =- mergeNamesMany [ inNameSpace (scopeNameSpace nsid s) | nsid <- ids ]+ mergeNamesMany $ map' (\nsid -> inNameSpace (scopeNameSpace nsid s)) ids allThingsInScope :: Scope -> NameSpace allThingsInScope s =- NameSpace { nsNames = allNamesInScope s- , nsModules = allNamesInScope s- , nsInScope = Set.unions $ map (nsInScope . snd) $ scopeNameSpaces s+ NameSpace { nsNames = allNamesInScope s+ , nsNameParts = mempty+ , nsModules = allNamesInScope s+ , nsInScope = Set.unions $ map' (nsInScope . snd) $ scopeNameSpaces s } thingsInScope :: [NameSpaceId] -> Scope -> NameSpace thingsInScope fs s =- NameSpace { nsNames = namesInScope fs s- , nsModules = namesInScope fs s- , nsInScope = Set.unions [ nsInScope $ scopeNameSpace nsid s | nsid <- fs ]+ NameSpace { nsNames = namesInScope fs s+ , nsNameParts = mempty+ , nsModules = namesInScope fs s+ , nsInScope = Set.unions [ nsInScope $ scopeNameSpace nsid s | nsid <- fs ] } -- | Merge two scopes. The result has the name of the first scope. mergeScope :: Scope -> Scope -> Scope-mergeScope = zipScope_ mergeNames mergeNames Set.union+mergeScope = zipScope_ mergeNames go mergeNames Set.union where+ go m m' = (Map.unionWith (<>) m m') -- | Merge a non-empty list of scopes. The result has the name of the first -- scope in the list.@@ -871,7 +952,7 @@ -- | Move all names in a scope to the given name space (except never move from -- Imported to Public). setScopeAccess :: NameSpaceId -> Scope -> Scope-setScopeAccess a s = (`updateScopeNameSpaces` s) $ AssocList.mapWithKey $ const . ns+setScopeAccess a s = updateScopeNameSpaces (AssocList.mapWithKey (const . ns)) s where zero = emptyNameSpace one = allThingsInScope s@@ -892,13 +973,60 @@ modifyNameSpace :: NameSpaceId -> (NameSpace -> NameSpace) -> Scope -> Scope modifyNameSpace nsid f = updateScopeNameSpaces $ AssocList.updateAt nsid f +addNameToNameParts :: C.Name -> AbstractName -> NamePartsInScope -> NamePartsInScope+addNameToNameParts x y nps =++ -- operator parts in the the name+ let nameOpParts = case nameParts x of+ parts -> case any (== Hole) parts of+ False -> [] -- name has no holes, so it's not an operator+ True -> [s | Id s <- List1.toList parts] in++ -- name parts in the associated notation, if there's any+ let notation = theNotation (nameFixity (qnameName (anameName y))) in+ let notationParts = [rangedThing s | IdPart s <- notation] in++ let allParts = if null notationParts then nameOpParts+ else nameOpParts ++! notationParts in++ foldl'+ (\acc part -> Map.insertWith+ (\_ old -> Map.insertWith (flip List1.union) x (List1.singleton y) old)+ part+ (Map.singleton x (List1.singleton y))+ acc)+ nps+ allParts++-- | Add all associated name parts of a name (operator parts, notation parts) to the scope.+addNamePartsToScope :: NameSpaceId -> C.Name -> AbstractName -> Scope -> Scope+addNamePartsToScope nsid x y s =+ let updNameSpace ns = ns {nsNameParts = addNameToNameParts x y (nsNameParts ns)} in+ let nameSpaces = AssocList.updateAt nsid updNameSpace (scopeNameSpaces s) in+ s {scopeNameSpaces = nameSpaces}++-- | Recompute name parts in the namespaces.+recomputeNameParts :: Scope -> Scope+recomputeNameParts s = s {scopeNameSpaces = map (fmap goNS) (scopeNameSpaces s)} where++ goNS :: NameSpace -> NameSpace+ goNS ns = ns {nsNameParts = nameParts} where++ go :: NamePartsInScope -> C.Name -> List1 AbstractName -> NamePartsInScope+ go acc x anames = foldl' (\acc y -> addNameToNameParts x y acc) acc anames++ nameParts :: NamePartsInScope+ nameParts = Map.foldlWithKey' go mempty (nsNames ns)++ -- | Add a name to a scope. addNameToScope :: NameSpaceId -> C.Name -> AbstractName -> Scope -> Scope addNameToScope nsid x y =+ addNamePartsToScope nsid x y . mapScopeNS nsid (Map.insertWith (flip List1.union) x $ singleton y) -- bind name x ↦ y- id -- no change to modules- (Set.insert $ anameName y) -- y is in scope now+ id -- no change to modules+ (Set.insert $ anameName y) -- y is in scope now -- | Remove a name from a scope. Caution: does not update the nsInScope set. -- This is only used by rebindName and in that case we add the name right@@ -990,16 +1118,16 @@ -- Restrict scope by directive. useOrHide :: UsingOrHiding -> Scope -> Scope- useOrHide (UsingOnly xs) = filterNames Set.member xs+ useOrHide (UsingOnly xs) = filterNames (flip Set.lookupKey) xs -- Filter scope, keeping only xs.- useOrHide (HidingOnly xs) = filterNames Set.notMember $ map renFrom impRenaming ++ xs+ useOrHide (HidingOnly xs) = filterNames (predicateToMaybe . flip Set.notMember) $ map' renFrom impRenaming ++! xs -- Filter out xs and the to be renamed names from scope. - -- Filter scope by (`rel` xs).+ -- Filter scope by (rel xs). -- O(n * log (length xs)).- filterNames :: (C.Name -> Set C.Name -> Bool) -> [C.ImportedName] ->+ filterNames :: (Set C.Name -> C.Name -> Maybe C.Name) -> [C.ImportedName] -> Scope -> Scope- filterNames rel xs = filterScope (`rel` Set.fromList ds) (`rel` Set.fromList ms)+ filterNames rel xs = mapScopeMaybe (rel $ Set.fromList ds) (rel $ Set.fromList ms) where (ds, ms) = partitionEithers $ for xs $ \case ImportedName x -> Left x@@ -1060,11 +1188,13 @@ -- | Remove private things from the given module from a scope. restrictLocalPrivate :: ModuleName -> Scope -> Scope-restrictLocalPrivate m =+restrictLocalPrivate m scope =+ recomputeNameParts $ mapScopeNS PrivateNS (Map.mapMaybe rName) (Map.mapMaybe rMod) (Set.filter (not . (`isInModule` m)))+ scope where rName as = List1.nonEmpty $ List1.filter (not . (`isInModule` m) . anameName) as rMod as = List1.nonEmpty $ List1.filter (not . (`isLtChildModuleOf` m) . amodName) as@@ -1120,29 +1250,6 @@ look m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules s0 = look $ scope ^. scopeCurrent -everythingInScopeQualified :: ScopeInfo -> NameSpace-everythingInScopeQualified scope =- allThingsInScope $ mergeScopes $- chase Set.empty scopes- where- s0 = look $ scope ^. scopeCurrent- scopes = s0 : map look (scopeParents s0)- look m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules- lookP = restrictPrivate . look-- -- We start with the current module and all its parents and look through- -- all their imports and submodules.- chase seen [] = []- chase seen (s : ss)- | Set.member name seen = chase seen ss- | otherwise = s : chase (Set.insert name seen) (imports ++ submods ++ ss)- where- -- #4166: only include things that are actually in scope here- inscope x _ = isInScope x == InScope- name = scopeName s- imports = map lookP $ Map.elems $ scopeImports s- submods = map (lookP . amodName) $ List1.concat $ Map.elems $ Map.filterWithKey inscope $ allNamesInScope s- -- | Get all concrete names in scope. Includes bound variables. concreteNamesInScope :: ScopeInfo -> Set C.QName concreteNamesInScope scope =@@ -1178,18 +1285,20 @@ scopeLookup :: InScope a => C.QName -> ScopeInfo -> [a] scopeLookup q scope = map fst $ scopeLookup' q scope +{-# SPECIALIZE scopeLookup' :: C.QName -> ScopeInfo -> [(AbstractName, Access)] #-}+{-# SPECIALIZE scopeLookup' :: C.QName -> ScopeInfo -> [(AbstractModule, Access)] #-} scopeLookup' :: forall a. InScope a => C.QName -> ScopeInfo -> [(a, Access)]-scopeLookup' q scope = nubOn fst $ inAllScopes ++ topImports ++ imports+scopeLookup' q scope = nubOn fst $ inAllScopes ++! topImports ++! imports where -- 1. Finding a name in the current scope and its parents. inAllScopes :: [(a, Access)]- inAllScopes = concatMap (findName q) allScopes+ inAllScopes = concatMap' (findName q) allScopes -- 2. Finding a name in the top imports. topImports :: [(a, Access)] topImports = case (inScopeTag :: InScopeTag a) of NameTag -> []- ModuleTag -> first (`AbsModule` Defined) <$> imported q+ ModuleTag -> map' (first (`AbsModule` Defined)) (imported q) -- 3. Finding a name in the imports belonging to an initial part of the qualifier. imports :: [(a, Access)]@@ -1199,20 +1308,16 @@ splitName :: C.QName -> [(C.QName, C.QName)] splitName (C.QName x) = [] splitName (C.Qual x q) =- (C.QName x, q) : [ (C.Qual x m, r) | (m, r) <- splitName q ]+ ((C.QName x, q) :) $! map' (\(m, r) -> (C.Qual x m, r)) (splitName q) (m, x) <- splitName q- m <- fst <$> imported m+ (m, _) <- imported m findName x $ restrictPrivate $ moduleScope m -------------------------------------------------------------------------------- - moduleScope :: A.ModuleName -> Scope- moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules- allScopes :: [Scope]- allScopes = current : map moduleScope (scopeParents current) where- current = moduleScope $ scope ^. scopeCurrent+ allScopes = scopeAndParents scope imported :: C.QName -> [(A.ModuleName, Access)] imported q = do@@ -1220,36 +1325,59 @@ m <- maybeToList $ Map.lookup q $ scopeImports s return (m, PublicAccess) - -- 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 -> findNameInScope x s- C.Qual x q -> do- let -- Get the modules named @x@ in scope @s@.- mods :: [A.ModuleName]- 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 <$> 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- -- if we just consider the modules:- m <- mods- -- The feature is on if we consider also the data and record types:- -- trace ("mods ++ defs = " ++ show (mods ++ defs)) $ do- -- m <- nub $ mods ++ defs -- record types will appear both as a mod and a def- -- Get the scope of module m, if any, and remove its private definitions.- let ss = Map.lookup m $ scope ^. scopeModules- ss' = restrictPrivate <$> ss- -- trace ("ss = " ++ show ss ) $ do- -- trace ("ss' = " ++ show ss') $ do- s' <- maybeToList ss'- findName q s'+ findName = findQNameInScope scope + moduleScope :: A.ModuleName -> Scope+ moduleScope = scopeOfModule scope +-- | The scope of the given module.+scopeOfModule :: ScopeInfo -> A.ModuleName -> Scope+scopeOfModule scope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules++-- | The current scope and the scopes of its parents.+scopeAndParents :: ScopeInfo -> [Scope]+scopeAndParents scope = (current :) $! map' (scopeOfModule scope) (scopeParents current)+ where+ current = scopeOfModule scope $ scope ^. scopeCurrent++{-# SPECIALIZE findQNameInScope :: ScopeInfo -> C.QName -> Scope -> [(AbstractName, Access)] #-}+{-# SPECIALIZE findQNameInScope :: ScopeInfo -> C.QName -> Scope -> [(AbstractModule, Access)] #-}+-- | Find a concrete, possibly qualified name in scope @s@.+-- The qualifiers are resolved to modules whose public scopes are searched.+findQNameInScope :: forall a. InScope a => ScopeInfo -> C.QName -> Scope -> [(a, Access)]+findQNameInScope scope q0 s = case q0 of+ C.QName x -> findNameInScope x s+ C.Qual x q -> do+ (_, s') <- qualifierScopes scope x s+ findQNameInScope scope q s'++-- | Resolve a qualifier @x@ in scope @s@ to the modules named @x@+-- and their public scopes.+qualifierScopes :: ScopeInfo -> C.Name -> Scope -> [(AbstractModule, Scope)]+qualifierScopes scope x s = do+ -- Andreas, 2013-05-01: Issue 836 complains about the feature+ -- that constructors can also be qualified by their datatype+ -- and projections by their record type. This feature is off+ -- if we just consider the modules (and not also the definitions named @x@).+ (m, _) <- findNameInScope x s+ -- Get the scope of module m, if any, and remove its private definitions.+ s' <- maybeToList $ Map.lookup (amodName m) $ scope ^. scopeModules+ return (m, restrictPrivate s')++-- | For a qualified name @x.q@ resolving to one of the given things @ys@,+-- find the modules @x@ in the current scope (or its parents)+-- through which @q@ resolves to some of @ys@.+--+-- Used to mark the qualifier @x@ as used for the unused-imports analysis.+scopeLookupQualifier :: InScope a => C.QName -> [a] -> ScopeInfo -> [AbstractModule]+scopeLookupQualifier q ys scope = case q of+ C.QName _ -> []+ C.Qual x q -> List.nub $ do+ (m, s) <- qualifierScopes scope x =<< scopeAndParents scope+ let zs = map fst $ findQNameInScope scope q s+ if any (`elem` ys) zs then [m] else []+ -- * Inverse look-up data AllowAmbiguousNames@@ -1259,11 +1387,11 @@ | AmbiguousConProjs -- ^ Ambiguous constructors, projections, or pattern synonyms. | AmbiguousNothing- deriving (Eq)+ deriving (Eq, Show) isNameInScope :: A.QName -> ScopeInfo -> Bool isNameInScope q scope =- billToPure [ Scoping, InverseScopeLookup ] $+ billToPure [ Scoping, InverseInScope ] $ Set.member q (scope ^. scopeInScope) isNameInScopeUnqualified :: A.QName -> ScopeInfo -> Bool@@ -1284,41 +1412,83 @@ -- | A version of 'inverseScopeLookupName' that also delivers the 'KindOfName'. -- Used in highlighting. inverseScopeLookupName'' :: AllowAmbiguousNames -> A.QName -> ScopeInfo -> Maybe NameMapEntry-inverseScopeLookupName'' amb q scope = billToPure [ Scoping , InverseScopeLookup ] $ do- NameMapEntry k xs <- Map.lookup q (scope ^. scopeInverseName)- NameMapEntry k <$> do List1.nonEmpty $ best $ List1.filter unambiguousName xs- where- best :: [C.QName] -> [C.QName]- best = List.sortOn $ length . C.qnameParts+inverseScopeLookupName'' amb q scope = billToPure [ Scoping , InverseNameLookup ] $ do - unique :: forall a . [a] -> Bool- unique [] = __IMPOSSIBLE__- unique [_] = True- unique (_:_:_) = False+ NameMapEntry k xs <- HMap.lookup (A.nameId q) (scope ^. scopeInverseName) - unambiguousName :: C.QName -> Bool- unambiguousName q = or- [ amb == AmbiguousAnything- , unique xs- , amb == AmbiguousConProjs && or- [ all (isJust . isConName) (k:ks)- , k `elem` [ FldName, PatternSynName ] && all (k ==) ks- ]- ]- where- xs = scopeLookup q scope- k:ks = map anameKind xs+ -- try to get an unqualified concrete name, that's probably given+ -- by the user.+ let getUserGivenName :: C.QName -> Maybe NameParts+ getUserGivenName = \case+ C.QName x -> case x of+ C.NoName{} -> Nothing+ C.Name NoRange _ _ -> Nothing+ C.Name _ _ parts -> Just parts+ C.Qual _ x -> getUserGivenName x + -- unqualified original concrete name+ let !userGiven = getUserGivenName (C.QName $ nameConcrete $ qnameName q)++ !xs <- List1.nonEmpty $ List.sortOn snd do+ -- List comprehension written in monadic form+ q :: C.QName <- nubOn id $ List1.toList xs+ let y:ys = scopeLookup' q scope+ let !k = anameKind $ fst y++ let unambiguous :: Bool+ unambiguous =+ (amb == AmbiguousAnything)+ || (null ys)+ || ( (amb == AmbiguousConProjs)+ && ( all (isJust . isConName . anameKind . fst) (y:ys)+ || ( (k == FldName || k == PatternSynName)+ && all ((k ==) . anameKind . fst) ys)))++ guard unambiguous++ -- Computing priority for name printing.+ --+ -- The rules are currently, in lexicographic order:+ -- 1. Less qualified names are preferred+ -- 2. Names whose unqualified name part is the same as what the user originally wrote, are+ -- preferred.+ -- 3. Names introduced later are preferred, by source position.+ -- If a single module opening introduces multiple possible printable names,+ -- we recursively prefer the names that were introduced later within the module.+ --+ -- Caveat: rule 3 only fires within the current source file. Currently we can't use it across+ -- files because we don't store ranges in interfaces. Currently we happen to pick the+ -- alphabetically greater names in those cases.+ let lineageRanges = go (anameLineage $ fst y) where+ go Defined = let !r = Down $! getRange q in [r]+ go (Opened x why) = let !r = getRange x; !rs = go why in Down r:rs+ go (Applied x why) = let !r = getRange x; !rs = go why in Down r:rs++ let sortingWeight = let !qualifiers = length (C.qnameParts q)+ !preferUserGiven = case (userGiven, getUserGivenName q) of+ (Just x, Just x') | x == x' -> Down True+ _ -> Down False+ in (+ qualifiers+ , preferUserGiven+ , lineageRanges+ )++ pure (q, sortingWeight)++ !xs <- pure (List1.map' fst xs)+ pure $ NameMapEntry k xs+ -- | Find the concrete names that map (uniquely) to a given abstract module name. -- Sort by length, shortest first. inverseScopeLookupModule :: A.ModuleName -> ScopeInfo -> [C.QName] inverseScopeLookupModule = inverseScopeLookupModule' AmbiguousNothing inverseScopeLookupModule' :: AllowAmbiguousNames -> A.ModuleName -> ScopeInfo -> [C.QName]-inverseScopeLookupModule' amb m scope = billToPure [ Scoping , InverseScopeLookup ] $+inverseScopeLookupModule' amb m scope = billToPure [ Scoping , InverseModuleLookup ] $ best $ filter unambiguousModule $ findModule m where- findModule m = fromMaybe [] $ Map.lookup m (scope ^. scopeInverseModule)+ findModule m = fromMaybe [] $ HMap.lookup m (scope ^. scopeInverseModule) best :: [C.QName] -> [C.QName] best = List.sortOn $ length . C.qnameParts@@ -1330,71 +1500,122 @@ unambiguousModule q = amb == AmbiguousAnything || unique (scopeLookup q scope :: [AbstractModule]) -recomputeInverseScopeMaps :: ScopeInfo -> ScopeInfo-recomputeInverseScopeMaps scope = billToPure [ Scoping , InverseScopeLookup ] $- scope { _scopeInverseName = nameMap- , _scopeInverseModule = Map.fromList [ (x, findModule x) | x <- Map.keys moduleMap ++ Map.keys importMap ]- , _scopeInScope = nsInScope $ everythingInScopeQualified scope- }- where- this = scope ^. scopeCurrent- current = this : scopeParents (moduleScope this)- scopes = [ (m, restrict m s) | (m, s) <- Map.toList (scope ^. scopeModules) ]+recomputeInScopeSet :: ScopeInfo -> Set A.QName+recomputeInScopeSet scope = fst $ St2.execState goCurrent (Set.empty, Set.empty) where+ !mods = scope ^. scopeModules+ !s0 = scope ^. scopeCurrent+ look m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m mods+ goCurrent = go True s0 *> forM_ (scopeParents (look s0)) (go True) - moduleScope :: A.ModuleName -> Scope- moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules+ go :: Bool -> ModuleName -> St2.State (Set A.QName) (Set ModuleName) ()+ go !isCurrent !m = do+ seen <- St2.get2+ if Set.member m seen then+ pure ()+ else do+ St2.modify2 (Set.insert m)+ let !s = look m+ -- names and submodules+ forM_ (scopeNameSpaces s) \(nsid, NameSpace _ _ mods inscope) -> do+ when (isCurrent || nsid /= PrivateNS) do+ St2.modify1 (<> inscope)+ Map.forWithKey_ mods \k ms -> do+ when (isInScope k == InScope) do+ forM_ ms \m -> do+ go False (amodName m)+ -- imports+ when isCurrent do+ Map.forWithKey_ (scopeImports s) \_ m -> do+ go False m - restrict m s | m `elem` current = s- | otherwise = restrictPrivate s+recomputeInverseNamesAndModules :: ScopeInfo -> (NameMap, ModuleMap)+recomputeInverseNamesAndModules scope = St2.execState goCurrent (mempty, mempty) where+ look m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m mods+ !mods = scope ^. scopeModules+ !s0 = look (scope ^. scopeCurrent) - internalName :: C.QName -> Bool- internalName C.QName{} = False- internalName (C.Qual m n) = intern m || internalName n- where- -- Recognize fresh names created Parser.y- intern (C.Name _ _ (C.Id ('.' : '#' : _) :| [])) = True- intern _ = False+ -- we traverse outer scopes first, because this causes inner names+ -- to appear first in name lists, and we prefer printing inner names+ goCurrent = goParents (scopeParents s0) *> go [] s0 - findName :: Ord a => Map a [(A.ModuleName, C.Name)] -> a -> [C.QName]- findName table q = do- (m, x) <- fromMaybe [] $ Map.lookup q table- if m `elem` current- then return (C.QName x)- else do- y <- findModule m- let z = C.qualify y x- guard $ not $ internalName z- return z+ updQuals (C.QName x) quals = x:quals+ updQuals (C.Qual x n) quals = updQuals n (x:quals)+ applyQuals !x quals = foldl' (flip C.Qual) x quals - findModule :: A.ModuleName -> [C.QName]- findModule q = findName moduleMap q ++- fromMaybe [] (Map.lookup q importMap)+ internalName :: C.QName -> Bool+ internalName C.QName{} = False+ internalName (C.Qual m n) = intern m || internalName n+ where+ -- Recognize fresh names created by Parser.y+ intern (C.Name _ _ (C.Id ('.' : '#' : _) :| [])) = True+ intern _ = False - importMap = Map.fromListWith (++) $ do- (m, s) <- scopes- (x, y) <- Map.toList $ scopeImports s- return (y, singleton x)+ -- The pseudo-name @constructor@ bound in a record module (see+ -- 'Agda.Syntax.Scope.Monad.bindRecordConstructorPseudoName') is a keyword,+ -- so it cannot be parsed unqualified. Thus, it must not be offered as an+ -- unqualified rendering of the record constructor (which could happen after+ -- @open R@). Qualified renderings like @R.constructor@ are fine.+ unqualifiedKeyword :: C.QName -> Bool+ unqualifiedKeyword (C.QName (C.Name _ _ (C.Id "constructor" :| []))) = True+ unqualifiedKeyword _ = False - moduleMap = Map.fromListWith (++) $ do- (m, s) <- scopes- (x, ms) <- Map.toList (allNamesInScope s)- q <- amodName <$> List1.toList ms- return (q, singleton (m, x))+ updModules qualx m =+ St2.modify2 $ HMap.insertWith (\_ acc -> qualx:acc) m [qualx] - nameMap :: NameMap- nameMap = Map.fromListWith (<>) $ do- (m, s) <- scopes- (x, ms) <- Map.toList (allNamesInScope s)- (q, k) <- (anameName &&& anameKind) <$> List1.toList ms- let ret z = return (q, NameMapEntry k $ singleton z)- if m `elem` current- then ret $ C.QName x- else do- y <- findModule m- let z = C.qualify y x- guard $ not $ internalName z- ret z+ updNames qualx nid entry = do+ let upd _ (NameMapEntry k xs) = NameMapEntry k $! qualx List1.<| xs+ St2.modify1 $ HMap.insertWith upd nid entry + goParents :: [ModuleName] -> St2.State NameMap ModuleMap ()+ goParents = \case+ [] -> pure ()+ s:ss -> goParents ss *> go [] (look s)++ go :: [C.Name] -> Scope -> St2.State NameMap ModuleMap ()+ go !quals s = do+ -- names and submodules+ forM_ (scopeNameSpaces s) \(nsid, NameSpace names _ mods _) -> do+ when (null quals || nsid /= PrivateNS) do++ -- names+ Map.forWithKey_ names \x ys -> do+ let !qualx = applyQuals (C.QName x) quals+ when (not (internalName qualx || unqualifiedKeyword qualx)) do+ forM_ ys \y -> do+ let nid = A.nameId y+ let entry = NameMapEntry (anameKind y) (qualx :| [])+ updNames qualx nid entry++ -- submodules+ Map.forWithKey_ mods \x ms -> do+ when (isInScope x == InScope) do+ let !qualx = applyQuals (C.QName x) quals+ when (not (internalName qualx)) do+ forM_ ms \m -> do+ let !name = amodName m+ updModules qualx name+ go (x:quals) (look name)++ -- imports+ when (null quals) do+ Map.forWithKey_ (scopeImports s) \x m -> do+ let !qualx = applyQuals x quals+ when (not (internalName qualx)) do+ updModules qualx m+ go (updQuals x quals) (look m)+++recomputeInverseScope' :: ScopeInfo -> ScopeInfo+recomputeInverseScope' scope =+ let (names, modules) = billToPure [Scoping, InverseNameModuleRecompute]+ (recomputeInverseNamesAndModules scope)+ inScope = billToPure [Scoping, InverseInScopeRecompute] (recomputeInScopeSet scope)+ in scope {+ _scopeInverseName = names+ , _scopeInverseModule = modules+ , _scopeInScope = inScope+ }+ ------------------------------------------------------------------------ -- * Update binding site ------------------------------------------------------------------------@@ -1412,7 +1633,7 @@ instance SetBindingSite a => SetBindingSite (List1 a) instance SetBindingSite A.Name where- setBindingSite r x = x { nameBindingSite = r }+ setBindingSite r x = x { _nameBindingSite = r } instance SetBindingSite A.QName where setBindingSite r x = x { qnameName = setBindingSite r $ qnameName x }@@ -1432,12 +1653,6 @@ -- * (Debug) printing ------------------------------------------------------------------------ -instance Pretty AbstractName where- pretty = pretty . anameName--instance Pretty AbstractModule where- pretty = pretty . amodName- instance Pretty NameSpaceId where pretty = text . \case PublicNS -> "public"@@ -1448,13 +1663,34 @@ pretty = vcat . prettyNameSpace prettyNameSpace :: NameSpace -> [Doc]-prettyNameSpace (NameSpace names mods _) =- blockOfLines "names" (map pr $ Map.toList names) ++- blockOfLines "modules" (map pr $ Map.toList mods)+prettyNameSpace (NameSpace names nameParts mods _) =+ blockOfLines "names" (map pr' $ Map.toList names) +++ blockOfLines "name parts" (map pr $ Map.toList nameParts) +++ blockOfLines "modules" (map pr $ Map.toList mods) where pr :: (Pretty a, Pretty b) => (a,b) -> Doc pr (x, y) = pretty x <+> "-->" <+> pretty y+ -- pr' :: (Pretty a, IsInstanceDef b, Pretty b) => (a, List1 b) -> Doc+ pr' :: (C.Name, List1 AbstractName) -> Doc+ pr' (x, ys) = pretty x <+> "-->" <+> prettyList (map augment $ List1.toList ys)+ where+ -- Extra information for names; comment out line to remove a particular augmentation+ augment = id+ . PrettyWithInstance+ -- . PrettyWithBindingSite +newtype PrettyWithInstance a = PrettyWithInstance a+instance (IsInstanceDef a, Pretty a) => Pretty (PrettyWithInstance a) where+ pretty (PrettyWithInstance x) =+ applyWhen (isJust $ isInstanceDef x) ("instance" <+>) $ pretty x++newtype PrettyWithBindingSite a = PrettyWithBindingSite a+ deriving (IsInstanceDef)+instance (HasNameBindingSite a, Pretty a) => Pretty (PrettyWithBindingSite a) where+ pretty (PrettyWithBindingSite x) = do+ let r = nameBindingSite x+ applyUnless (null r) (<+> ("bound at" <+> pretty r)) $ pretty x+ instance Pretty Scope where pretty scope@Scope{ scopeName = name, scopeParents = parents, scopeImports = imps } = vcat $ concat@@ -1474,12 +1710,13 @@ blockOfLines hd ss = hd : map (nest 2) ss instance Pretty ScopeInfo where- pretty (ScopeInfo this mods toBind locals ctx _ _ _ _ _ _) = vcat $ concat+ pretty (ScopeInfo this mods toBind locals ctx _ _ _ fixs _) = vcat $ concat [ [ "ScopeInfo" , nest 2 $ "current =" <+> pretty this ]- , [ nest 2 $ "toBind =" <+> pretty locals | not (null toBind) ]+ , [ nest 2 $ "toBind =" <+> pretty toBind | not (null toBind) ] , [ nest 2 $ "locals =" <+> pretty locals | not (null locals) ]+ , [ nest 2 $ "fixities=" <+> pretty fixs | not (null fixs ) ] , [ nest 2 $ "context =" <+> pretty ctx , nest 2 $ "modules" ]@@ -1491,27 +1728,16 @@ ------------------------------------------------------------------------ instance KillRange ScopeInfo where- killRange m = m--instance HasRange AbstractName where- getRange = getRange . anameName--instance SetRange AbstractName where- setRange r x = x { anameName = setRange r $ anameName x }+ killRange = id -instance NFData Scope-instance NFData DataOrRecordModule-instance NFData NameSpaceId-instance NFData ScopeInfo-instance NFData KindOfName-instance NFData NameMapEntry+instance NFData AmbiguousNameReason instance NFData BindingSource+instance NFData DataOrRecordModule instance NFData LocalVar-instance NFData NameSpace+instance NFData NameMapEntry instance NFData NameOrModule-instance NFData WhyInScope-instance NFData AbstractName-instance NFData NameMetadata-instance NFData AbstractModule+instance NFData NameSpace+instance NFData NameSpaceId instance NFData ResolvedName-instance NFData AmbiguousNameReason+instance NFData Scope+instance NFData ScopeInfo
− src/full/Agda/Syntax/Scope/Flat.hs
@@ -1,141 +0,0 @@-{-# OPTIONS_GHC -Wunused-imports #-}---- | Flattened scopes.-module Agda.Syntax.Scope.Flat- ( FlatScope- , flattenScope- , getDefinedNames- , localNames- ) where--import Prelude hiding ( (||) )--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.Common (ExprKind(..))-import Agda.Syntax.Common.Pretty-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.Boolean ( (||) )-import Agda.Utils.Function ( applyWhenJust )-import Agda.Utils.Lens-import Agda.Utils.List-import Agda.Utils.List1 (List1)-import qualified Agda.Utils.List1 as List1-import Agda.Utils.Maybe--import Agda.Utils.Impossible---- | Flattened scopes.-newtype FlatScope = Flat (Map QName (List1 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 (List1 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 _ <- List1.toList 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' :: (AbstractName -> Bool) -> FlatScope -> [List1 NewNotation]-getDefinedNames' f (Flat names) =- [ mergeNotations $ fmap (namesToNotation x . A.qnameName . anameName) ds- | (x, ds) <- Map.toList names- , any f 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.--getDefinedNames :: KindsOfNames -> FlatScope -> [List1 NewNotation]-getDefinedNames kinds = getDefinedNames' (filterByKind kinds)--filterByKind :: KindsOfNames -> AbstractName -> Bool-filterByKind kinds = (`elemKindsOfNames` kinds) . anameKind---- | Compute all names (first component) and operators/notations--- (second component) in scope.------ For 'IsPattern', only constructor-like names are returned.----localNames :: ExprKind -> Maybe QName -> FlatScope -> ScopeM ([QName], [NewNotation])-localNames k top flat = do- -- Construct a filter for the names we consider.- let- f = case k of- IsExpr -> const True- IsPattern -> let- -- Andreas, 2025-02-28, issue #7722- -- Filter by kind.- -- Just return the constructor-like operators,- -- otherwise the pattern parser blows up.- fk = filterByKind (someKindsOfNames $ FldName : conLikeNameKinds)- -- Filter by name, keeping @top@ in.- ft = top <&> \ y -> (unqualify y ==) . A.nameConcrete . A.qnameName . anameName- in applyWhenJust ft (||) fk-- -- Retrieve the names of interest from the flat scope.- let defs = getDefinedNames' f 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 (List1.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
@@ -3,16 +3,14 @@ {-| The scope monad with operations. -} -module Agda.Syntax.Scope.Monad where+module Agda.Syntax.Scope.Monad (module Agda.Syntax.Scope.Monad, module Agda.Syntax.Scope.State) where import Prelude hiding (null) -import Control.Arrow ((***)) import Control.Monad.Except ( MonadError, throwError, runExceptT ) import Control.Monad.State ( StateT, runStateT, gets, modify ) import Control.Monad.Trans ( MonadTrans, lift )-import Control.Monad.Trans.Maybe ( MaybeT(MaybeT), runMaybeT )-import Control.Applicative+import Control.Monad.IO.Class import Data.Either ( partitionEithers ) import Data.Foldable (all, traverse_)@@ -21,6 +19,7 @@ import qualified Data.HashMap.Strict as HMap import qualified Data.HashSet as HSet import qualified Data.Map as Map+import Data.IORef import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set@@ -35,13 +34,15 @@ import Agda.Syntax.Fixity import Agda.Syntax.Notation import Agda.Syntax.Abstract.Name as A-import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Abstract qualified as A import Agda.Syntax.Abstract (ScopeCopyInfo(..)) import Agda.Syntax.Concrete as C import Agda.Syntax.Concrete.Fixity import Agda.Syntax.Concrete.Definitions ( DeclarationWarning(..) ,DeclarationWarning'(..) ) -- TODO: move the relevant warnings out of there import Agda.Syntax.Scope.Base as A+import Agda.Syntax.Scope.State+import Agda.Syntax.Scope.UnusedImports (lookedupModule, registerModuleOpening) import Agda.TypeChecking.Monad.Base as I import Agda.TypeChecking.Monad.Builtin@@ -69,17 +70,10 @@ import qualified Agda.Utils.Set1 as Set1 import Agda.Utils.Singleton import Agda.Utils.Suffix as C+import Agda.Utils.Tuple ((***), pattern Pair) import Agda.Utils.Impossible ------------------------------------------------------------------------------- * The scope checking monad-------------------------------------------------------------------------------- | To simplify interaction between scope checking and type checking (in--- particular when chasing imports), we use the same monad.-type ScopeM = TCM- -- Debugging printLocals :: Int -> String -> ScopeM ()@@ -101,28 +95,6 @@ isDatatypeModule m = do scopeDatatypeModule . Map.findWithDefault __IMPOSSIBLE__ m <$> useScope scopeModules -getCurrentModule :: ReadTCState m => m A.ModuleName-getCurrentModule = setRange noRange <$> useScope scopeCurrent--setCurrentModule :: MonadTCState m => A.ModuleName -> m ()-setCurrentModule m = modifyScope $ set scopeCurrent m--withCurrentModule :: (ReadTCState m, MonadTCState m) => A.ModuleName -> m a -> m a-withCurrentModule new action = do- old <- getCurrentModule- setCurrentModule new- x <- action- setCurrentModule old- return x--withCurrentModule' :: (MonadTrans t, Monad (t ScopeM)) => A.ModuleName -> t ScopeM a -> t ScopeM a-withCurrentModule' new action = do- old <- lift getCurrentModule- lift $ setCurrentModule new- x <- action- lift $ setCurrentModule old- return x- getNamedScope :: A.ModuleName -> ScopeM Scope getNamedScope m = do scope <- getScope@@ -153,6 +125,8 @@ -- If it is not new (but apparently did not clash), -- we do not erase its contents for reasons of monotonicity. modifyScopes $ Map.insertWith mergeScope m sm+ -- András, 2025-08-30: TODO: only inverse modules need to be recomputed+ recomputeInverseScope -- | Apply a function to the scope map. modifyScopes :: (Map A.ModuleName Scope -> Map A.ModuleName Scope) -> ScopeM ()@@ -162,30 +136,12 @@ modifyNamedScope :: A.ModuleName -> (Scope -> Scope) -> ScopeM () modifyNamedScope m f = modifyScopes $ Map.adjust f m -setNamedScope :: A.ModuleName -> Scope -> ScopeM ()-setNamedScope m s = modifyNamedScope m $ const s---- | Apply a monadic function to the top scope.-modifyNamedScopeM :: A.ModuleName -> (Scope -> ScopeM (a, Scope)) -> ScopeM a-modifyNamedScopeM m f = do- (a, s) <- f =<< getNamedScope m- setNamedScope m s- return a- -- | Apply a function to the current scope. modifyCurrentScope :: (Scope -> Scope) -> ScopeM () modifyCurrentScope f = getCurrentModule >>= (`modifyNamedScope` f) -modifyCurrentScopeM :: (Scope -> ScopeM (a, Scope)) -> ScopeM a-modifyCurrentScopeM f = getCurrentModule >>= (`modifyNamedScopeM` f)---- | Apply a function to the public or private name space.-modifyCurrentNameSpace :: NameSpaceId -> (NameSpace -> NameSpace) -> ScopeM ()-modifyCurrentNameSpace acc f = modifyCurrentScope $ updateScopeNameSpaces $- AssocList.updateAt acc f- setContextPrecedence :: PrecedenceStack -> ScopeM ()-setContextPrecedence = modifyScope_ . set scopePrecedence+setContextPrecedence = modifyScope . set scopePrecedence withContextPrecedence :: ReadTCState m => Precedence -> m a -> m a withContextPrecedence p =@@ -195,7 +151,7 @@ getLocalVars = useScope scopeLocals modifyLocalVars :: (LocalVars -> LocalVars) -> ScopeM ()-modifyLocalVars = modifyScope_ . updateScopeLocals+modifyLocalVars = modifyScope . updateScopeLocals setLocalVars :: LocalVars -> ScopeM () setLocalVars vars = modifyLocalVars $ const vars@@ -249,7 +205,7 @@ getVarsToBind = useScope scopeVarsToBind addVarToBind :: C.Name -> LocalVar -> ScopeM ()-addVarToBind x y = modifyScope_ $ updateVarsToBind $ AssocList.insert x y+addVarToBind x y = modifyScope $ updateVarsToBind $ AssocList.insert x y -- | After collecting some variable names in the scopeVarsToBind, -- bind them all simultaneously.@@ -258,13 +214,12 @@ vars <- getVarsToBind modifyLocalVars (vars ++) printLocals 30 "bound variables:"- modifyScope_ $ setVarsToBind []+ modifyScope $ setVarsToBind [] -annotateDecls :: ReadTCState m => m [A.Declaration] -> m A.Declaration+annotateDecls :: ReadTCState m => m [A.Declaration] -> m (Maybe A.Declaration) annotateDecls m = do- ds <- m- s <- getScope- return $ A.ScopedDecl s ds+ forMM (List1.nonEmpty <$> m) \ ds1 -> do+ getScope <&> (`A.ScopedDecl` ds1) annotateExpr :: ReadTCState m => m A.Expr -> m A.Expr annotateExpr m = do@@ -285,10 +240,10 @@ freshAbstractName fx x = do i <- fresh return $ A.Name- { nameId = i+ { _nameId = i , nameConcrete = x , nameCanonical = x- , nameBindingSite = getRange x+ , _nameBindingSite = getRange x , nameFixity = fx , nameIsRecordName = False }@@ -346,7 +301,7 @@ UnknownName -> setCurrentRange x $ typeError $ I.NotInScope q _ -> setCurrentRange x $ typeError $ ConstructorNameOfNonRecord r - Right x' -> return x'+ Right x' -> pure x' tryResolveName :: forall m. (ReadTCState m, HasBuiltins m, MonadError NameResolutionError m) => KindsOfNames@@ -362,6 +317,7 @@ let vars = AssocList.mapKeysMonotonic C.QName $ scope ^. scopeLocals throwAmb = throwError . IllegalAmbiguity+ case lookup x vars of -- Case: we have a local variable x, but is (perhaps) shadowed by some imports ys.@@ -403,21 +359,26 @@ (Just (_, ss), _) -> throwAmb $ AmbiguousDeclName $ List2.append (d :| map fst ds) (fmap fst ss) - -- Name is of the form r.constructor- Nothing | Just r <- isRecordConstructor x -> do- -- We resolve the record name r with no filter, that way we- -- can know when printing an error message whether r is not in- -- scope, or whether it's some other type of name, etc.- recd <- tryResolveName AllKindsOfNames Nothing r-- case recd of- DefinedName acc abs suf -> getRecordConstructor (anameName abs) >>= \case- Just (qn, ind) -> pure $ ConstructorName (Set1.singleton $ fromMaybe Inductive ind) $- List1.singleton $ upd abs { anameName = qn, anameKind = ConName }- Nothing -> throwError $ ConstrOfNonRecord r recd- _ -> throwError $ ConstrOfNonRecord r recd- Nothing -> case suffixedNames of+ -- Name is of the form R.constructor but did not resolve.+ -- Since the record constructor is bound as @constructor@ in the+ -- scope of the record module R (see 'bindRecordConstructorPseudoName'),+ -- this means that R is not (the module of) a record type.+ -- Produce a more informative error than "not in scope".+ Nothing | Just r <- isRecordConstructor x -> do+ -- We resolve the record name r with no filter, that way we+ -- can know when printing an error message whether r is not in+ -- scope, or whether it's some other type of name, etc.+ tryResolveName AllKindsOfNames Nothing r >>= \case+ -- If R does resolve to a record type, its constructor is+ -- simply not in scope here; report the plain not-in-scope error.+ DefinedName _ d _ | anameKind d == RecName -> return UnknownName+ -- If R is not a name but a module (e.g. a copy of a record module),+ -- report R.constructor rather than R as not in scope.+ UnknownName | not $ null (scopeLookup r scope :: [AbstractModule]) ->+ return UnknownName+ recd -> throwError $ ConstrOfNonRecord r recd+ Nothing -> return UnknownName Just (suffix , (d, a) :| []) -> return $ DefinedName a (upd d) suffix Just (suffix , (d1,_) :| (d2,_) : sds) ->@@ -455,11 +416,14 @@ return $ \x -> Just x `elem` [builtinProp, builtinSet, builtinSSet, builtinPropOmega, builtinSetOmega, builtinSSetOmega] -- | Look up a module in the scope.+-- Marks the module as used for the unused-imports analysis. resolveModule :: C.QName -> ScopeM AbstractModule resolveModule x = do ms <- scopeLookup x <$> getScope caseMaybe (nonEmpty ms) (typeError $ NoSuchModule x) $ \ case- AbsModule m why :| [] -> return $ AbsModule (m `withRangeOf` x) why+ AbsModule m why :| [] -> do+ let am = AbsModule (m `withRangeOf` x) why+ am <$ lookedupModule x am ms -> typeError $ AmbiguousModule x (fmap amodName ms) -- | Get the fixity of a not yet bound name.@@ -472,7 +436,7 @@ instance MonadFixityError ScopeM where throwMultipleFixityDecls xs = case xs of- (x, _) :| _ -> setCurrentRange (getRange x) $ typeError $ MultipleFixityDecls xs+ (_, Pair _ f2) :| _ -> setCurrentRange (theNameRange f2) $ typeError $ MultipleFixityDecls xs throwMultiplePolarityPragmas xs = case xs of x :| _ -> setCurrentRange (getRange x) $ typeError $ MultiplePolarityPragmas xs warnUnknownNamesInFixityDecl = scopeWarning . UnknownNamesInFixityDecl@@ -480,12 +444,13 @@ warnUnknownFixityInMixfixDecl = scopeWarning . UnknownFixityInMixfixDecl warnPolarityPragmasButNotPostulates = scopeWarning . PolarityPragmasButNotPostulates warnEmptyPolarityPragma = scopeWarning . EmptyPolarityPragma+ warnFixityDeclarationForNonOperator r x = scopeWarning $ FixityDeclarationForNonOperator r x -- | Collect the fixity/syntax declarations and polarity pragmas from the list -- of declarations and store them in the scope. computeFixitiesAndPolarities :: DoWarn -> [C.Declaration] -> ScopeM a -> ScopeM a computeFixitiesAndPolarities warn ds cont = do- fp <- fixitiesAndPolarities warn ds+ !fp <- fixitiesAndPolarities warn ds -- Andreas, 2019-08-16: -- Since changing fixities and polarities does not affect the name sets, -- we do not need to invoke @modifyScope@ here@@ -530,29 +495,41 @@ -- | Bind a defined name. Must not shadow anything. bindName :: Access -> KindOfName -> C.Name -> A.QName -> ScopeM ()-bindName acc kind x y = bindName' acc kind NoMetadata x y+bindName acc kind x y = bindName' acc kind noMetadata x y bindName' :: Access -> KindOfName -> NameMetadata -> C.Name -> A.QName -> ScopeM () bindName' acc kind meta x y = whenJustM (bindName'' acc kind meta x y) typeError +addNameToInverseScope :: KindOfName -> C.Name -> AbstractName -> ScopeInfo -> ScopeInfo+addNameToInverseScope kind x y s =+ let !y' = anameName y+ in s { _scopeInScope = Set.insert y' (_scopeInScope s)+ , _scopeInverseName = HMap.insertWith (<>) (A.nameId y')+ (NameMapEntry kind (C.QName x :| [])) (_scopeInverseName s)+ }+ -- | Bind a name. Returns the 'TypeError' if exists, but does not throw it. bindName'' :: Access -> KindOfName -> NameMetadata -> C.Name -> A.QName -> ScopeM (Maybe TypeError) bindName'' acc kind meta x y = do- when (isNoName x) $ modifyScopes $ Map.map $ removeNameFromScope PrivateNS x+ when (isNoName x) $ do+ modifyScopes $ Map.map $ removeNameFromScope PrivateNS x+ recomputeInverseScope r <- resolveName (C.QName x) let y' :: Either TypeError AbstractName y' = case r of -- Binding an anonymous declaration always succeeds. -- In case it's not the first one, we simply remove the one that came before _ | isNoName x -> success- DefinedName _ d _ -> clash $ anameName d- VarName z _ -> clash $ A.qualify_ z+ DefinedName _ d _ -> clash $ ClashingAbstractName d+ VarName z _ -> clash $ ClashingQName $ A.qualify_ z FieldName ds -> ambiguous (== FldName) ds ConstructorName i ds-> ambiguous (isJust . isConName) ds PatternSynResName n -> ambiguous (== PatternSynName) n UnknownName -> success let ns = if isNoName x then PrivateNS else localNameSpace acc- traverse_ (modifyCurrentScope . addNameToScope ns x) y'+ forM_ y' \y' -> do+ modifyCurrentScope $ addNameToScope ns x y'+ modifyScope $ addNameToInverseScope kind x y' pure $ either Just (const Nothing) y' where success = Right $ AbsName y kind Defined meta@@ -560,59 +537,103 @@ ambiguous f ds = if f kind && all (f . anameKind) ds- then success else clash $ anameName (List1.head ds)+ then success else clash $ ClashingAbstractName $ List1.head ds -- | Rebind a name. Use with care! -- Ulf, 2014-06-29: Currently used to rebind the name defined by an -- unquoteDecl, which is a 'QuotableName' in the body, but a 'DefinedName' -- later on.-rebindName :: Access -> KindOfName -> C.Name -> A.QName -> ScopeM ()-rebindName acc kind x y = do- if kind == ConName- then modifyCurrentScope $+rebindName :: Access -> KindOfName -> NameMetadata -> C.Name -> A.QName -> ScopeM ()+rebindName acc kind meta x y = do+ if kind == ConName then do+ modifyCurrentScope $ mapScopeNS (localNameSpace acc) (Map.update (nonEmpty . List1.filter ((ConName ==) . anameKind)) x) id id- else modifyCurrentScope $ removeNameFromScope (localNameSpace acc) x- bindName acc kind x y+ else do+ modifyCurrentScope $ removeNameFromScope (localNameSpace acc) x+ recomputeInverseScope+ bindName' acc kind meta x y +-- András, 2025-08-30: TODO: directly extend inverse scope. -- | Bind a module name. bindModule :: Access -> C.Name -> A.ModuleName -> ScopeM ()-bindModule acc x m = modifyCurrentScope $- addModuleToScope (localNameSpace acc) x (AbsModule m Defined)+bindModule acc x m = do+ modifyCurrentScope $ addModuleToScope (localNameSpace acc) x (AbsModule m Defined)+ recomputeInverseScope -- | Bind a qualified module name. Adds it to the imports field of the scope. bindQModule :: Access -> C.QName -> A.ModuleName -> ScopeM ()-bindQModule acc q m = modifyCurrentScope $ \s ->- s { scopeImports = Map.insert q m (scopeImports s) }+bindQModule acc q m = do+ modifyCurrentScope $ \s -> s { scopeImports = Map.insert q m (scopeImports s) }+ recomputeInverseScope --------------------------------------------------- -- * Operations to do with record constructor names --------------------------------------------------- --- | Record (ha) that a given record has the specified constructor name.-setRecordConstructor :: A.QName -> (A.QName, Maybe Induction) -> ScopeM ()-setRecordConstructor recr con = modifyScope_ $ over scopeRecords $ Map.insert recr con+-- | Bind the pseudo-name @constructor@ in the scope of the record module,+-- mapping it to the (possibly anonymous) constructor of the record.+--+-- This is what makes @R.constructor@ resolve: @R@ is the record /module/+-- and @constructor@ an ordinary name in it, so no special treatment is+-- needed when resolving the qualified name @R.constructor@.+--+-- Note that @constructor@ is a keyword, thus, it can never be parsed+-- as an unqualified name. In particular, @open R@ does not make the+-- record constructor accessible under the name @constructor@, and+-- @constructor@ cannot be mentioned in @using@, @hiding@ or @renaming@.+--+-- This does not put the record constructor itself into the record module+-- (which would be wrong, see issue #4189, since the record module is+-- parameterized over the record value, but the constructor is not);+-- it only adds this alias for it.+bindRecordConstructorPseudoName :: A.ModuleName -> KindOfName -> A.QName -> ScopeM ()+bindRecordConstructorPseudoName m kind y = do+ modifyNamedScope m $+ addNameToScope PublicNS recordConstructorPseudoName $+ AbsName y kind Defined noMetadata+ -- Note: we cannot use 'addNameToInverseScope' here, since that would+ -- register the unqualified (and thus unparseable) rendering @constructor@.+ recomputeInverseScope --- | Get the internal 'QName' for the name of a record constructor. If--- the name does not refer to a record type, 'Nothing' is returned.-getRecordConstructor :: ReadTCState m => A.QName -> m (Maybe (A.QName, Maybe Induction))-getRecordConstructor recr = runMaybeT $ local <|> imported where- local = do- recs <- useScope scopeRecords- MaybeT $ pure $ Map.lookup recr recs- imported = do- idefs <- useTC (stImports . sigDefinitions)- case theDef <$> HMap.lookup recr idefs of- Just def@I.Record{} -> pure (I.recCon def, I.recInduction def)- _ -> MaybeT $ pure Nothing+-- | Remove the record constructor pseudo-name from the scope of a record module.+--+-- The alias @constructor@ is only meant to be used in the qualified form+-- @R.constructor@, where @R@ is the record module. Thus, it is not brought+-- into scope by @open R@.+--+-- It is also not copied when the record module @R@ itself is applied to+-- arguments (as in @module M = R@): the record module is parameterized over+-- the record value, but the record constructor is not (issue #4189).+-- (When @R@ is only copied as a submodule of the applied module, the+-- constructor is copied correctly, since the arguments are then taken from+-- the enclosing module.)+dropRecordConstructorPseudoName :: Scope -> Scope+dropRecordConstructorPseudoName s+ | Just IsRecordModule <- scopeDatatypeModule s =+ -- We don't have enough information for an incremental update of the+ -- in-scope sets, so recompute them (cheap: record modules are small).+ recomputeInScopeSets $ mapScope_ (Map.delete recordConstructorPseudoName) id id s+ | otherwise = s +-- | The pseudo-name @constructor@ under which the constructor of a record+-- is bound in the scope of the record module.+--+-- Since @constructor@ is a keyword, this name is only reachable+-- as the tail of a qualified name, e.g., @R.constructor@.+recordConstructorPseudoName :: C.Name+recordConstructorPseudoName = C.simpleName "constructor" --- | Is this the qualified name which refers to the constructor of an--- anonymous record (like @Foo.constructor@)?+-- | Is this the qualified name which refers to the constructor of a+-- record (like @Foo.constructor@)? -- -- If so, return the part of the name referring to the record (@Foo@).+--+-- This is only used to produce a good error message when @Foo.constructor@+-- does not resolve; the resolution itself goes through the ordinary+-- scope lookup, see 'bindRecordConstructorPseudoName'. isRecordConstructor :: C.QName -> Maybe C.QName isRecordConstructor = fmap to . toplevel where toplevel, is :: C.QName -> Maybe [C.Name]@@ -635,15 +656,16 @@ -- | Clear the scope of any no names. stripNoNames :: ScopeM ()-stripNoNames = modifyScopes $ Map.map $ mapScope_ stripN stripN id- where- stripN = Map.filterWithKey $ const . not . isNoName+stripNoNames = do+ let stripN = Map.filterWithKey $ const . not . isNoName+ modifyScopes $ Map.map $ mapScope_ stripN stripN id+ recomputeInverseScope type WSM = StateT ScopeMemo ScopeM data ScopeMemo = ScopeMemo- { memoNames :: A.Ren A.QName- , memoModules :: Map ModuleName (ModuleName, Bool)+ { memoNames :: A.Ren A.QName+ , memoModules :: Map ModuleName (ModuleName, Bool) -- ^ Bool: did we copy recursively? We need to track this because we don't -- copy recursively when creating new modules for reexported functions -- (issue1985), but we might need to copy recursively later.@@ -651,10 +673,13 @@ memoToScopeInfo :: ScopeMemo -> ScopeCopyInfo memoToScopeInfo (ScopeMemo names mods) =- ScopeCopyInfo { renNames = names- , renModules = Map.map (pure . fst) mods }+ ScopeCopyInfo+ { renNames = names+ , renModules = Map.map (pure . fst) mods+ } --- | Mark a name as being a copy in the TC state.+-- | Mark a name as being a copy in the TC state, associating it with+-- the given 'A.ScopeCopyRef' for liveness information. copyName :: A.QName -> A.QName -> ScopeM () copyName from to = do from <- fromMaybe from . HMap.lookup from <$> useTC stCopiedNames@@ -668,7 +693,9 @@ -- public names in the old scope to match the new name and returns the -- renamings. copyScope :: C.QName -> A.ModuleName -> Scope -> ScopeM (Scope, ScopeCopyInfo)-copyScope oldc new0 s = (inScopeBecause (Applied oldc) *** memoToScopeInfo) <$> runStateT (copy new0 s) (ScopeMemo mempty mempty)+copyScope oldc new0 s =+ (inScopeBecause (Applied oldc) *** memoToScopeInfo) <$>+ runStateT (copy new0 $ dropRecordConstructorPseudoName s) (ScopeMemo mempty mempty) where copy :: A.ModuleName -> Scope -> WSM Scope copy new s = do@@ -676,8 +703,9 @@ lift $ reportSLn "scope.copy" 50 $ prettyShow s s0 <- lift $ getNamedScope new -- Delete private names, then copy names and modules. Recompute inScope- -- set rather than trying to copy it.- s' <- recomputeInScopeSets <$> mapScopeM_ copyD copyM return (setNameSpace PrivateNS emptyNameSpace s)+ -- set and name parts rather than trying to copy them.+ s' <- recomputeNameParts . recomputeInScopeSets <$>+ mapScopeM_ copyD copyM return (setNameSpace PrivateNS emptyNameSpace s) -- Fix name and parent. return $ s' { scopeName = scopeName s0 , scopeParents = scopeParents s0@@ -689,8 +717,21 @@ old = scopeName s copyD :: NamesInScope -> WSM NamesInScope- copyD = traverse $ mapM $ onName renName+ copyD = Map.traverseWithKey \ x -> mapM $ onName $ renNameFor x + -- Andreas, 2026-08-23:+ -- The pseudo-name @constructor@ bound in a record module+ -- (see 'bindRecordConstructorPseudoName') is only an alias for the record+ -- constructor. If the record has a named constructor, the latter lives+ -- outside the record module, and copying the alias like an ordinary name+ -- would produce a second copy of the constructor (plus a spurious copy of+ -- the module the constructor lives in). Thus, reuse the existing copy.+ renNameFor :: C.Name -> A.QName -> WSM A.QName+ renNameFor x y+ | x == recordConstructorPseudoName =+ maybe (renName y) (return . List1.head) =<< findName y+ | otherwise = renName y+ copyM :: ModulesInScope -> WSM ModulesInScope copyM = traverse $ mapM $ lensAmodName renMod @@ -705,20 +746,14 @@ addMod x y rec = modify $ \ i -> i { memoModules = Map.insert x (y, rec) (memoModules i) } -- Querying the memo structure.- findName x = gets (Map.lookup x . memoNames) -- NB:: Defined but not used+ findName :: A.QName -> WSM (Maybe (List1 A.QName))+ findName x = gets (Map.lookup x . memoNames) findMod x = gets (Map.lookup x . memoModules) refresh :: A.Name -> WSM A.Name refresh x = do i <- lift fresh- return $ x { A.nameId = i }-- copyRecordConstr :: A.QName -> A.QName -> WSM ()- copyRecordConstr from to = getRecordConstructor from >>= \case- Just (con, ind) -> do- con' <- renName con- lift $ setRecordConstructor to (con', ind)- Nothing -> pure ()+ return $ x { A._nameId = i } -- Change a binding M.x -> old.M'.y to M.x -> new.M'.y renName :: A.QName -> WSM A.QName@@ -756,7 +791,6 @@ lift $ reportSLn "scope.copy" 50 $ " Copying " ++ prettyShow x ++ " to " ++ prettyShow y addName x y lift (copyName x y)- copyRecordConstr x y return y -- Change a binding M.x -> old.M'.y to M.x -> new.M'.y@@ -801,6 +835,7 @@ copyRec x y = do s0 <- lift $ getNamedScope x s <- withCurrentModule' y $ copy y s0+ -- András, 2025-08-30: inverse scope will be computed immediately after copyScope returns lift $ modifyNamedScope y (const s) ---------------------------------------------------------------------------@@ -820,12 +855,16 @@ Renaming ImportedModule{} _ mfx _ -> getRange <$> mfx _ -> Nothing --- | Check that an import directive doesn't contain repeated names.-verifyImportDirective :: [C.ImportedName] -> C.HidingDirective -> C.RenamingDirective -> ScopeM ()-verifyImportDirective usn hdn ren =- List1.unlessNull- (mapMaybe List2.fromList1Maybe . List1.group . List.sort $ usn ++ hdn ++ map renFrom ren)- \ yss -> setCurrentRange yss $ typeError $ RepeatedNamesInImportDirective yss+-- | Warn about fixity declarations for targets that are non-operators+-- or closed operators:+checkNoFixityForClosedOperator :: [C.Renaming] -> ScopeM ()+checkNoFixityForClosedOperator ren = do+ forM_ ren \case+ Renaming (ImportedName _) (ImportedName x) mfx r+ | Just _ <- mfx, not (isPrePostOrInfixOperator x) -> warnFixityDeclarationForNonOperator r x+ | otherwise -> pure ()+ Renaming ImportedModule{} ImportedModule{} _ _ -> pure ()+ _ -> __IMPOSSIBLE__ -- | Apply an import directive and check that all the names mentioned actually -- exist.@@ -842,19 +881,30 @@ -- user has supplied fixity annotations to @renaming module@ clauses. checkNoFixityInRenamingModule ren' + -- Andreas, 2026-09-11, issue #1438+ -- Warn about fixities declared for non- or closed-operators.+ checkNoFixityForClosedOperator ren'+ -- TODO (post 2.9.0): purge fixity declarations for closed and non-operators.+ -- See also 'fixitiesAndPolarities.+ -- Andreas, 2020-06-06, issue #4707 -- Duplicates in @using@ directive are dropped with a warning. usingList <- discardDuplicatesInUsing usn' + -- Check that an import directive doesn't contain repeated names.+ -- Historic note: -- The following check was originally performed by the parser. -- The Great Ulf Himself added the check back in the dawn of time -- (5ba14b647b9bd175733f9563e744176425c39126) -- when Agda 2 wasn't even believed to exist yet.- verifyImportDirective usingList hdn' ren'+ let names' = usingList ++ hdn' ++ map renFrom ren' -- all mentioned names from the imported module+ -- Report any duplicates in @names'@.+ List1.unlessNull (mapMaybe List2.fromList1Maybe $ List1.group $ List.sort names') \ yss ->+ setCurrentRange yss $ typeError $ RepeatedNamesInImportDirective yss -- We start by checking that all of the names talked about in the import -- directive do exist. If some do not then we remove them and raise a warning.- let (missingExports, namesA) = checkExist $ usingList ++ hdn' ++ map renFrom ren'+ let (missingExports, namesA) = checkExist names' () <- List1.unlessNull missingExports \ missingExports1 -> setCurrentRange rng do reportSLn "scope.import.apply" 30 $ "non existing names: " ++ prettyShow missingExports warning $ ModuleDoesntExport m (Map.keys namesInScope) (Map.keys modulesInScope) missingExports1@@ -905,10 +955,36 @@ let look x = List1.head . Map.findWithDefault __IMPOSSIBLE__ x -- We set the ranges to the ranges of the concrete names in order to get -- highlighting for the names in the import directive.- let definedA = for definedNames $ \case- ImportedName x -> ImportedName . (x,) . setRange (getRange x) . anameName $ look x namesInScope'- ImportedModule x -> ImportedModule . (x,) . setRange (getRange x) . amodName $ look x modulesInScope' + let+ -- Amy, 2025-05-12: to support `record where`, we also need to+ -- update the concrete name of the "target" to match the concrete+ -- name that the user wrote--- otherwise we get import directives+ -- from user code like+ --+ -- open Some.Qualified renaming (original to new)+ --+ -- that print (and, more importantly, generate record fields!) like+ --+ -- renaming (Some.Qualifed.original to Some.Qualified.original)+ --+ -- because the new concrete name is a thin alias for the existing+ -- abstract QName, rather than+ --+ -- renaming (Some.Qualified.Original to new)+ --+ -- Andreas, 2026-10-02+ -- Even though @record where@ has been removed again, and @upd@+ -- does not make an observable difference any more, we can leave+ -- @upd@ in.++ upd :: C.Name -> A.QName -> A.QName+ upd x nm = setRange (getRange x) $ qualify_ $ (qnameName nm) { nameConcrete = x }++ definedA = for definedNames $ \case+ ImportedName x -> ImportedName . (x,) . upd x . anameName $ look x namesInScope'+ ImportedModule x -> ImportedModule . (x,) . setRange (getRange x) . amodName $ look x modulesInScope'+ let adir = mapImportDir namesA definedA dir return (adir, scope') -- TODO Issue 1714: adir @@ -1047,12 +1123,12 @@ noGeneralizedVarsIfLetOpen LetOpenModule = disallowGeneralizedVars -- | Open a module.-openModule_ :: OpenKind -> C.QName -> C.ImportDirective -> ScopeM A.ImportDirective-openModule_ kind cm dir = openModule kind Nothing cm dir+openModule_ :: KwRange -> OpenKind -> C.QName -> C.ImportDirective -> ScopeM A.ImportDirective+openModule_ kwr kind cm dir = openModule kwr kind Nothing cm dir -- | Open a module, possibly given an already resolved module name.-openModule :: OpenKind -> Maybe A.ModuleName -> C.QName -> C.ImportDirective -> ScopeM A.ImportDirective-openModule kind mam cm dir = do+openModule :: KwRange -> OpenKind -> Maybe A.ModuleName -> C.QName -> C.ImportDirective -> ScopeM A.ImportDirective+openModule kwr kind mam cm dir = do current <- getCurrentModule m <- caseMaybe mam (amodName <$> resolveModule cm) return let acc | Nothing <- publicOpen dir = PrivateNS@@ -1061,10 +1137,13 @@ -- Get the scope exported by module to be opened. (adir, s') <- applyImportDirectiveM cm dir . inScopeBecause (Opened cm) .+ dropRecordConstructorPseudoName . noGeneralizedVarsIfLetOpen kind =<< getNamedScope m+ registerModuleOpening kwr current cm dir s' -- For the unused import warning let s = setScopeAccess acc s' let ns = scopeNameSpace acc s- modifyCurrentScope (`mergeScope` s)+ modifyCurrentScope \current -> recomputeNameParts $ mergeScope current s+ recomputeInverseScope -- Andreas, 2018-06-03, issue #3057: -- If we simply check for ambiguous exported identifiers _after_ -- importing the new identifiers into the current scope, we also@@ -1106,7 +1185,7 @@ where ks = fmap anameKind qs -- We report the first clashing exported identifier. () <- List1.unlessNull (filter defClash defClashes) $- \ ((x, q :| _) :| _) -> typeError $ ClashingDefinition (C.QName x) (anameName q) Nothing+ \ ((x, q :| _) :| _) -> typeError $ ClashingDefinition (C.QName x) (ClashingAbstractName q) Nothing List1.unlessNull modClashes $ \ ((_, ms) :| _) -> do caseMaybe (List1.last2 ms) __IMPOSSIBLE__ $ \ (m0, m1) -> do
+ src/full/Agda/Syntax/Scope/Operator.hs view
@@ -0,0 +1,220 @@++-- | Computing scopes of names that are relevant to parsing+-- some raw expression.+module Agda.Syntax.Scope.Operator+ ( OperatorScope(..)+ , getOperatorScope+ , getDefinedNames+ , localNames+ ) where++import Prelude hiding ( (||) )++import Control.Monad+import Data.Bifunctor+import Data.Either (partitionEithers)+import Data.Foldable+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map++import Data.Set (Set)+import qualified Data.Set as Set++import Agda.Syntax.Abstract.Name (AbstractName (..), AbstractModule (..), KindOfName(..))+import Agda.Syntax.Abstract.Name qualified as A++import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty+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.Boolean ( (||) )+import Agda.Utils.Function ( applyWhenJust )+import Agda.Utils.Lens+import Agda.Utils.List+import Agda.Utils.List1 (List1, NonEmpty(..))+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Maybe+import Agda.Utils.AssocList (AssocList)+import Agda.Utils.Impossible++-- | Looking up all name parts of a QName.+namePartScopeLookup :: QName -> ScopeInfo -> [Map Name (List1 AbstractName)]+namePartScopeLookup q scope = inAllScopes ++! imports+ where+ -- 1. Finding a name in the current scope and its parents.+ inAllScopes :: [Map Name (List1 AbstractName)]+ inAllScopes = concatMap' (findName q) allScopes++ -- 2. Finding a name in the imports belonging to an initial part of the qualifier.+ imports :: [Map Name (List1 AbstractName)]+ imports = do+ let -- return all possible splittings, e.g.+ -- splitName X.Y.Z = [(X, Y.Z), (X.Y, Z)]+ splitName :: QName -> [(QName, QName)]+ splitName (QName x) = []+ splitName (Qual x q) = ((QName x, q):) $! map' (\(m, r) -> (Qual x m, r)) (splitName q)++ (m, x) <- splitName q+ s <- allScopes+ m <- maybeToList $ Map.lookup m $ scopeImports s+ findName x $ restrictPrivate $ moduleScope m++ moduleScope :: A.ModuleName -> Scope+ moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules++ allScopes :: [Scope]+ allScopes = (current :) $! map' moduleScope (scopeParents current) where+ current = moduleScope $ scope ^. scopeCurrent++ findName :: QName -> Scope -> [Map Name (List1 AbstractName)]+ findName q0 s = case q0 of+ QName x -> do+ n <- nameStringParts x+ (_, ns) <- scopeNameSpaces s+ maybeToList $ Map.lookup n (nsNameParts ns)+ Qual x q -> do+ m <- amodName . fst <$!> findNameInScope x s+ let ss = restrictPrivate <$!> (Map.lookup m $ scope ^. scopeModules)+ s' <- maybeToList ss+ findName q s'++getOperatorScope :: Set QName -> ScopeInfo -> OperatorScope+getOperatorScope names scope = let++ nameList :: [QName]+ nameList = Set.toList names++ namePartSet :: Set NameParts+ namePartSet = let+ getParts :: QName -> NameParts+ getParts (QName x) = nameParts x+ getParts (Qual _ x) = getParts x++ go :: Set NameParts -> QName -> Set NameParts+ go acc x = let+ parts = getParts x+ goPart !acc Hole = acc+ goPart acc (Id x) = Set.insert (Id x :| []) acc+ in foldl' goPart (Set.insert parts acc) parts++ in foldl' go mempty nameList++ -- look up the name as a full identifier+ fullNameLookups :: [(QName, List1 AbstractName)]+ fullNameLookups = do+ qname <- nameList+ case scopeLookup qname scope of+ [] -> []+ a:as -> [(qname, a :| as)]++ requalify :: QName -> Name -> QName+ requalify qn n = case qn of+ QName _ -> QName n+ Qual x qn -> Qual x $! requalify qn n++ -- lookup all parts of a name as operator/notation parts+ namePartLookups :: [(QName, List1 AbstractName)]+ namePartLookups = do+ qname <- nameList+ map <- namePartScopeLookup qname scope+ (name, as) <- Map.toList map+ let !name' = requalify qname name+ pure (name', as)++ goLocals :: LocalVars -> (AssocList Name A.Name, Bool)+ goLocals ls = go ls mempty where+ go :: LocalVars -> Set Name -> (AssocList Name A.Name, Bool)+ go [] !seen = ([], False)+ go ((x, a):ls) seen | Set.member x seen = go ls seen+ go ((x, a):ls) seen = case notShadowedLocal a of+ Nothing -> go ls seen+ Just a ->+ let goNamePart = \case+ Id x -> Set.member (Id x :| []) namePartSet+ _ -> False+ goNotPart = \case+ IdPart x -> Set.member (Id (rangedThing x) :| []) namePartSet+ _ -> False+ not = theNotation (A.nameFixity a)+ parts = nameParts x+ anyOp = (any (== Hole) parts && any goNamePart parts) || any goNotPart not+ anyName = Set.member parts namePartSet+ (ls', anyOp') = go ls (Set.insert x seen)+ !anyOp'' = anyOp || anyOp'+ !ls'' = if anyOp || anyName then (x, a):ls' else ls'+ in (ls'', anyOp'')++ (locals, hasLocalOp) = goLocals (scope ^. scopeLocals)++ in if null namePartLookups && not hasLocalOp+ then OpScope False (Map.fromListWith (flip List1.union) fullNameLookups) locals+ else OpScope True (Map.fromListWith (flip List1.union) (fullNameLookups ++! namePartLookups)) locals+++-- | 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' :: (AbstractName -> Bool) -> OperatorScope -> [List1 NewNotation]+getDefinedNames' f (OpScope _ names _) =+ [ mergeNotations $ List1.map' (namesToNotation x . A.qnameName . anameName) ds+ | (x, ds) <- Map.toList names+ , any f 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.++getDefinedNames :: KindsOfNames -> OperatorScope -> [List1 NewNotation]+getDefinedNames kinds = getDefinedNames' (filterByKind kinds)++filterByKind :: KindsOfNames -> AbstractName -> Bool+filterByKind kinds = (`elemKindsOfNames` kinds) . anameKind++-- | Compute all names (first component) and operators/notations+-- (second component) in scope.+--+-- For 'IsPattern', only constructor-like names are returned.+--+localNames :: ExprKind -> Maybe QName -> OperatorScope -> ScopeM ([QName], [NewNotation])+localNames k top opScope@(OpScope _ _ locals) = do+ -- Construct a filter for the names we consider.+ let+ f = case k of+ IsExpr -> const True+ IsPattern YesDisplayLHS -> const True+ -- #8228: Non-constructor-like operators are useful in DISPLAY+ -- pragmas.+ IsPattern NoDisplayLHS -> let+ -- Andreas, 2025-02-28, issue #7722+ -- Filter by kind.+ -- Just return the constructor-like operators,+ -- otherwise the pattern parser blows up.+ fk = filterByKind (someKindsOfNames $ FldName : conLikeNameKinds)+ -- Filter by name, keeping @top@ in.+ ft = top <&> \ y -> (unqualify y ==) . A.nameConcrete . A.qnameName . anameName+ in applyWhenJust ft (||) fk++ -- Retrieve the names of interest from the flat scope.+ let defs = getDefinedNames' f opScope++ -- Note: Debug printout aligned with the one in+ -- Agda.Syntax.Concrete.Operators.buildParsers.+ reportS "scope.operators" 50+ [ "opScope = " ++ prettyShow opScope+ , "defs = " ++ prettyShow defs+ , "locals = " ++ prettyShow locals+ ]+ let localNots = map' localOp locals+ notLocal = not . hasElem (map' notaName localNots) . notaName+ otherNots = concatMap' (List1.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/State.hs view
@@ -0,0 +1,52 @@+-- | General functions for stateful manipulation of the scope.++-- This module has been originally created to avoid import cycles between+-- Agda.Syntax.Scope.Monad and Agda.Syntax.Scope.UnusedImports.++module Agda.Syntax.Scope.State where++import Agda.Syntax.Abstract.Name as A ( ModuleName )+import Agda.Syntax.Position ( SetRange(setRange), noRange )+import Agda.Syntax.Scope.Base (scopeCurrent)++import Agda.TypeChecking.Monad.Base ( TCM, MonadTCState, ReadTCState )+import Agda.TypeChecking.Monad.State (useScope, modifyScope, recomputeInverseScope)++import Agda.Utils.Lens (set)+import Agda.Utils.Monad (MonadTrans (lift))++---------------------------------------------------------------------------+-- * The scope checking monad+---------------------------------------------------------------------------++-- | To simplify interaction between scope checking and type checking (in+-- particular when chasing imports), we use the same monad.+type ScopeM = TCM++---------------------------------------------------------------------------+-- * Current module+---------------------------------------------------------------------------++getCurrentModule :: ReadTCState m => m A.ModuleName+getCurrentModule = setRange noRange <$> useScope scopeCurrent++setCurrentModule :: MonadTCState m => A.ModuleName -> m ()+setCurrentModule m = do+ modifyScope $ set scopeCurrent m+ recomputeInverseScope++withCurrentModule :: (ReadTCState m, MonadTCState m) => A.ModuleName -> m a -> m a+withCurrentModule new action = do+ old <- getCurrentModule+ setCurrentModule new+ x <- action+ setCurrentModule old+ return x++withCurrentModule' :: (MonadTrans t, Monad (t ScopeM)) => A.ModuleName -> t ScopeM a -> t ScopeM a+withCurrentModule' new action = do+ old <- lift getCurrentModule+ lift $ setCurrentModule new+ x <- action+ lift $ setCurrentModule old+ return x
+ src/full/Agda/Syntax/Scope/UnusedImports.hs view
@@ -0,0 +1,327 @@+-- | Warn about unused imports.+--+-- For each @open@ statement, we want to issue a warning about concrete names+-- and modules brought into scope by this statement which are not referenced subsequently.+--+-- To this end, whenever we lookup a concrete name during scope checking,+-- we mark it as used by calling 'lookedupName' with the results of the lookup,+-- which is an 'AbstractName' or several 'AbstractName's in case the name+-- is ambiguous (e.g. an ambiguous constructor or projection).+-- Likewise, whenever we resolve a concrete module name,+-- we mark the resulting 'AbstractModule' as used by calling 'lookedupModule'.+-- If the concrete name is qualified, e.g. @M.x@,+-- we also mark the module @M@ as used that the qualifier resolved to.+--+-- We also record for each opened module the set of 'AbstractName's+-- and 'AbstractModule's it brought into scope.+--+-- When checking the file is done, we can traverse the each opened module+-- and report all the 'AbstractName's and 'AbstractModule's that we not used.++module Agda.Syntax.Scope.UnusedImports+ ( lookedupName+ , lookedupModule+ , registerModuleOpening+ , warnUnusedImports+ ) where++import Prelude hiding (null, (||))++import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.List (partition, sortOn)+import Data.Map qualified as Map+import Data.Set qualified as Set++import Agda.Interaction.Options (optQualifiedInstances)+import Agda.Interaction.Options.Warnings (WarningName (UnusedImports_, UnusedImportsAll_))++import Agda.Syntax.Abstract.Name+ ( WhyInScope(Defined, Opened, Applied),+ AbstractName, anameName, anameLineage,+ AbstractModule, amodName, amodLineage )+import Agda.Syntax.Abstract.Name qualified as A+import Agda.Syntax.Common+ ( IsInstanceDef(isInstanceDef), KwRange+ , ImportDirective'(using, impRenaming, publicOpen)+ , ImportedName'(ImportedName, ImportedModule), fromImportedName, Renaming'(renTo), Using'(Using, UseEverything)+ )+import Agda.Syntax.Common.Pretty (prettyShow, Pretty (pretty))+import Agda.Syntax.Concrete qualified as C+import Agda.Syntax.Position ( HasRange(getRange), SetRange(setRange) )+import Agda.Syntax.Position qualified as P+import Agda.Syntax.Scope.Base as A+import Agda.Syntax.Scope.State ( ScopeM, withCurrentModule )+-- importing Agda.Syntax.Scope.Monad creates import cycles++import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Debug ( MonadDebug, reportSLn, __IMPOSSIBLE_VERBOSE__ )+import Agda.TypeChecking.Monad.State ( getScope )+import Agda.TypeChecking.Monad.Trace (setCurrentRange)+import Agda.TypeChecking.Warnings (warning)++import Agda.Utils.Boolean ( (||) )+import Agda.Utils.Function ( applyUnless )+import Agda.Utils.Lens ( (<&>), Lens' )+import Agda.Utils.List ( partitionMaybe, hasElem )+import Agda.Utils.List1 ( pattern (:|), List1 )+import Agda.Utils.List1 qualified as List1+import Agda.Utils.List2 ( List2(..) )+import Agda.Utils.List2 qualified as List2+import Agda.Utils.Maybe ( fromMaybe, isJust, mapMaybe, whenNothing )+import Agda.Utils.Monad ( forM_, when, unless, whenM )+import Agda.Utils.Null ( Null(null) )++import Agda.Utils.Impossible++-- | Call these whenever a concrete name was translated to an abstract one.+lookedupName ::+ C.QName -- ^ The concrete name resolved by the scope checker.+ -> ResolvedName -- ^ The resolution of the name.+ -> ScopeM ()+lookedupName x = \case+ DefinedName _access y _suffix -> unamb y >> lookedupQualifier x [y]+ FieldName ys -> add ys+ ConstructorName _ind ys -> add ys+ PatternSynResName ys -> add ys+ VarName{} -> return ()+ UnknownName{} -> return ()+ where+ add ys = do+ case ys of+ y :| [] -> unamb y+ y1 :| y2 : ys -> amb $ List2 y1 y2 ys+ lookedupQualifier x $ List1.toList ys+ unamb = modifyTCLens stUnambiguousLookups . (:)+ amb xs = case rangeToPosPos x of+ -- Andreas, 2025-11-30+ -- It can happen that a concrete identifier has no range,+ -- e.g. when it comes from an expanded ellipsis.+ -- In this case, we do not record the lookup,+ -- since it should have been looked up already+ -- when processing the pattern from the original lhs+ -- (that was duplicated by ellipsis expansion).+ -- See test/Interaction/ExpandEllipsis.+ Nothing -> pure ()+ Just i -> modifyTCLens stAmbiguousLookups $ IntMap.insert i xs++-- | Call this whenever a concrete module name was translated to an abstract one.+lookedupModule ::+ C.QName -- ^ The concrete module name resolved by the scope checker.+ -> AbstractModule -- ^ The resolution of the module name.+ -> ScopeM ()+lookedupModule x m = do+ modifyTCLens stModuleLookups (m :)+ lookedupQualifier x [m]++-- | If the concrete name @x@ is qualified, i.e., of the form @M.y@,+-- mark the modules @M@ as used through which @x@ resolved to (one of) the given things.+lookedupQualifier :: InScope a => C.QName -> [a] -> ScopeM ()+lookedupQualifier x ys = case x of+ C.QName{} -> pure ()+ C.Qual{} -> whenM unusedImportsEnabled do+ ms <- scopeLookupQualifier x ys <$> getScope+ modifyTCLens stModuleLookups (ms ++)++-- | Is the 'UnusedImports' warning on?+-- It is sufficient to check for 'UnusedImports_' since it is implied by 'UnusedImportsAll_'.+unusedImportsEnabled :: ScopeM Bool+unusedImportsEnabled = (UnusedImports_ `Set.member`) <$> useTC stWarningSet++rangeToPosPos :: HasRange a => a -> Maybe Int+rangeToPosPos = fmap (fromIntegral . P.posPos) . P.rStart' . getRange++-- | Call this when opening a module with all the names it brings into scope.+-- When the 'UnusedImports' warning is enabled, we will store this information+-- to later issue a warning connected to this 'open' statement+-- for the names that were not used.+registerModuleOpening ::+ KwRange -- ^ Range of the @open@ keyword.+ -> A.ModuleName -- ^ Parent module: module into which we pour the opened module.+ -> C.QName -- ^ Opened module.+ -> C.ImportDirective -- ^ Directive restricting the scope of the opened module.+ -> Scope -- ^ The scope resulting from applying the import directive.+ -> ScopeM ()+registerModuleOpening kwr currentModule x dir (Scope m0 _parents ns imports _dataOrRec) = do+ -- @imports@ have been removed by 'restrictPrivate'.+ unless (null imports) __IMPOSSIBLE__++ -- When the UnusedImports warning is off, do not collect information about @open@.+ -- E.g. we do not want to see warnings for the automatically inserted+ -- @open import Agda.Primitive using (Set)@.+ doWarn <- unusedImportsEnabled+ reportSLn "warning.unusedImports" 20 $ unlines+ [ "openedModule: " <> prettyShow doWarn+ , "x = " <> prettyShow x+ -- , "currentModule: " <> prettyShow curM+ ]+ when doWarn $ whenNothing (publicOpen dir) do+ let+ m = setRange (getRange x) m0+ names :: NamesInScope -- Map C.Name (List1 AbstractName)+ names = mergeNamesMany $ map (nsNames . snd) ns+ modules :: ModulesInScope -- Map C.Name (List1 AbstractModule)+ modules = mergeNamesMany $ map (nsModules . snd) ns+ -- The modules mentioned in the directive.+ explicitModules = Set.fromList+ [ y | ImportedModule y <- usingList ++ map renTo (impRenaming dir) ]+ usingList = case using dir of+ UseEverything -> []+ Using ys -> ys+ -- Modules that come with a name, e.g. modules of data and record types.+ -- We recognize them either by their abstract name,+ -- or by their concrete name (needed for copies made by module application,+ -- since these get fresh abstract names).+ companions = Map.keysSet (Map.filterWithKey isCompanion modules)+ isCompanion y zs = Set.notMember y explicitModules &&+ (Map.member y names || any ((`Set.member` nameModules) . amodName) zs)+ nameModules = Set.fromList $ map (A.qnameToMName . anameName) $ concatMap List1.toList $ Map.elems names+ !k = fromMaybe __IMPOSSIBLE__ $ rangeToPosPos x+ hasDir = not (null (using dir)) || not (null (impRenaming dir))+ modifyTCLens stOpenedModules $+ IntMap.insert k (OpenedModule kwr m currentModule hasDir names modules companions)++-- | Call this when a file has been checked to generate the unused-imports warnings for each opened module.+-- Assumes that all names have been looked up via 'lookedupName'+-- and all modules via 'lookedupModule'.+-- Needs the disambiguation information from the type checker to correctly report ununsed overloaded names.+warnUnusedImports :: TCM ()+warnUnusedImports = do+ warnAll <- (UnusedImportsAll_ `Set.member`) <$> useTC stWarningSet+ st <- useTC stUnusedImportsState+ disambiguatedNames <- useTC stDisambiguatedNames+ -- If instances can be used qualified, they do not need to be imported,+ -- so we should warn about them.+ qualifiedInstances <- optQualifiedInstances <$> pragmaOptions++ reportSLn "warning.unusedImports" 60 $ "ambiguousLookups: " <> prettyShow (ambiguousLookups st)+ reportSLn "warning.unusedImports" 60 $ "unambiguousLookups: " <> prettyShow (unambiguousLookups st)+ reportSLn "warning.unusedImports" 60 $ "moduleLookups: " <> prettyShow (moduleLookups st)++ let+ -- Disambiguate overloaded lookups.+ addAmbLookup (i :: Int) (ys :: List2 AbstractName) = do+ case IntMap.lookup i disambiguatedNames of+ Just (DisambiguatedName _k x) -> (filter ((x ==) . anameName) (List2.toList ys) ++)+ Nothing -> (List2.toList ys ++) -- __IMPOSSIBLE__+ allLookups :: [AbstractName]+ allLookups = IntMap.foldrWithKey addAmbLookup (unambiguousLookups st) (ambiguousLookups st)++ -- To make a set of the list of looked-up 'AbstractName's,+ -- we need to convert them to 'Imported' lest we+ -- conflate names from different openings.+ -- Same for the 'AbstractModule's.+ lookups :: [Imported AbstractName]+ (unknowns, lookups) = partitionMaybe toImported allLookups+ moduleLookups' :: [Imported AbstractModule]+ moduleLookups' = mapMaybe toImported $ moduleLookups st++ isInst, isUsedName :: Imported AbstractName -> Bool+ isInst = isJust . isInstanceDef . iThing+ isUsedName = applyUnless qualifiedInstances (isInst ||) $ hasElem lookups+ isUsedModule :: Imported AbstractModule -> Bool+ isUsedModule = hasElem moduleLookups'++ reportSLn "warning.unusedImports" 60 $ "allLookups: " <> prettyShow allLookups+ reportSLn "warning.unusedImports" 60 $ "lookups: " <> prettyShow lookups+ reportSLn "warning.unusedImports" 60 $ "unknowns: " <> prettyShow unknowns++ -- Iterate through the @open@ statements and issue warnings.+ forM_ (openedModules st) \ (OpenedModule kwr m parent hasDir names modules companions) -> do++ -- Partition the names and modules brought into scope by the open statement+ -- into used and unused ones.+ (usedNames, unusedNames) <- partitionUsed isUsedName names+ (usedModules, unusedModules) <- partitionUsed isUsedModule modules++ let+ used = not (null usedNames && null usedModules)+ -- Unused things to report individually, in alphabetical order.+ -- We omit the modules of data and record types not mentioned explicitly,+ -- since we report their names already.+ unused :: [C.ImportedName]+ unused = sortOn fromImportedName $ concat+ [ map ImportedName unusedNames+ , map ImportedModule $ filter (`Set.notMember` companions) unusedModules+ ]++ -- Commands to issue the warnings:+ warn = setCurrentRange (getRange (kwr, m)) . withCurrentModule parent . warning . UnusedImports m+ warnModule = warn Nothing+ warnEach = List1.unlessNull unused $ warn . Just++ -- Issue warning.+ -- If nothing was used, we warn about the whole import.+ -- If the open statement has a 'using' or 'renaming' directive,+ -- or if the 'UnusedImportsAll_' warning is enabled,+ -- we warn about each unused name individually.+ -- Otherwise, we just warn once about the whole import.+ if | hasDir -> warnEach+ | not used -> warnModule+ | warnAll -> warnEach+ | otherwise -> pure ()++-- | Partition the things brought into scope by an @open@ statement+-- into the used and unused ones.+-- Returns the concrete names they are in scope under.+partitionUsed :: forall a m. (Lineage a, MonadDebug m)+ => (Imported a -> Bool) -- ^ Was the thing used?+ -> ThingsInScope a -- ^ The things brought into scope by the @open@.+ -> m ([C.Name], [C.Name])+partitionUsed isUsed sc = do+ let+ imps, used, unused :: [(C.Name, List1 (Imported a))]+ (other, imps) = partitionMaybe (traverse $ traverse toImported) $ Map.toList sc+ (used, unused) = partition (any isUsed . snd) imps+ reportSLn "warning.unusedImports" 60 $ "used: " <> prettyShow used+ reportSLn "warning.unusedImports" 60 $ "unused: " <> prettyShow unused+ unless (null other) $ __IMPOSSIBLE_VERBOSE__ (show other)+ return (map fst used, map fst unused)++------------------------------------------------------------------------------+-- * Auxiliary definitions++-- | Things (names and modules) that remember how they came into scope.+class (Ord a, Show a, Pretty a) => Lineage a where+ lineage :: a -> WhyInScope++instance Lineage AbstractName where+ lineage = anameLineage++instance Lineage AbstractModule where+ lineage = amodLineage++-- | A wrapper around 'AbstractName' or 'AbstractModule'+-- to make the position of the 'Opened' in the lineage available.+-- This wrapper is needed when 'AbstractName's are stored in sets+-- so that we do not conflate different 'AbstractName's with the same underlying 'A.QName'+-- that were brought into scope by different 'open' statements.+data Imported a = Imported+ { iWhere :: Int -- Position of 'Opened' extracted from the 'AbstractName'.+ , iThing :: a+ } deriving (Eq, Ord, Show)++instance Pretty a => Pretty (Imported a) where+ pretty (Imported i n) = pretty n <> " (at position " <> pretty i <> ")"++-- | Convert an 'AbstractName' or 'AbstractModule' to an 'Imported'+-- if it was brought into scope by an 'open' statement.+toImported :: Lineage a => a -> Maybe (Imported a)+toImported x = case lineage x of+ Opened m _ -> rangeToPosPos m <&> (`Imported` x)+ Applied{} -> Nothing+ Defined{} -> Nothing++-- Lenses for the components of the UnusedImportsState in the TCState.++stUnambiguousLookups :: Lens' TCState [AbstractName]+stUnambiguousLookups = stUnusedImportsState . lensUnambiguousLookups++stAmbiguousLookups :: Lens' TCState (IntMap (List2 AbstractName))+stAmbiguousLookups = stUnusedImportsState . lensAmbiguousLookups++stModuleLookups :: Lens' TCState [AbstractModule]+stModuleLookups = stUnusedImportsState . lensModuleLookups++stOpenedModules :: Lens' TCState (IntMap OpenedModule)+stOpenedModules = stUnusedImportsState . lensOpenedModules
src/full/Agda/Syntax/TopLevelModuleName.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-} ------------------------------------------------------------------------ -- Top-level module names@@ -27,6 +28,7 @@ import Agda.Syntax.Position import Agda.Utils.FileName+import Agda.Utils.Function (iterate') import Agda.Utils.Hash import Agda.Utils.Impossible import Agda.Utils.Lens@@ -120,19 +122,10 @@ , rawModuleNameInferred = isNoName x } --- | 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'.+-- | Retrieves the top-level module name. rawTopLevelModuleNameForModule :: C.Module -> RawTopLevelModuleName-rawTopLevelModuleNameForModule (C.Mod _ []) = __IMPOSSIBLE__-rawTopLevelModuleNameForModule (C.Mod _ ds) =- case C.spanAllowedBeforeModule ds of- (_, C.Module _ _ n _ _ : _) -> rawTopLevelModuleNameForQName n- _ -> __IMPOSSIBLE__+rawTopLevelModuleNameForModule (C.Mod n _pragmas _decls) = rawTopLevelModuleNameForQName n ------------------------------------------------------------------------ -- Top-level module names@@ -208,5 +201,4 @@ projectRoot :: AbsolutePath -> TopLevelModuleName -> AbsolutePath projectRoot file TopLevelModuleName{ moduleNameParts = m } =- mkAbsolute $- iterate takeDirectory (filePath file) !! length m+ mkAbsolute $ iterate' (length m) takeDirectory $ filePath file
src/full/Agda/Syntax/TopLevelModuleName/Boot.hs view
@@ -2,9 +2,6 @@ module Agda.Syntax.TopLevelModuleName.Boot where -import Agda.Utils.List1 (List1)-import Agda.Utils.BiMap (HasTag, Tag, tag)- import Control.DeepSeq (NFData, rnf) import Data.Function (on) import Data.Hashable (Hashable, hashWithSalt)@@ -12,8 +9,12 @@ import Data.Word (Word64) import GHC.Generics (Generic) +import Agda.Utils.BiMap (HasTag, Tag, tag)+import Agda.Utils.List1 (List1)+import Agda.Utils.Null+ newtype ModuleNameHash = ModuleNameHash { moduleNameHash :: Word64 }- deriving (Eq, Ord, Hashable)+ deriving (Eq, Ord, Hashable, Null) instance NFData ModuleNameHash where rnf _ = ()@@ -23,7 +24,7 @@ tag = Just noModuleNameHash :: ModuleNameHash-noModuleNameHash = ModuleNameHash 0+noModuleNameHash = empty -- | The record selector is not included in the resulting strings.
src/full/Agda/Syntax/Translation/AbstractToConcrete.hs view
@@ -97,7 +97,8 @@ -- | Preconditions to run the AbstractToConcrete translation. -- type MonadAbsToCon m =- ( MonadFresh NameId m+ ( MonadFileId m+ , MonadFresh NameId m , MonadInteractionPoints m , MonadStConcreteNames m , HasOptions m@@ -140,7 +141,8 @@ --------------------------------------------------------------------------- type MonadToConcrete m =- ( MonadAbsToCon m+ ( MonadFileId m+ , MonadAbsToCon m , MonadReader Env m ) @@ -152,6 +154,7 @@ , HasOptions , MonadAddContext , MonadDebug+ , MonadFileId , MonadInteractionPoints , MonadReduce , MonadStConcreteNames@@ -163,7 +166,7 @@ deriving instance MonadFresh NameId m => MonadFresh NameId (AbsToConT m) deriving instance (Monad m, IsString (m Doc)) => IsString (AbsToConT m Doc) deriving instance (Monad m, Null (m Doc)) => Null (AbsToConT m Doc)-deriving instance (Monad m, Semigroup (m Doc)) => Semigroup (AbsToConT m Doc)+deriving instance (Monad m) => Semigroup (AbsToConT m Doc) runAbsToCon :: MonadAbsToCon m => AbsToConT m c -> m c runAbsToCon m = do@@ -210,8 +213,8 @@ noScopeCheck b || isNameInScope q scope -> return [(b, q)] _ -> return [] ctxVars <- getContextNames'- letVars <- Map.keys <$> asksTC envLetBindings- let vars = ctxVars ++ letVars+ letVars <- Map.keys <$> viewTC eLetBindings+ let vars = ctxVars ++! letVars -- pick concrete names for in-scope names now so we don't -- accidentally shadow them@@ -397,9 +400,9 @@ Just ys -> List1.snoc (List1.toList ys) y -- | For the given abstract name, return the names that could shadow it.-shadowingNames :: (ReadTCState m, MonadStConcreteNames m)+shadowingNames :: (ReadTCState m) => A.Name -> m (Set RawName)-shadowingNames x = Set1.toSet' . Map.lookup x <$> useR stShadowingNames+shadowingNames x = pure mempty -- TODO toConcreteName :: MonadToConcrete m => A.Name -> m C.Name toConcreteName x | y <- nameConcrete x , isNoName y = return y@@ -619,6 +622,10 @@ type ConOfAbs Char = Char toConcrete = pure +instance ToConcrete C.Name where+ type ConOfAbs C.Name = C.Name+ toConcrete = pure+ -- Functors --------------------------------------------------------------- instance ToConcrete a => ToConcrete [a] where@@ -785,15 +792,52 @@ -- Expression instance ---------------------------------------------------- +class NameAspects a where+ -- | Wrap the given 'Asp.NameKind' into an 'Asp.Aspects' which+ -- contains extra information generically derived (e.g. binding site)+ -- from the name.+ nameAspects+ :: Bool -- ^ Is this an operator part?+ -> Asp.NameKind -- ^ Specific syntax-highlighting information+ -> a -- ^ The name+ -> Asp.Aspects++instance NameAspects A.Name where+ nameAspects opp nk qn = (Asp.rangeDefinitionSite (nameBindingSite qn))+ { Asp.tokenBased = Asp.NotOnlyTokenBased+ , Asp.aspect = Just (Asp.Name (Just nk) opp)+ }++instance NameAspects A.QName where+ nameAspects opp nk = nameAspects opp nk . qnameName++-- | Only adds a binding site if the name is unambiguous.+instance NameAspects A.AmbiguousQName where+ nameAspects op nk amb+ | Just q <- A.getUnambiguous amb = nameAspects op nk (qnameName q)++ nameAspects op nk amb = empty+ { Asp.tokenBased = Asp.NotOnlyTokenBased+ , Asp.aspect = Just (Asp.Name (Just nk) False)+ }++knownIdent :: NameAspects a => Asp.NameKind -> a -> C.QName -> C.Expr+knownIdent nk a c = C.KnownIdent (nameAspects False nk a) c+ instance ToConcrete A.Expr where type ConOfAbs A.Expr = C.Expr - toConcrete (Var x) = KnownIdent Asp.Bound . C.QName <$> toConcrete x- toConcrete (Def' x suffix) = KnownIdent Asp.Function <$> addSuffixConcrete suffix (toConcrete x)- toConcrete (Proj ProjPrefix p) = KnownIdent Asp.Field <$> toConcrete (headAmbQ p)- toConcrete (Proj _ p) = C.Dot empty . KnownIdent Asp.Field <$> toConcrete (headAmbQ p)- toConcrete (A.Macro x) = KnownIdent Asp.Macro <$> toConcrete x- toConcrete e@(Con c) = tryToRecoverPatternSyn e $ KnownIdent (Asp.Constructor Inductive) <$> toConcrete (headAmbQ c)+ toConcrete (Var x) = knownIdent Asp.Bound x . C.QName <$> toConcrete x+ toConcrete (Def' x suffix) = knownIdent Asp.Function (qnameName x) <$> addSuffixConcrete suffix (toConcrete x)+ toConcrete (Proj ProjPrefix p) = knownIdent Asp.Field p <$> toConcrete (headAmbQ p)+ toConcrete (Proj _ p) = C.Dot empty . knownIdent Asp.Field p <$> toConcrete (headAmbQ p)+ toConcrete (A.Macro x) = knownIdent Asp.Macro (qnameName x) <$> toConcrete x+ toConcrete (A.PatternSyn n) = knownIdent (Asp.Constructor Inductive) n <$> toConcrete (headAmbQ n)+ toConcrete (A.Highlighted a b) = C.Highlighted a <$> toConcrete b++ toConcrete e@(Con c) = tryToRecoverPatternSyn e $+ knownIdent (Asp.Constructor Inductive) c <$> toConcrete (headAmbQ c)+ -- for names we have to use the name from the info, since the abstract -- name has been resolved to a fully qualified name (except for -- variables)@@ -810,7 +854,7 @@ toConcrete (A.QuestionMark i ii) = do preserve <- asks preserveIIds return $ C.QuestionMark (getRange i) $- interactionId ii <$ guard (preserve || isJust (metaNumber i))+ interactionId ii <$ guard (preserve || isJust (metaNumber i)) toConcrete (A.Underscore i) = C.Underscore (getRange i) <$>@@ -913,7 +957,7 @@ return [p] -- __IMPOSSIBLE__ -- Andreas, this is actually not impossible, -- my strictification exposed this sleeping bug- let decl2clause (C.FunClause (C.LHS p [] []) rhs C.NoWhere ca) = do+ let decl2clause (C.FunClause ai (C.LHS p [] []) rhs C.NoWhere ca) = do reportSLn "extendedlambda" 50 $ "abstractToConcrete extended lambda pattern p = " ++ show p ps <- removeApp p reportSLn "extendedlambda" 50 $ "abstractToConcrete extended lambda patterns ps = " ++ prettyShow ps@@ -970,16 +1014,19 @@ bracket appBrackets $ do C.RecUpdate kwr (getRange i) <$> toConcrete e <*> toConcreteTop fs + -- Annotated 'leftovers' from the scope-checker toConcrete (A.ScopedExpr _ e) = toConcrete e- toConcrete (A.Quote i) = return $ C.Quote (getRange i)- toConcrete (A.QuoteTerm i) = return $ C.QuoteTerm (getRange i)- toConcrete (A.Unquote i) = return $ C.Unquote (getRange i)+ toConcrete (A.Qualified _ e) = toConcrete e + -- Reflection keywords:+ toConcrete (A.Quote i) = return $ C.Quote (getRange i)+ toConcrete (A.QuoteTerm i) = return $ C.QuoteTerm (getRange i)+ toConcrete (A.Unquote i) = return $ C.Unquote (getRange i)+ -- Andreas, 2012-04-02: TODO! print DontCare as irrAxiom -- Andreas, 2010-10-05 print irrelevant things as ordinary things toConcrete (A.DontCare e) = C.Dot empty . C.Paren r <$> toConcrete e where r = getRange e- toConcrete (A.PatternSyn n) = C.Ident <$> toConcrete (headAmbQ n) makeDomainFree :: A.LamBinding -> A.LamBinding makeDomainFree b@(A.DomainFull (A.TBind _ tac (x :| []) t)) =@@ -1041,29 +1088,32 @@ bindToConcrete (A.LetBind i info x t e) ret = bindToConcrete x \ x -> do+ let+ keep C.Underscore{} = False+ keep _ = True toConcrete (t, A.RHS e Nothing) >>= \case (t, (e, [], [], [])) -> ret $ addInstanceB (if isInstance info then Just empty else Nothing) $- [ C.TypeSig info empty (C.boundName x) t- , C.FunClause- (C.LHS (C.IdentP True $ C.QName $ C.boundName x) [] [])- e C.NoWhere empty- ]+ [ C.TypeSig info empty (C.boundName x) t | keep t ] <>+ [ C.FunClause info+ (C.LHS (C.IdentP True $ C.QName $ C.boundName x) [] [])+ e C.NoWhere empty+ ] _ -> __IMPOSSIBLE__ bindToConcrete (A.LetAxiom i info x t) ret = bindToConcrete x \x -> do t <- toConcrete t ret $ addInstanceB (if isInstance info then Just empty else Nothing) $ [ C.TypeSig info empty (C.boundName x) t ] -- TODO: bind variables- bindToConcrete (LetPatBind i p e) ret = do+ bindToConcrete (LetPatBind i ai p e) ret = do p <- toConcrete p e <- toConcrete e- ret [ C.FunClause (C.LHS p [] []) (C.RHS e) NoWhere empty ]+ ret [ C.FunClause ai (C.LHS p [] []) (C.RHS e) NoWhere empty ] bindToConcrete (LetApply i erased x modapp _ _) ret = do x' <- unqualify <$> toConcrete x modapp <- toConcrete modapp let r = getRange modapp- open = fromMaybe DontOpen $ minfoOpenShort i+ open = minfoOpenShort i dir = fromMaybe defaultImportDir{ importDirRange = r } $ minfoDirective i -- This is no use since toAbstract LetDefs is in localToAbstract. local (openModule' x dir id) $@@ -1072,7 +1122,9 @@ x' <- toConcrete x let dir = fromMaybe defaultImportDir $ minfoDirective i local (openModule' x dir restrictPrivate) $- ret [ C.Open (getRange i) x' dir ]+ ret [ C.Open (kwRange i) x' dir ]+ -- Andreas, 2025-11-27, kwRange is a lie,+ -- but we do not have the range of the @open@ keyword here. instance ToConcrete A.WhereDeclarations where type ConOfAbs A.WhereDeclarations = WhereClause@@ -1153,7 +1205,7 @@ instance ToConcrete (Constr A.Constructor) where type ConOfAbs (Constr A.Constructor) = C.Declaration - toConcrete (Constr (A.ScopedDecl scope [d])) =+ toConcrete (Constr (A.ScopedDecl scope (d :| []))) = withScope scope $ toConcrete (Constr d) toConcrete (Constr (A.Axiom _ i info Nothing x t)) = do x' <- unsafeQNameToName <$> toConcrete x@@ -1170,7 +1222,7 @@ C.LHS p _ _ -> do bindToConcrete wh $ \ wh' -> do (rhs', eqs, with, wcs) <- toConcreteTop rhs- return $ FunClause (C.LHS p eqs with) rhs' wh' catchall :| wcs+ return $ FunClause defaultArgInfo (C.LHS p eqs with) rhs' wh' catchall :| wcs instance ToConcrete A.ModuleApplication where type ConOfAbs A.ModuleApplication = C.ModuleApplication@@ -1200,7 +1252,7 @@ type ConOfAbs A.Declaration = [C.Declaration] toConcrete (ScopedDecl scope ds) =- withScope scope (declsToConcrete ds)+ withScope scope $ declsToConcrete $ List1.toList ds toConcrete (A.Axiom _ i info mp x t) = do x' <- unsafeQNameToName <$> toConcrete x@@ -1238,7 +1290,7 @@ -- Primitives are always relevant. toConcrete (A.FunDef i _ cs) =- withAbstractPrivate i $ List1.concat <$> toConcrete cs+ withAbstractPrivate i $ List1.toList . sconcat <$> toConcrete cs toConcrete (A.DataSig i erased x bs t) = withAbstractPrivate i $@@ -1248,7 +1300,7 @@ return [ C.DataSig (getRange i) erased x' (map C.DomainFull $ catMaybes tel') t' ] - toConcrete (A.DataDef i x uc bs cs) =+ toConcrete (A.DataDef i x _pc _uc bs cs) = withAbstractPrivate i $ bindToConcrete (map makeDomainFree $ dataDefParams bs) $ \ tel' -> do (x',cs') <- first unsafeQNameToName <$> toConcrete (x, map Constr cs)@@ -1262,14 +1314,14 @@ return [ C.RecordSig (getRange i) erased x' (map C.DomainFull $ catMaybes tel') t' ] - toConcrete (A.RecDef i x uc dir bs t cs) =+ toConcrete (A.RecDef i x _pc _uc _eta dir bs t cs) = withAbstractPrivate i $ bindToConcrete (map makeDomainFree $ dataDefParams bs) $ \ tel' -> do dirs <- toConcrete dir (x',cs') <- first unsafeQNameToName <$> toConcrete (x, map Constr cs) return [ C.RecordDef (getRange i) x' dirs (catMaybes tel') cs' ] - toConcrete (A.Mutual i ds) = pure . C.Mutual empty <$> declsToConcrete ds+ toConcrete (A.Mutual i ds) = pure . C.Mutual empty <$> declsToConcrete (List1.toList ds) toConcrete (A.Section i erased x (A.GeneralizeTel _ tel) ds) = do x <- toConcrete x@@ -1281,15 +1333,15 @@ x <- unsafeQNameToName <$> toConcrete x modapp <- toConcrete modapp let r = getRange modapp- open = fromMaybe DontOpen $ minfoOpenShort i+ open = minfoOpenShort i dir = fromMaybe defaultImportDir{ importDirRange = r } $ minfoDirective i return [ C.ModuleMacro (getRange i) erased x modapp open dir ] toConcrete (A.Import i x _) = do x <- toConcrete x- let open = fromMaybe DontOpen $ minfoOpenShort i+ let open = minfoOpenShort i dir = fromMaybe defaultImportDir $ minfoDirective i- return [ C.Import (getRange i) x Nothing open dir]+ return [ C.Import open (kwRange i) x empty dir] toConcrete (A.Pragma i p) = do p <- toConcrete $ RangeAndPragma (getRange i) p@@ -1297,7 +1349,9 @@ toConcrete (A.Open i x _) = do x <- toConcrete x- return [C.Open (getRange i) x defaultImportDir]+ return [C.Open (kwRange i) x defaultImportDir]+ -- Andreas, 2025-11-27, kwRange is a lie,+ -- but we do not have the range of the @open@ keyword here. toConcrete (A.PatternSynDef x xs p) = toConcrete x >>= \case C.QName x -> bindToConcrete (map (fmap A.unBind) xs) \ xs ->@@ -1333,13 +1387,13 @@ A.CompilePragma b x s -> do x <- toConcrete x return $ C.CompilePragma r b x s+ A.ForeignPragma b s -> return $ C.ForeignPragma r b s A.StaticPragma x -> C.StaticPragma r <$> toConcrete x A.InjectivePragma x -> C.InjectivePragma r <$> toConcrete x A.InjectiveForInferencePragma x -> C.InjectiveForInferencePragma r <$> toConcrete x A.InlinePragma b x -> C.InlinePragma r b <$> toConcrete x A.NotProjectionLikePragma q -> C.NotProjectionLikePragma r <$> toConcrete q A.OverlapPragma q i -> C.OverlapPragma r <$> (fmap pure (toConcrete q)) <*> pure i- 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 @@ -1501,7 +1555,7 @@ A.ConP i c args -> tryOp (headAmbQ c) (A.ConP i c) args A.ProjP i ProjPrefix p -> C.IdentP True <$> toConcrete (headAmbQ p)- A.ProjP i _ p -> C.DotP empty noRange . C.Ident <$> toConcrete (headAmbQ p)+ A.ProjP i _ p -> C.DotP empty noRange CouldBeProjectionPattern . C.Ident <$> toConcrete (headAmbQ p) A.DefP i x args -> tryOp (headAmbQ x) (A.DefP i x) args @@ -1523,11 +1577,11 @@ -- Andreas, 2018-06-19, issue #3130 -- Print .p as .(p) if p is a projection -- to avoid confusion with projection pattern.- A.DotP i e@A.Proj{} -> C.DotP empty r . C.Paren r <$> toConcreteCtx TopCtx e+ A.DotP i e@A.Proj{} -> C.DotP empty r CannotBeProjectionPattern . C.Paren r <$> toConcreteCtx TopCtx e where r = getRange i -- gallais, 2019-02-12, issue #3491- -- Print p as .(p) if p is a variable but there is a projection of the+ -- Print .p as .(p) if p is a variable but there is a projection of the -- same name in scope. A.DotP i e@(A.Var v) -> do let r = getRange i@@ -1538,7 +1592,7 @@ -- If we do then we print .(v) rather than .v Right FieldName{} -> do reportSLn "print.dotted" 50 $ "Wrapping ambiguous name " ++ prettyShow (nameConcrete v)- C.DotP empty r . C.Paren r <$> toConcrete (A.Var v)+ C.DotP empty r CannotBeProjectionPattern . C.Paren r <$> toConcrete (A.Var v) Right _ -> printDotDefault i e Left _ -> __IMPOSSIBLE__ @@ -1564,7 +1618,7 @@ -- Andreas, 2016-02-04 print ._ pattern as _ pattern, -- following the fusing of WildP and ImplicitP. C.Underscore{} -> return $ C.WildP r- _ -> return $ C.DotP empty r c+ _ -> return $ C.DotP empty r CannotBeProjectionPattern c tryOp :: MonadToConcrete m => A.QName -> (A.Patterns -> A.Pattern) -> A.Patterns -> m C.Pattern tryOp x f args = do@@ -1637,7 +1691,7 @@ getHead (A.PatternSyn n) = Just (HdSyn $ headAmbQ n) getHead _ = Nothing -cOpApp :: Asp.NameKind -> Range -> C.QName -> A.Name -> List1 (MaybeSection C.Expr) -> C.Expr+cOpApp :: Asp.Aspects -> Range -> C.QName -> A.Name -> List1 (MaybeSection C.Expr) -> C.Expr cOpApp nk r x n es = C.KnownOpApp nk r x (singleton n) $ fmap (defaultNamedArg . placeholder) $@@ -1717,7 +1771,7 @@ recoverOpApp :: forall a c m. (ToConcrete a, c ~ ConOfAbs a, HasRange c, MonadToConcrete m) => ((PrecedenceStack -> Bool) -> m c -> m c) -> (a -> Bool) -- ^ Check for lambdas- -> (Asp.NameKind -> Range -> C.QName -> A.Name -> List1 (MaybeSection c) -> c) -- ^ @opApp@+ -> (Asp.Aspects -> Range -> C.QName -> A.Name -> List1 (MaybeSection c) -> c) -- ^ @opApp@ -> (a -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, a))])) -> a -> m (Maybe c)@@ -1746,7 +1800,7 @@ YesSection -> False NoSection (i, e) -> isLam e && preferParenless (appParens i) - doQNameHelper :: MonadToConcrete m => Either A.Name A.QName -> [MaybeSection (AppInfo, a)] -> m (Maybe c)+ doQNameHelper :: Either A.Name A.QName -> [MaybeSection (AppInfo, a)] -> m (Maybe c) doQNameHelper n args = do x <- either (C.QName <.> toConcrete) toConcrete n let n' = either id A.qnameName n@@ -1760,9 +1814,9 @@ PatternSynResName (q :| _) -> (q ^. lensFixity, Asp.Constructor Asp.Inductive) UnknownName -> (noFixity, Asp.Bound) List1.ifNull args {-then-} mDefault {-else-} $ \ as ->- doQName nk fx x n' as (C.nameParts $ C.unqualify x)+ doQName (nameAspects True nk n') fx x n' as (C.nameParts $ C.unqualify x) - doQName :: MonadToConcrete m => Asp.NameKind -> Fixity -> C.QName -> A.Name -> List1 (MaybeSection (AppInfo, a)) -> NameParts -> m (Maybe c)+ doQName :: Asp.Aspects -> Fixity -> C.QName -> A.Name -> List1 (MaybeSection (AppInfo, a)) -> NameParts -> m (Maybe c) -- fall-back (wrong number of arguments or no holes) doQName nk _ x _ as xs@@ -1853,7 +1907,7 @@ let isConP ConP{} = True -- #2828: only fold pattern synonyms with isConP _ = False -- constructor rhs cands = [ (q, args, score rhs)- | (q, psyndef@(_, rhs)) <- reverse $ Map.toList psyns+ | (q, psyndef@(PatternSynDefn _ rhs)) <- reverse $ Map.toList psyns , isConP rhs , Just args <- [match psyndef e] -- #3879: only fold pattern synonyms with an unqualified concrete name in scope
src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs view
@@ -16,3644 +16,4016 @@ import Prelude hiding ( null, (||) ) -import Control.Monad ( (>=>), (<=<), foldM, forM, forM_, zipWithM, zipWithM_ )-import Control.Applicative ( liftA2, liftA3 )-import Control.Monad.Except ( runExceptT, MonadError(..) )-import Control.Monad.State ( StateT, execStateT, get, put )-import Control.Monad.Trans.Maybe-import Control.Monad.Trans ( lift )--import Data.Bifunctor-import Data.Foldable (traverse_)-import Data.Set (Set)-import Data.Map (Map)-import Data.Functor (void)-import qualified Data.List as List-import qualified Data.Set as Set-import qualified Data.Map as Map-import qualified Data.HashSet as HashSet-import Data.Maybe-import Data.Void--import Agda.Syntax.Common-import qualified Agda.Syntax.Common.Pretty as P-import Agda.Syntax.Common.Pretty (render, Pretty, pretty, prettyShow)-import Agda.Syntax.Concrete as C-import Agda.Syntax.Concrete.Attribute as CA-import Agda.Syntax.Concrete.Generic-import Agda.Syntax.Concrete.Operators-import Agda.Syntax.Concrete.Pattern-import Agda.Syntax.Abstract as A-import Agda.Syntax.Abstract.Pattern as A- ( patternVars, checkPatternLinearity, containsAsPattern, lhsCoreApp, lhsCoreWith, noDotOrEqPattern )-import Agda.Syntax.Abstract.Pretty-import Agda.Syntax.Abstract.UsedNames- ( allUsedNames )-import qualified Agda.Syntax.Internal as I-import Agda.Syntax.Position-import Agda.Syntax.Literal-import Agda.Syntax.Info as Info-import Agda.Syntax.Concrete.Definitions as C-import Agda.Syntax.Fixity-import Agda.Syntax.Concrete.Fixity (DoWarn(..))-import Agda.Syntax.Notation-import Agda.Syntax.Scope.Base as A-import Agda.Syntax.Scope.Monad-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 hiding (topLevelModuleName)-import qualified Agda.TypeChecking.Monad.State as S-import Agda.TypeChecking.Monad.Signature (notUnderOpaque)-import Agda.TypeChecking.Monad.MetaVars (registerInteractionPoint)-import Agda.TypeChecking.Monad.Debug-import Agda.TypeChecking.Monad.Env (insideDotPattern, isInsideDotPattern, getCurrentPath)-import Agda.TypeChecking.Rules.Builtin (isUntypedBuiltin, bindUntypedBuiltin, builtinKindOfName)--import Agda.TypeChecking.Patterns.Abstract (expandPatternSynonyms)-import Agda.TypeChecking.Pretty hiding (pretty, prettyA)-import Agda.TypeChecking.Quote (quotedName)-import Agda.TypeChecking.Opacity-import Agda.TypeChecking.Warnings--import Agda.Interaction.FindFile (checkModuleName, rootNameModule, SourceFile(SourceFile))--- import Agda.Interaction.Imports -- for type-checking in ghci-import {-# SOURCE #-} Agda.Interaction.Imports (scopeCheckImport)-import Agda.Interaction.Options-import qualified Agda.Interaction.Options.Lenses as Lens-import Agda.Interaction.Options.Warnings--import qualified Agda.Utils.AssocList as AssocList-import Agda.Utils.Boolean ( (||), ifThenElse )-import Agda.Utils.CallStack ( HasCallStack, withCurrentCallStack )-import Agda.Utils.Char-import Agda.Utils.Either-import Agda.Utils.FileName-import Agda.Utils.Function ( applyWhen, applyWhenJust, applyWhenM, applyUnless )-import Agda.Utils.Functor-import Agda.Utils.Lens-import Agda.Utils.List-import Agda.Utils.List1 ( List1, pattern (:|) )-import Agda.Utils.List2 ( List2, pattern List2 )-import qualified Agda.Utils.List1 as List1-import qualified Agda.Utils.Map as Map-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Set1 ( Set1 )-import qualified Agda.Utils.Set1 as Set1-import Agda.Utils.Singleton-import Agda.Utils.Tuple--import Agda.Utils.Impossible ( __IMPOSSIBLE__ )-import Agda.ImpossibleTest (impossibleTest, impossibleTestReduceM)-import qualified Agda.Syntax.Common as A--{--------------------------------------------------------------------------- Exceptions- --------------------------------------------------------------------------}--notAnExpression :: (HasCallStack, MonadTCError m) => C.Expr -> m a-notAnExpression = locatedTypeError NotAnExpression--notAValidLetBinding :: (HasCallStack, MonadTCError m) => Maybe NotAValidLetBinding -> m a-notAValidLetBinding = locatedTypeError NotAValidLetBinding--{--------------------------------------------------------------------------- Helpers- --------------------------------------------------------------------------}--newtype RecordConstructorType = RecordConstructorType [C.Declaration]--instance ToAbstract RecordConstructorType where- type AbsOfCon RecordConstructorType = A.Expr- toAbstract (RecordConstructorType ds) = recordConstructorType ds---- | Compute the type of the record constructor (with bogus target type)-recordConstructorType :: [C.Declaration] -> ScopeM A.Expr-recordConstructorType decls =- -- Nicify all declarations since there might be fixity declarations after- -- the the last field. Use NoWarn to silence fixity warnings. We'll get- -- them again when scope checking the declarations to build the record- -- module.- niceDecls NoWarn decls $ buildType . takeFields- where- takeFields = List.dropWhileEnd notField-- notField NiceField{} = False- notField _ = True-- buildType :: [C.NiceDeclaration] -> ScopeM A.Expr- -- TODO: Telescope instead of Expr in abstract RecDef- buildType ds = do- -- 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-- makeBinding :: C.NiceDeclaration -> ScopeM (Maybe A.TypedBinding)- makeBinding d = do- let failure = typeError $ NotValidBeforeField d- r = getRange d- mkLet d = Just . A.TLet r <$> toAbstract (LetDef RecordLetDef d)- setCurrentRange r $ case d of-- C.NiceField r pr ab inst tac x (Arg ai t) -> do- fx <- getConcreteFixity x- ai <- checkFieldArgInfo True ai- let bv = Arg ai $ unnamed $ C.mkBinder $ (C.mkBoundName x fx) { bnameTactic = tac }- toAbstract $ C.TBind r (singleton bv) t-- -- Public open is allowed and will take effect when scope checking as- -- proper declarations.- C.NiceOpen r m dir -> do- mkLet $ C.NiceOpen r m dir{ publicOpen = Nothing }- C.NiceModuleMacro r p e x modapp open dir -> do- mkLet $ C.NiceModuleMacro r p e x modapp open- dir{ publicOpen = Nothing }-- -- Do some rudimentary matching here to get NotValidBeforeField instead- -- of NotAValidLetDecl.- C.NiceMutual _ _ _ _- [ C.FunSig _ _ _ _ macro _ _ _ _ _- , C.FunDef _ _ abstract _ _ _ _- [ C.Clause _ _ (C.LHS _p [] []) (C.RHS _) NoWhere [] ]- ] | abstract /= AbstractDef && macro /= MacroDef -> do- mkLet d-- C.NiceLoneConstructor{} -> failure- C.NiceMutual{} -> failure- -- TODO: some of these cases might be __IMPOSSIBLE__- C.Axiom{} -> failure- C.PrimitiveFunction{} -> failure- C.NiceModule{} -> failure- C.NiceImport{} -> failure- C.NicePragma{} -> failure- C.NiceRecSig{} -> failure- C.NiceDataSig{} -> failure- C.NiceFunClause{} -> failure- C.FunSig{} -> failure -- Note: these are bundled with FunDef in NiceMutual- C.FunDef{} -> failure- C.NiceDataDef{} -> failure- C.NiceRecDef{} -> failure- C.NicePatternSyn{} -> failure- C.NiceGeneralize{} -> failure- C.NiceUnquoteDecl{} -> failure- C.NiceUnquoteDef{} -> failure- C.NiceUnquoteData{} -> failure- C.NiceOpaque{} -> failure--checkModuleApplication- :: C.ModuleApplication- -> ModuleName- -> C.Name- -> C.ImportDirective- -> ScopeM (A.ModuleApplication, ScopeCopyInfo, A.ImportDirective)--checkModuleApplication (C.SectionApp _ tel m es) m0 x dir' = do- reportSDoc "scope.decl" 70 $ vcat $- [ text $ "scope checking ModuleApplication " ++ prettyShow x- ]-- -- For the following, set the current module to be m0.- withCurrentModule m0 $ do- -- Parse the raw arguments of the module application. (See issue #1245.)- args <- parseArguments (C.Ident m) es- -- Scope check the telescope (introduces bindings!).- tel' <- catMaybes <$> toAbstract tel- -- Scope check the old module name and the module args.- m1 <- toAbstract $ OldModuleName m- args' <- toAbstractCtx (ArgumentCtx PreferParen) args- -- Copy the scope associated with m and take the parts actually imported.- (adir, s) <- applyImportDirectiveM (C.QName x) dir' =<< getNamedScope m1- (s', copyInfo) <- copyScope m m0 s- -- Set the current scope to @s'@- modifyCurrentScope $ const s'- printScope "mod.inst" 40 "copied source module"- reportSDoc "scope.mod.inst" 30 $ return $ pretty copyInfo- let amodapp = A.SectionApp tel' m1 args'- reportSDoc "scope.decl" 70 $ vcat $- [ text $ "scope checked ModuleApplication " ++ prettyShow x- ]- reportSDoc "scope.decl" 70 $ vcat $- [ nest 2 $ prettyA amodapp- ]- return (amodapp, copyInfo, adir)--checkModuleApplication (C.RecordModuleInstance _ recN) m0 x dir' =- withCurrentModule m0 $ do- m1 <- toAbstract $ OldModuleName recN- s <- getNamedScope m1- (adir, s) <- applyImportDirectiveM recN dir' s- (s', copyInfo) <- copyScope recN m0 s- modifyCurrentScope $ const s'-- printScope "mod.inst" 40 "copied record module"- return (A.RecordModuleInstance m1, copyInfo, adir)---- | @checkModuleMacro mkApply range access concreteName modapp open dir@------ Preserves local variables.--checkModuleMacro- :: (ToConcrete a, Pretty (ConOfAbs a))- => (ModuleInfo- -> Erased- -> ModuleName- -> A.ModuleApplication- -> ScopeCopyInfo- -> A.ImportDirective- -> a)- -> OpenKind- -> Range- -> Access- -> Erased- -> C.Name- -> C.ModuleApplication- -> OpenShortHand- -> C.ImportDirective- -> ScopeM a-checkModuleMacro apply kind r p e x modapp open dir = do- reportSDoc "scope.decl" 70 $ vcat $- [ text $ "scope checking ModuleMacro " ++ prettyShow x- ]- dir <- notPublicWithoutOpen open dir-- m0 <- toAbstract (NewModuleName x)- reportSDoc "scope.decl" 90 $ "NewModuleName: m0 =" <+> prettyA m0-- printScope "mod.inst" 40 "module macro"-- -- If we're opening a /named/ module, the import directive is- -- applied to the "open", otherwise to the module itself. However,- -- "public" is always applied to the "open".- let (moduleDir, openDir) = case (open, isNoName x) of- (DoOpen, False) -> (defaultImportDir, dir)- (DoOpen, True) -> ( dir { publicOpen = Nothing }- , defaultImportDir { publicOpen = publicOpen dir }- )- (DontOpen, _) -> (dir, defaultImportDir)-- -- Restore the locals after module application has been checked.- (modapp', copyInfo, adir') <- withLocalVars $ checkModuleApplication modapp m0 x moduleDir- printScope "mod.inst.app" 40 "checkModuleMacro, after checkModuleApplication"-- reportSDoc "scope.decl" 90 $ "after mod app: trying to print m0 ..."- reportSDoc "scope.decl" 90 $ "after mod app: m0 =" <+> prettyA m0-- bindModule p x m0- reportSDoc "scope.decl" 90 $ "after bindMod: m0 =" <+> prettyA m0-- printScope "mod.inst.copy.after" 40 "after copying"-- -- Open the module if DoOpen.- -- Andreas, 2014-09-02: @openModule@ might shadow some locals!- adir <- case open of- DontOpen -> return adir'- DoOpen -> do- adir'' <- openModule kind (Just m0) (C.QName x) openDir- -- Andreas, 2020-05-14, issue #4656- -- Keep the more meaningful import directive for highlighting- -- (the other one is a defaultImportDir).- return $ if isNoName x then adir' else adir''-- printScope "mod.inst" 40 $ show open- reportSDoc "scope.decl" 90 $ "after open : m0 =" <+> prettyA m0-- stripNoNames- printScope "mod.inst.strip" 30 $ "after stripping"- reportSDoc "scope.decl" 90 $ "after stripNo: m0 =" <+> prettyA m0-- let m = m0 `withRangesOf` singleton x- adecl = apply info e m modapp' copyInfo adir-- reportSDoc "scope.decl" 70 $ vcat $- [ text $ "scope checked ModuleMacro " ++ prettyShow x- ]- reportSLn "scope.decl" 90 $ "info = " ++ show info- reportSLn "scope.decl" 90 $ "m = " ++ prettyShow m- reportSLn "scope.decl" 90 $ "modapp' = " ++ show modapp'- reportSDoc "scope.decl" 90 $ return $ pretty copyInfo- reportSDoc "scope.decl" 70 $ nest 2 $ prettyA adecl- return adecl- where- info = ModuleInfo- { minfoRange = r- , minfoAsName = Nothing- , minfoAsTo = renamingRange dir- , minfoOpenShort = Just open- , minfoDirective = Just dir- }---- | The @public@ keyword must only be used together with @open@.--notPublicWithoutOpen :: OpenShortHand -> C.ImportDirective -> ScopeM C.ImportDirective-notPublicWithoutOpen DoOpen = return-notPublicWithoutOpen DontOpen = uselessPublic UselessPublicNoOpen---- | Warn about useless @public@.--uselessPublic :: UselessPublicReason -> C.ImportDirective -> ScopeM C.ImportDirective-uselessPublic reason dir = do- whenJust (publicOpen dir) \ r ->- setCurrentRange r $ warning $ UselessPublic reason- return $ dir { publicOpen = Nothing }---- | Computes the range of all the \"to\" keywords used in a renaming--- directive.--renamingRange :: C.ImportDirective -> Range-renamingRange = getRange . map renToRange . impRenaming---- | Scope check a 'NiceOpen'.-checkOpen- :: Range -- ^ Range of @open@ statement.- -> Maybe A.ModuleName -- ^ Resolution of concrete module name (if already resolved).- -> C.QName -- ^ Module to open.- -> C.ImportDirective -- ^ Scope modifier.- -> ScopeM (ModuleInfo, A.ModuleName, A.ImportDirective) -- ^ Arguments of 'A.Open'-checkOpen r mam x dir = do- cm <- getCurrentModule- reportSDoc "scope.decl" 70 $ do- vcat $- [ text "scope checking NiceOpen " <> return (pretty x)- , text " getCurrentModule = " <> prettyA cm- , text $ " getCurrentModule (raw) = " ++ show cm- , text $ " C.ImportDirective = " ++ prettyShow dir- ]- -- Andreas, 2017-01-01, issue #2377: warn about useless `public`- dir <- if null cm then uselessPublic UselessPublicPreamble dir else return dir-- m <- caseMaybe mam (toAbstract (OldModuleName x)) return- printScope "open" 40 $ "opening " ++ prettyShow x- adir <- openModule TopOpenModule (Just m) x dir- printScope "open" 40 $ "result:"- let minfo = ModuleInfo- { minfoRange = r- , minfoAsName = Nothing- , minfoAsTo = renamingRange dir- , minfoOpenShort = Nothing- , minfoDirective = Just dir- }- let adecls = [A.Open minfo m adir]- reportSDoc "scope.decl" 70 $ vcat $- text ( "scope checked NiceOpen " ++ prettyShow x- ) : map (nest 2 . prettyA) adecls- return (minfo, m, adir)---- | Check a literal, issuing an error warning for bad literals.-checkLiteral :: Literal -> ScopeM ()-checkLiteral = \case- LitChar c -> when (isSurrogateCodePoint c) $ warning $ InvalidCharacterLiteral c- LitNat _ -> return ()- LitWord64 _ -> return ()- LitFloat _ -> return ()- LitString _ -> return ()- LitQName _ -> return ()- LitMeta _ _ -> return ()--{--------------------------------------------------------------------------- Translation- --------------------------------------------------------------------------}--concreteToAbstract_ :: ToAbstract c => c -> ScopeM (AbsOfCon c)-concreteToAbstract_ = toAbstract--concreteToAbstract :: ToAbstract c => ScopeInfo -> c -> ScopeM (AbsOfCon c)-concreteToAbstract scope x = withScope_ scope (toAbstract x)---- | Things that can be translated to abstract syntax are instances of this--- class.-class ToAbstract c where- type AbsOfCon c- toAbstract :: c -> ScopeM (AbsOfCon c)---- | This function should be used instead of 'toAbstract' for things that need--- to keep track of precedences to make sure that we don't forget about it.-toAbstractCtx :: ToAbstract c => Precedence -> c-> ScopeM (AbsOfCon c)-toAbstractCtx ctx c = withContextPrecedence ctx $ toAbstract c----UNUSED Liang-Ting Chen 2019-07-16---toAbstractTopCtx :: ToAbstract c a => c -> ScopeM a---toAbstractTopCtx = toAbstractCtx TopCtx--toAbstractHiding :: (LensHiding h, ToAbstract c) => h -> c -> ScopeM (AbsOfCon c)-toAbstractHiding h | visible h = toAbstract -- don't change precedence if visible-toAbstractHiding _ = toAbstractCtx TopCtx----UNUSED Liang-Ting Chen 2019-07-16---setContextCPS :: Precedence -> (a -> ScopeM b) ->--- ((a -> ScopeM b) -> ScopeM b) -> ScopeM b---setContextCPS p ret f = do--- old <- useScope scopePrecedence--- withContextPrecedence p $ f $ \ x -> setContextPrecedence old >> ret x------localToAbstractCtx :: ToAbstract c =>--- Precedence -> c -> (AbsOfCon -> ScopeM (AbsOfCon c)) -> ScopeM (AbsOfCon c)---localToAbstractCtx ctx c ret = setContextCPS ctx ret (localToAbstract c)---- | This operation does not affect the scope, i.e. the original scope--- is restored upon completion.-localToAbstract :: ToAbstract c => c -> (AbsOfCon c -> ScopeM b) -> ScopeM b-localToAbstract x ret = localScope $ ret =<< toAbstract x---- | Like 'localToAbstract' but returns the scope after the completion of the--- second argument.-localToAbstract' :: ToAbstract c => c -> (AbsOfCon c -> ScopeM b) -> ScopeM (b, ScopeInfo)-localToAbstract' x ret = do- scope <- getScope- withScope scope $ ret =<< toAbstract x--instance ToAbstract () where- type AbsOfCon () = ()- toAbstract = pure--instance (ToAbstract c1, ToAbstract c2) => ToAbstract (c1, c2) where- type AbsOfCon (c1, c2) = (AbsOfCon c1, AbsOfCon c2)- toAbstract (x,y) = (,) <$> toAbstract x <*> toAbstract y--instance (ToAbstract c1, ToAbstract c2, ToAbstract c3) => ToAbstract (c1, c2, c3) where- type AbsOfCon (c1, c2, c3) = (AbsOfCon c1, AbsOfCon c2, AbsOfCon c3)- toAbstract (x,y,z) = flatten <$> toAbstract (x,(y,z))- where- flatten (x,(y,z)) = (x,y,z)--instance ToAbstract c => ToAbstract [c] where- type AbsOfCon [c] = [AbsOfCon c]- toAbstract = mapM toAbstract--instance ToAbstract c => ToAbstract (List1 c) where- type AbsOfCon (List1 c) = List1 (AbsOfCon c)- toAbstract = mapM toAbstract--instance (ToAbstract c1, ToAbstract c2) => ToAbstract (Either c1 c2) where- type AbsOfCon (Either c1 c2) = Either (AbsOfCon c1) (AbsOfCon c2)- toAbstract = traverseEither toAbstract toAbstract--instance ToAbstract c => ToAbstract (Maybe c) where- type AbsOfCon (Maybe c) = Maybe (AbsOfCon c)- toAbstract = traverse toAbstract---- Names --------------------------------------------------------------------data NewName a = NewName- { newBinder :: A.BindingSource -- what kind of binder?- , newName :: a- } deriving (Functor)--data OldQName = OldQName- C.QName- -- ^ Concrete name to be resolved.- (Maybe (Set1 A.Name))- -- ^ If a set is given, then the first name must- -- correspond to one of the names in the set.---- | We sometimes do not want to fail hard if the name is not actually--- in scope because we have a strategy to recover from this problem--- (e.g. drop the offending COMPILE pragma)-data MaybeOldQName = MaybeOldQName OldQName---- | Wrapper for a concrete name that we already bound to an 'A.Def'.----newtype OldName a = OldName a---- | Wrapper to resolve a name in a pattern.-data PatName = PatName- C.QName- -- ^ Concrete name to be resolved in a pattern.- (Maybe (Set1 A.Name))- -- ^ If a set is given, then the first name must correspond to one- -- of the names in the set.- Hiding- -- ^ If pattern variable is hidden, its status is indicated in 'Hiding'.- DisplayLHS- -- ^ If we parse the lhs of a 'DisplayPragma',- -- names of arbitrary definitions count as constructors.--instance ToAbstract (NewName C.Name) where- type AbsOfCon (NewName C.Name) = A.Name- toAbstract (NewName b x) = do- y <- freshAbstractName_ x- bindVariable b x y- return y--instance ToAbstract (NewName C.BoundName) where- type AbsOfCon (NewName C.BoundName) = A.BindName- toAbstract NewName{ newBinder = b, newName = BName{ boundName = x, bnameFixity = fx }} = do- y <- freshAbstractName fx x- bindVariable b x y- return $ A.BindName y--instance ToAbstract OldQName where- type AbsOfCon OldQName = A.Expr- toAbstract q@(OldQName x _) =- fromMaybeM (notInScopeError x) $ toAbstract (MaybeOldQName q)--instance ToAbstract MaybeOldQName where- type AbsOfCon MaybeOldQName = Maybe A.Expr- toAbstract (MaybeOldQName (OldQName x ns)) = do- qx <- resolveName' allKindsOfNames ns x- reportSLn "scope.name" 30 $ "resolved " ++ prettyShow x ++ ": " ++ prettyShow qx- case qx of- VarName x' _ -> return $ Just $ A.Var x'- DefinedName _ d suffix -> do- raiseWarningsOnUsage $ anameName d- -- then we take note of generalized names used- addGeneralizable d- -- and then we return the name- return $ withSuffix suffix $ nameToExpr d- where- withSuffix NoSuffix e = Just e- withSuffix s@Suffix{} (A.Def x) = Just $ A.Def' x s- withSuffix _ _ = Nothing-- FieldName ds -> ambiguous (A.Proj ProjPrefix) ds- ConstructorName _ ds -> ambiguous A.Con ds- PatternSynResName ds -> ambiguous A.PatternSyn ds- UnknownName -> do- reportSLn "scope.name.unknown" 80 $ "resolved : unknown " ++ prettyShow x- pure Nothing- where- ambiguous :: (AmbiguousQName -> A.Expr) -> List1 AbstractName -> ScopeM (Maybe A.Expr)- ambiguous f ds = do- let xs = fmap anameName ds- raiseWarningsOnUsageIfUnambiguous xs- return $ Just $ f $ AmbQ xs-- -- Note: user warnings on ambiguous names will be raised by the type checker,- -- see 'storeDisambiguatedName'.- raiseWarningsOnUsageIfUnambiguous :: List1 A.QName -> ScopeM ()- raiseWarningsOnUsageIfUnambiguous = \case- x :| [] -> raiseWarningsOnUsage x- _ -> return ()---- | Resolve a name and fail hard if it is not in scope.----resolveQName :: C.QName -> ScopeM ResolvedName-resolveQName x = resolveName x >>= \case- UnknownName -> notInScopeError x- q -> q <$ addGeneralizable q- -- Issue #7575:- -- If the name is a @variable@, add it to the things we wish to generalize.- -- If generalization is not supported here, this will throw an error.---- | A name resolved in a pattern.-data APatName- = VarPatName A.Name- -- ^ Pattern variable.- | ConPatName (List1 AbstractName)- -- ^ A (possibly ambiguous) constructor.- -- When parsing a 'C.DisplayPragma', this can be the name of a definition.- | PatternSynPatName (List1 AbstractName)- -- ^ A (possibly ambiguous) pattern synonym.- | DefPatName AbstractName- -- ^ A defined name, only possible when checking a 'C.DisplayPragma'.--instance ToAbstract PatName where- type AbsOfCon PatName = APatName- toAbstract (PatName x ns h displayLhs) = do- reportSLn "scope.pat" 30 $ "checking pattern name: " ++ prettyShow x- let kinds = applyWhen displayLhs (defNameKinds ++) conLikeNameKinds- rx <- resolveName' (someKindsOfNames kinds) ns x- -- Andreas, 2013-03-21 ignore conflicting names which cannot- -- be meant since we are in a pattern- -- Andreas, 2020-04-11 CoConName:- -- coinductive constructors will be rejected later, in the type checker- reportSLn "scope.pat" 40 $ "resolved as " ++ prettyShow rx- case rx of- ConstructorName _ ds -> ConPatName ds <$ do- reportSLn "scope.pat" 30 $ "it was a con: " ++ prettyShow (fmap anameName ds)- PatternSynResName ds -> PatternSynPatName ds <$ do- reportSLn "scope.pat" 30 $ "it was a pat syn: " ++ prettyShow (fmap anameName ds)- DefinedName _ d suffix | YesDisplayLHS <- displayLhs, null suffix -> DefPatName d <$ do- reportSLn "scope.pat" 30 $ "it was a def: " ++ prettyShow (anameName d)- _ -> case x of- C.QName y -> VarPatName <$> bindPatternVariable h y- C.Qual{} -> typeError $ InvalidPattern $ C.IdentP True x---- | Translate and possibly bind a pattern variable--- (which could have been bound before due to non-linearity).-bindPatternVariable :: Hiding -> C.Name -> ScopeM A.Name-bindPatternVariable h x = do- y <- (AssocList.lookup x <$> getVarsToBind) >>= \case- Just (LocalVar y _ _) -> do- reportSLn "scope.pat" 30 $ "it was a old var: " ++ prettyShow x- return $ setRange (getRange x) y- Nothing -> do- reportSLn "scope.pat" 30 $ "it was a new var: " ++ prettyShow x- freshAbstractName_ x- addVarToBind x $ LocalVar y (PatternBound h) []- return y--class ToQName a where- toQName :: a -> C.QName--instance ToQName C.Name where toQName = C.QName-instance ToQName C.QName where toQName = id---- | Should be a defined name.-instance ToQName a => ToAbstract (OldName a) where- type AbsOfCon (OldName a) = A.QName- toAbstract (OldName x) = do- resolveName (toQName x) >>= \case- DefinedName _ d NoSuffix -> return $ anameName d- DefinedName _ d Suffix{} -> __IMPOSSIBLE__- VarName{} -> __IMPOSSIBLE__- UnknownName -> __IMPOSSIBLE__- -- We can get the cases below for DISPLAY pragmas- 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)--newtype NewModuleName = NewModuleName C.Name-newtype NewModuleQName = NewModuleQName C.QName-newtype OldModuleName = OldModuleName C.QName--freshQModule :: A.ModuleName -> C.Name -> ScopeM A.ModuleName-freshQModule m x = A.qualifyM m . mnameFromList1 . singleton <$> freshAbstractName_ x--checkForModuleClash :: C.Name -> ScopeM ()-checkForModuleClash x = do- ms :: [AbstractModule] <- scopeLookup (C.QName x) <$> getScope- List1.unlessNull ms \ ms -> do- reportSLn "scope.clash" 40 $ "clashing modules ms = " ++ prettyShow ms- reportSLn "scope.clash" 60 $ "clashing modules ms = " ++ show ms- setCurrentRange x $- typeError $ ShadowedModule x $ fmap ((`withRangeOf` x) . amodName) ms--instance ToAbstract NewModuleName where- type AbsOfCon NewModuleName = A.ModuleName- toAbstract (NewModuleName x) = do- checkForModuleClash x- m <- getCurrentModule- y <- freshQModule m x- createModule Nothing y- return y--instance ToAbstract NewModuleQName where- type AbsOfCon NewModuleQName = A.ModuleName- toAbstract (NewModuleQName m) = toAbs noModuleName m- where- toAbs m (C.QName x) = do- y <- freshQModule m x- createModule Nothing y- return y- toAbs m (C.Qual x q) = do- m' <- freshQModule m x- toAbs m' q--instance ToAbstract OldModuleName where- type AbsOfCon OldModuleName = A.ModuleName-- toAbstract (OldModuleName q) = setCurrentRange q $ do- amodName <$> resolveModule q---- Expressions ---------------------------------------------------------------UNUSED Liang-Ting Chen 2019-07-16----- | Peel off 'C.HiddenArg' and represent it as an 'NamedArg'.---mkNamedArg :: C.Expr -> NamedArg C.Expr---mkNamedArg (C.HiddenArg _ e) = Arg (hide defaultArgInfo) e---mkNamedArg (C.InstanceArg _ e) = Arg (makeInstance defaultArgInfo) e---mkNamedArg e = Arg defaultArgInfo $ unnamed e---- | Peel off 'C.HiddenArg' and represent it as an 'Arg', throwing away any name.-mkArg' :: ArgInfo -> C.Expr -> Arg C.Expr-mkArg' info (C.HiddenArg _ e) = Arg (hide info) $ namedThing e-mkArg' info (C.InstanceArg _ e) = Arg (makeInstance info) $ namedThing e-mkArg' info e = Arg (setHiding NotHidden info) e--inferParenPreference :: C.Expr -> ParenPreference-inferParenPreference C.Paren{} = PreferParen-inferParenPreference _ = PreferParenless---- | Parse a possibly dotted and braced @C.Expr@ as @A.Expr@,--- interpreting dots as relevance and braces as hiding.--- Only accept a layer of dotting/bracing if the respective accumulator is @Nothing@.-toAbstractDotHiding :: Maybe Relevance -> Maybe Hiding -> Precedence -> C.Expr -> ScopeM (A.Expr, Relevance, Hiding)-toAbstractDotHiding mr mh prec e = do- reportSLn "scope.irrelevance" 100 $ "toAbstractDotHiding: " ++ render (pretty e)- traceCall (ScopeCheckExpr e) $ case e of-- C.RawApp _ es -> toAbstractDotHiding mr mh prec =<< parseApplication es- C.Paren _ e -> toAbstractDotHiding mr mh TopCtx e-- C.Dot kwr e- | Nothing <- mr -> toAbstractDotHiding (Just $ Irrelevant $ OIrrDot $ getRange kwr) mh prec e-- C.DoubleDot kwr e- | Nothing <- mr -> toAbstractDotHiding (Just $ ShapeIrrelevant $ OShIrrDotDot $ getRange kwr) mh prec e-- C.HiddenArg _ (Named Nothing e)- | Nothing <- mh -> toAbstractDotHiding mr (Just Hidden) TopCtx e-- C.InstanceArg _ (Named Nothing e)- | Nothing <- mh -> toAbstractDotHiding mr (Just $ Instance NoOverlap) TopCtx e-- e -> (, fromMaybe relevant mr, fromMaybe NotHidden mh) <$>- toAbstractCtx prec e---- | Translate concrete expression under at least one binder into nested--- lambda abstraction in abstract syntax.-toAbstractLam :: Range -> List1 C.LamBinding -> C.Expr -> Precedence -> ScopeM A.Expr-toAbstractLam r bs e ctx = do- -- Translate the binders- lvars0 <- getLocalVars- localToAbstract (fmap (C.DomainFull . makeDomainFull) bs) $ \ bs -> do- lvars1 <- getLocalVars- checkNoShadowing lvars0 lvars1- -- Translate the body- e <- toAbstractCtx ctx e- -- We have at least one binder. Get first @b@ and rest @bs@.- return $ case List1.catMaybes bs of- -- Andreas, 2020-06-18- -- There is a pathological case in which we end up without binder:- -- λ (let- -- mutual -- warning: empty mutual block- -- ) -> Set- [] -> e- b:bs -> A.Lam (ExprRange r) b $ foldr mkLam e bs- where- mkLam b e = A.Lam (ExprRange $ fuseRange b e) b e---- | Scope check extended lambda expression.-scopeCheckExtendedLam ::- Range -> Erased -> List1 C.LamClause -> ScopeM A.Expr-scopeCheckExtendedLam r e cs = do- whenM isInsideDotPattern $ typeError $ NotAllowedInDotPatterns PatternLambdas-- -- Find an unused name for the extended lambda definition.- cname <- freshConcreteName r 0 extendedLambdaName- name <- freshAbstractName_ cname- a <- asksTC (^. lensIsAbstract)- reportSDoc "scope.extendedLambda" 30 $ vcat- [ text $ "new extended lambda name (" ++ show a ++ "): " ++ prettyShow name- ]- verboseS "scope.extendedLambda" 60 $ do- forM_ cs $ \ c -> do- reportSLn "scope.extendedLambda" 60 $ "extended lambda lhs: " ++ show (C.lamLHS c)- qname <- qualifyName_ name- bindName privateAccessInserted FunName cname qname-- -- Andreas, 2019-08-20- -- Keep the following __IMPOSSIBLE__, which is triggered by -v scope.decl.trace:80,- -- for testing issue #4016.- d <- C.FunDef r [] a NotInstanceDef __IMPOSSIBLE__ __IMPOSSIBLE__ cname . List1.toList <$> do- forM cs $ \ (LamClause ps rhs ca) -> do- let p = C.rawAppP $- killRange (IdentP True $ C.QName cname) :| ps- let lhs = C.LHS p [] []- return $ C.Clause cname ca lhs rhs NoWhere []- scdef <- toAbstract d-- -- Create the abstract syntax for the extended lambda.- case scdef of- A.ScopedDecl si [A.FunDef di qname' cs] -> do- setScope si -- This turns into an A.ScopedExpr si $ A.ExtendedLam...- return $- A.ExtendedLam (ExprRange r) di e qname' $- List1.fromListSafe __IMPOSSIBLE__ cs- _ -> __IMPOSSIBLE__---- | Scope check an expression.--instance ToAbstract C.Expr where- type AbsOfCon C.Expr = A.Expr-- toAbstract e =- traceCall (ScopeCheckExpr e) $ annotateExpr $ case e of-- -- Names- Ident x -> toAbstract (OldQName x Nothing)- KnownIdent _ x -> toAbstract (OldQName x Nothing)- -- Just discard the syntax highlighting information.-- -- Literals- C.Lit r l -> do- checkLiteral l- case l of- LitNat n -> do- let builtin | n < 0 = Just <$> primFromNeg -- negative literals are only allowed if FROMNEG is defined- | otherwise = ensureInScope =<< getBuiltin' builtinFromNat- builtin >>= \case- Just (I.Def q _) -> return $ mkApp q $ A.Lit i $ LitNat $ abs n- _ -> return alit-- LitString s -> do- getBuiltin' builtinFromString >>= ensureInScope >>= \case- Just (I.Def q _) -> return $ mkApp q alit- _ -> return alit-- _ -> return alit- where- i = ExprRange r- alit = A.Lit i l- mkApp q = A.App (defaultAppInfo r) (A.Def q) . defaultNamedArg-- -- #4925: Require fromNat/fromNeg to be in scope *unqualified* for literal overloading to- -- apply.- ensureInScope :: Maybe I.Term -> ScopeM (Maybe I.Term)- ensureInScope v@(Just (I.Def q _)) =- ifM (isNameInScopeUnqualified q <$> getScope) (return v) (return Nothing)- ensureInScope _ = return Nothing-- -- Meta variables- C.QuestionMark r n -> do- scope <- getScope- -- Andreas, 2014-04-06 create interaction point.- ii <- registerInteractionPoint True r n- let info = MetaInfo- { metaRange = r- , metaScope = scope- , metaNumber = Nothing- , metaNameSuggestion = ""- , metaKind = UnificationMeta- }- return $ A.QuestionMark info ii- C.Underscore r n -> do- scope <- getScope- return $ A.Underscore $ MetaInfo- { metaRange = r- , metaScope = scope- , metaNumber = __IMPOSSIBLE__ =<< n- , metaNameSuggestion = fromMaybe "" n- , metaKind = UnificationMeta- }-- -- Raw application- C.RawApp r es -> do- e <- parseApplication es- toAbstract e-- -- Application- C.App r e1 e2 -> do- -- Andreas, 2021-02-10, issue #3289: reject @e {.p}@ and @e ⦃ .p ⦄@.-- -- Raise an error if argument is a C.Dot with Hiding info.- case namedArg e2 of- C.Dot{} | notVisible e2 -> setCurrentRange e2 $ typeError $ IllegalHidingInPostfixProjection e2- _ -> return ()-- let parenPref = inferParenPreference (namedArg e2)- info = (defaultAppInfo r) { appOrigin = UserWritten, appParens = parenPref }- e1 <- toAbstractCtx FunctionCtx e1- e2 <- toAbstractCtx (ArgumentCtx parenPref) e2- return $ A.App info e1 e2-- -- Operator application- C.OpApp r op ns es -> toAbstractOpApp op ns es- C.KnownOpApp _ r op ns es -> toAbstractOpApp op ns es-- -- With application- C.WithApp r e es -> do- e <- toAbstractCtx WithFunCtx e- es <- mapM (toAbstractCtx WithArgCtx) es- return $ A.WithApp (ExprRange r) e es-- -- Misplaced hidden argument. We can treat these as parentheses and- -- raise an error-warning- C.HiddenArg _ e' -> do- warning (HiddenNotInArgumentPosition e)- toAbstract (namedThing e')-- C.InstanceArg _ e' -> do- warning (InstanceNotInArgumentPosition e)- toAbstract (namedThing e')-- -- Lambda- C.AbsurdLam r h -> return $ A.AbsurdLam (ExprRange r) h-- C.Lam r bs e -> toAbstractLam r bs e TopCtx-- -- Extended Lambda- C.ExtendedLam r e cs -> scopeCheckExtendedLam r e cs-- -- Relevant and irrelevant non-dependent function type- C.Fun r (Arg info1 e1) e2 -> do- let arg = mkArg' info1 e1- let mr = case getRelevance arg of- Relevant{} -> Nothing- r -> Just r- let mh = case getHiding arg of- NotHidden -> Nothing- h -> Just h- Arg info (e1', rel, hid) <- traverse (toAbstractDotHiding mr mh FunctionSpaceDomainCtx) arg- let updRel = applyUnless (isRelevant rel) $ setRelevance rel- let updHid = case hid of- NotHidden -> id- hid -> setHiding hid- A.Fun (ExprRange r) (Arg (updRel $ updHid info) e1') <$> toAbstractCtx TopCtx e2-- -- Dependent function type- e0@(C.Pi tel e) -> do- lvars0 <- getLocalVars- localToAbstract tel $ \tel -> do- lvars1 <- getLocalVars- checkNoShadowing lvars0 lvars1- e <- toAbstractCtx TopCtx e- let info = ExprRange (getRange e0)- return $ A.mkPi info (List1.catMaybes tel) e-- -- Let- e0@(C.Let _ ds (Just e)) ->- ifM isInsideDotPattern (typeError $ NotAllowedInDotPatterns LetExpressions) {-else-} do- localToAbstract (LetDefs ExprLetDef ds) $ \ds' -> do- e <- toAbstractCtx TopCtx e- let info = ExprRange (getRange e0)- return $ A.mkLet info ds' e- C.Let _ _ Nothing -> typeError $ NotAValidLetExpression MissingBody-- -- Record construction- C.Rec kwr r fs -> do- fs' <- toAbstractCtx TopCtx fs- let ds' = [ d | Right (_, Just d) <- fs' ]- fs'' = map (mapRight fst) fs'- i = ExprRange r- return $ A.mkLet i ds' (A.Rec kwr i fs'')-- -- Record update- C.RecUpdate kwr r e fs -> do- A.RecUpdate kwr (ExprRange r) <$> toAbstract e <*> toAbstractCtx TopCtx fs-- -- Parenthesis- C.Paren _ e -> toAbstractCtx TopCtx e-- -- Idiom brackets- C.IdiomBrackets r es ->- toAbstractCtx TopCtx =<< parseIdiomBracketsSeq r es-- -- Do notation- C.DoBlock r ss ->- toAbstractCtx TopCtx =<< desugarDoNotation r ss-- -- Post-fix projections- e0@(C.Dot _kwr e) -> A.Dot (ExprRange $ getRange e0) <$> toAbstract e-- -- Pattern things- C.As _ _ _ -> notAnExpression e- C.Absurd _ -> notAnExpression e-- -- Impossible things- C.Equal{} -> syntaxError "unexpected '='" -- triggered by 'f = (x = e)'- C.Ellipsis _ -> syntaxError "unexpected '...'" -- triggered by 'f = ...'- C.DoubleDot _ _ -> syntaxError "unexpected '..'" -- triggered by 'f = ..x'-- -- Quoting- C.Quote r -> return $ A.Quote (ExprRange r)- C.QuoteTerm r -> return $ A.QuoteTerm (ExprRange r)- C.Unquote r -> return $ A.Unquote (ExprRange r)-- C.Tactic r e -> syntaxError "'tactic' can only appear in attributes"-- -- DontCare- C.DontCare e -> A.DontCare <$> toAbstract e-- -- forall-generalize- C.Generalized e -> do- (s, e) <- collectGeneralizables $ toAbstract e- pure $ A.generalized s e--instance ToAbstract C.ModuleAssignment where- type AbsOfCon C.ModuleAssignment = (A.ModuleName, Maybe A.LetBinding)- toAbstract (C.ModuleAssignment m es i)- | null es && isDefaultImportDir i = (, Nothing) <$> toAbstract (OldModuleName m)- | otherwise = do- x <- C.NoName (getRange m) <$> fresh- r <- checkModuleMacro LetApply LetOpenModule- (getRange (m, es, i)) PublicAccess defaultErased x- (C.SectionApp (getRange (m , es)) [] m es)- DontOpen i- case r of- LetApply _ _ m' _ _ _ -> return (m', Just r)- _ -> __IMPOSSIBLE__--instance ToAbstract c => ToAbstract (FieldAssignment' c) where- type AbsOfCon (FieldAssignment' c) = FieldAssignment' (AbsOfCon c)-- toAbstract = traverse toAbstract--instance ToAbstract (C.Binder' (NewName C.BoundName)) where- type AbsOfCon (C.Binder' (NewName C.BoundName)) = A.Binder-- toAbstract (C.Binder p o n) = do- let name = C.boundName $ newName n-- -- If we do have a pattern then the variable needs to be inserted- -- so we do need a proper internal name for it.- --- -- Amy, 2024-10-18: If we generated a name, then mark the binder- -- name as being inserted.- (n, o) <- if not (isNoName name && isJust p) then pure (n, o) else do- n' <- freshConcreteName (getRange $ newName n) 0 patternInTeleName- pure (fmap (\ n -> n { C.boundName = n' }) n, InsertedBinderName)-- n <- toAbstract n- -- Expand puns if optHiddenArgumentPuns is True.- p <- traverse expandPunsOpt p- -- Actually parsing the pattern, checking it is linear,- -- and bind its variables- p <- traverse parsePattern p- p <- toAbstract p- checkPatternLinearity p $ \ys ->- typeError $ RepeatedVariablesInPattern ys- bindVarsToBind- p <- toAbstract p- pure $ A.Binder p o n--instance ToAbstract C.LamBinding where- type AbsOfCon C.LamBinding = Maybe A.LamBinding-- toAbstract (C.DomainFree x) = do- tac <- scopeCheckTactic x- Just . A.DomainFree tac <$> toAbstract (updateNamedArg (fmap $ NewName LambdaBound) x)- toAbstract (C.DomainFull tb) = fmap A.DomainFull <$> toAbstract tb---- | Scope check tactic attribute, make sure they are only used in hidden arguments.-scopeCheckTactic :: NamedArg C.Binder -> ScopeM A.TacticAttribute-scopeCheckTactic x = do- let ctac = bnameTactic $ C.binderName $ namedArg x- let r = getRange ctac- setCurrentRange r $ do- tac <- traverse toAbstract ctac- if null tac || hidden x then return tac else empty <$ warning UselessTactic--makeDomainFull :: C.LamBinding -> C.TypedBinding-makeDomainFull (C.DomainFull b) = b-makeDomainFull (C.DomainFree x) = C.TBind r (singleton x) $ C.Underscore r Nothing- where r = getRange x--instance ToAbstract C.TypedBinding where- type AbsOfCon C.TypedBinding = Maybe A.TypedBinding-- toAbstract (C.TBind r xs t) = do- t' <- toAbstractCtx TopCtx t- -- Invariant: all tactics are the same- -- (distributed in the parser, TODO: don't)- let tacArg = List1.find (not . null . bnameTactic . C.binderName . namedArg) xs- tac <- maybe (pure empty) scopeCheckTactic tacArg-- let fin = all (bnameIsFinite . C.binderName . namedArg) xs- xs' <- toAbstract $ fmap (updateNamedArg (fmap $ NewName LambdaBound)) xs-- return $ Just $ A.TBind r (TypedBindingInfo tac fin) xs' t'- toAbstract (C.TLet r ds) = A.mkTLet r <$> toAbstract (LetDefs ExprLetDef ds)---- | Scope check a module (top level function).----scopeCheckNiceModule- :: Range- -> Access- -> Erased- -> C.Name- -> C.Telescope- -> ScopeM [A.Declaration]- -> ScopeM A.Declaration- -- ^ The returned declaration is an 'A.Section'.-scopeCheckNiceModule r p e name tel checkDs = do- -- Andreas, 2025-03-29: clear @envCheckingWhere@- -- We are no longer directly in a @where@ block if we enter a module.- localTC (\ env -> env{ envCheckingWhere = C.NoWhere_ }) $- checkWrappedModules p (splitModuleTelescope tel)- where- -- Andreas, 2013-12-10:- -- If the module telescope contains open statements- -- or module macros (Issue 1299),- -- add an extra anonymous module around the current one.- -- Otherwise, the open statements would create- -- identifiers in the parent scope of the current module.- -- But open statements in the module telescope should- -- only affect the current module!- -- Ulf, 2024-11-21 (#7440): We need the wrapper module to have to correct parameters, otherwise- -- open public of a module created in the telescope will behave incorrectly when applying the- -- outer module.- splitModuleTelescope :: C.Telescope -> [C.Telescope]- splitModuleTelescope [] = [[]]- splitModuleTelescope (b : tel) =- case b of- C.TLet _ ds | any needsWrapper ds -> [] : addBind b (splitModuleTelescope tel)- _ -> addBind b $ splitModuleTelescope tel- where- addBind b (tel : ms) = (b : tel) : ms- addBind _ [] = __IMPOSSIBLE__-- needsWrapper C.ModuleMacro{} = True- needsWrapper C.Open{} = True- needsWrapper C.Import{} = True -- not __IMPOSSIBLE__, see Issue #1718- -- However, it does not matter what we return here, as this will- -- become an error later: "Not a valid let-declaration".- -- (Andreas, 2015-11-17)- needsWrapper (C.Mutual _ ds) = any needsWrapper ds- needsWrapper (C.Abstract _ ds) = any needsWrapper ds- needsWrapper (C.Private _ _ ds) = any needsWrapper ds- needsWrapper _ = False-- checkWrappedModules :: Access -> [C.Telescope] -> ScopeM A.Declaration- checkWrappedModules _ [] = __IMPOSSIBLE__- checkWrappedModules p [tel] = scopeCheckNiceModule_ r p name tel checkDs- checkWrappedModules p (tel : tels) =- scopeCheckNiceModule_ r p noName_ tel $ singleton <$>- checkWrappedModules PublicAccess tels -- Inner modules are PublicAccess (see #4350)-- -- The actual workhorse:- scopeCheckNiceModule_ :: Range -> Access -> C.Name -> C.Telescope -> ScopeM [A.Declaration] -> ScopeM A.Declaration- scopeCheckNiceModule_ r p name tel checkDs = do-- -- Check whether we are dealing with an anonymous module.- -- This corresponds to a Coq/LEGO section.- (name, p', open) <- do- if isNoName name then do- (i :: NameId) <- fresh- return (C.NoName (getRange name) i, privateAccessInserted, True)- else return (name, p, False)-- -- Check and bind the module, using the supplied check for its contents.- aname <- toAbstract (NewModuleName name)- d <- snd <$> do- scopeCheckModule r e (C.QName name) aname tel checkDs- bindModule p' name aname-- -- If the module was anonymous open it public- -- unless it's private, in which case we just open it (#2099)- when open $- void $ -- We can discard the returned default A.ImportDirective.- openModule TopOpenModule (Just aname) (C.QName name) $- defaultImportDir { publicOpen = boolToMaybe (p == PublicAccess) empty }- return d---- | We for now disallow let-bindings in @data@ and @record@ telescopes.--- This due "nested datatypes"; there is no easy interpretation of--- @--- data D (A : Set) (open M A) (b : B) : Set where--- c : D (A × A) b → D A b--- @--- where @B@ is brought in scope by @open M A@.--class EnsureNoLetStms a where- ensureNoLetStms :: a -> ScopeM ()-- default ensureNoLetStms :: (Foldable t, EnsureNoLetStms b, t b ~ a) => a -> ScopeM ()- ensureNoLetStms = traverse_ ensureNoLetStms--instance EnsureNoLetStms C.Binder where- ensureNoLetStms arg@(C.Binder p _ n) =- when (isJust p) $ typeError $ IllegalPatternInTelescope arg--instance EnsureNoLetStms C.TypedBinding where- ensureNoLetStms = \case- tb@C.TLet{} -> typeError $ IllegalLetInTelescope tb- C.TBind _ xs _ -> traverse_ (ensureNoLetStms . namedArg) xs--instance EnsureNoLetStms a => EnsureNoLetStms (LamBinding' a) where- ensureNoLetStms = \case- -- GA: DO NOT use traverse here: `LamBinding'` only uses its parameter in- -- the DomainFull constructor so we would miss out on some potentially- -- illegal lets! Cf. #4402- C.DomainFree a -> ensureNoLetStms a- C.DomainFull a -> ensureNoLetStms a--instance EnsureNoLetStms a => EnsureNoLetStms (Named_ a) where-instance EnsureNoLetStms a => EnsureNoLetStms (NamedArg a) where-instance EnsureNoLetStms a => EnsureNoLetStms [a] where----- | Returns the scope inside the checked module.-scopeCheckModule- :: Range -- ^ The range of the module.- -> Erased -- ^ Is the module erased?- -> C.QName -- ^ The concrete name of the module.- -> A.ModuleName -- ^ The abstract name of the module.- -> C.Telescope -- ^ The module telescope.- -> ScopeM [A.Declaration] -- ^ The code for checking the module contents.- -> ScopeM (ScopeInfo, A.Declaration)- -- ^ The returned declaration is an 'A.Section'.-scopeCheckModule r e x qm tel checkDs = do- printScope "module" 40 $ "checking module " ++ prettyShow x- -- Andreas, 2013-12-10: Telescope does not live in the new module- -- but its parent, so check it before entering the new module.- -- This is important for Nicolas Pouillard's open parametrized modules- -- statements inside telescopes.- res <- withLocalVars $ do- tel <- toAbstract (GenTel tel)- withCurrentModule qm $ do- -- pushScope m- -- qm <- getCurrentModule- printScope "module" 40 $ "inside module " ++ prettyShow x- ds <- checkDs- scope <- getScope- return (scope, A.Section r e (qm `withRangesOfQ` x) tel ds)-- -- Binding is done by the caller- printScope "module" 40 $ "after module " ++ prettyShow x- return res---- | Temporary data type to scope check a file.-data TopLevel a = TopLevel- { topLevelSourceFile :: SourceFile- -- ^ The file from which we loaded this module.- , topLevelExpectedName :: TopLevelModuleName- -- ^ The expected module name- -- (coming from the import statement that triggered scope checking this file).- , topLevelTheThing :: a- -- ^ The file content.- }--data TopLevelInfo = TopLevelInfo- { topLevelDecls :: [A.Declaration]- , topLevelScope :: ScopeInfo -- ^ as seen from inside the module- }---- | The top-level module name.--topLevelModuleName :: TopLevelInfo -> A.ModuleName-topLevelModuleName = (^. scopeCurrent) . topLevelScope---- | Top-level declarations are always--- @--- (import|open)* -- a bunch of possibly opened imports--- module ThisModule ... -- the top-level module of this file--- @-instance ToAbstract (TopLevel [C.Declaration]) where- type AbsOfCon (TopLevel [C.Declaration]) = TopLevelInfo-- toAbstract (TopLevel src expectedMName ds) =- -- A file is a bunch of preliminary decls (imports etc.)- -- plus a single module decl.- case C.spanAllowedBeforeModule ds of-- -- If there are declarations after the top-level module- -- we have to report a parse error here.- (_, C.Module{} : d : _) -> setCurrentRange d $ typeError DeclarationsAfterTopLevelModule-- -- Otherwise, proceed.- (outsideDecls, [ C.Module r e m0 tel insideDecls ]) -> do- -- If the module name is _ compute the name from the file path- (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- -- name as the file. In this case, it is highly likely that the user- -- put some non-allowed declarations before the top-level module in error.- -- Andreas, 2017-10-19, issue #2808- -- Widen this check to:- -- If the first module of the insideDecls has the same name as the file,- -- report an error.- case flip span insideDecls $ \case { C.Module{} -> False; _ -> True } of- (ds0, (C.Module _ _ m1 _ _ : _))- | 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.- , r == beginningOfFile (getRange insideDecls) -> do-- -- GA #4888: We know we are in a bad place. But we still scopecheck- -- the initial segment on the off chance we generate a better error- -- message.- void importPrimitives- void $ toAbstract (Declarations outsideDecls)- void $ toAbstract (Declarations ds0)- -- Fail with a crude error otherwise- setCurrentRange ds0 $ typeError IllegalDeclarationBeforeTopLevelModule-- -- Otherwise, reconstruct the top-level module name- _ -> do- file <- srcFilePath src- 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- -- -- its import. For flat file structures, this is the same.- -- -- For hierarchical file structures, this reverses the behavior:- -- -- Loading the file by itself will fail, but it can be imported.- -- -- The previous behavior is: it can be loaded by itself, but not- -- -- be imported- -- then return $ C.fromTopLevelModuleName expectedMName- else do- -- Andreas, 2014-03-28 Issue 1078- -- We need to check the module name against the file name here.- -- Otherwise one could sneak in a lie and confuse the scope- -- checker.- top <- S.topLevelModuleName- (rawTopLevelModuleNameForQName m0)- checkModuleName top src (Just expectedMName)- return (m0, top)- setTopLevelModule top- am <- toAbstract (NewModuleQName m)- primitiveImport <- importPrimitives- -- Scope check the declarations outside- outsideDecls <- toAbstract (Declarations outsideDecls)- (insideScope, insideDecl) <- scopeCheckModule r e m am tel $- toAbstract (Declarations insideDecls)- -- Andreas, 2020-05-13, issue #1804, #4647- -- Do not eagerly remove private definitions, only when serializing- -- let scope = over scopeModules (fmap $ restrictLocalPrivate am) insideScope- let scope = insideScope- setScope scope-- -- While scope-checking the top-level module we might have- -- encountered several (possibly nested) opaque blocks. We- -- must now ensure that these have transitively-closed- -- unfolding sets.- saturateOpaqueBlocks-- return $ TopLevelInfo (primitiveImport ++ outsideDecls ++ [ insideDecl ]) scope-- -- We already inserted the missing top-level module, see- -- 'Agda.Syntax.Parser.Parser.figureOutTopLevelModule',- -- thus, this case is impossible:- _ -> __IMPOSSIBLE__---- | Declaration @open import Agda.Primitive using (Set)@ when 'optImportSorts'.--- @Prop@ is added when 'optProp', and @SSet@ when 'optTwoLevel'.-importPrimitives :: ScopeM [A.Declaration]-importPrimitives = do- ifNotM (optImportSorts <$> pragmaOptions) (return []) {- else -} do- prop <- optProp <$> pragmaOptions- twoLevel <- optTwoLevel <$> pragmaOptions- -- Add implicit `open import Agda.Primitive using (Prop; Set; SSet)`- let agdaPrimitiveName = Qual (C.simpleName "Agda") $ C.QName $ C.simpleName "Primitive"- usingDirective = map (ImportedName . C.simpleName) $ concat- [ [ "Prop" | prop ]- , [ "Set" | True ]- , [ "SSet" | twoLevel ]- ]- directives = ImportDirective noRange (Using usingDirective) [] [] Nothing- importAgdaPrimitive = [C.Import noRange agdaPrimitiveName Nothing C.DoOpen directives]- toAbstract (Declarations importAgdaPrimitive)---- | runs Syntax.Concrete.Definitions.niceDeclarations on main module-niceDecls :: DoWarn -> [C.Declaration] -> ([NiceDeclaration] -> ScopeM a) -> ScopeM a-niceDecls warn ds ret = setCurrentRange ds $ computeFixitiesAndPolarities warn ds $ do-- -- Some pragmas are not allowed in safe mode unless we are in a builtin module.- -- So we need to tell the nicifier whether it should yell about unsafe pragmas.- isSafe <- Lens.getSafeMode <$> pragmaOptions- safeButNotBuiltin <- and2M- -- NB: BlockArguments allow bullet-point style argument lists using @do@, hehe!- do pure isSafe- do not <$> do isBuiltinModuleWithSafePostulates . fromMaybe __IMPOSSIBLE__ =<< asksTC envCurrentPath-- -- We need to pass the fixities to the nicifier for clause grouping.- fixs <- useScope scopeFixities- niceEnv <- NiceEnv safeButNotBuiltin <$> asksTC envCheckingWhere-- -- Run nicifier.- let (result, warns) = runNice niceEnv $ niceDeclarations fixs ds-- -- Respect the @DoWarn@ directive. For this to be sound, we need to know for- -- sure that each @Declaration@ is checked at least once with @DoWarn@.- unless (warn == NoWarn || null warns) $ do- -- If there are some warnings and the --safe flag is set,- -- we check that none of the NiceWarnings are fatal- when isSafe $ do- let (errs, ws) = List.partition unsafeDeclarationWarning warns- -- If some of them are, we fail- List1.unlessNull errs \ errs -> do- List1.unlessNull ws \ ws -> warnings $ fmap NicifierIssue ws- tcerrs <- mapM (warning_ . NicifierIssue) errs- setCurrentRange errs $ typeError $ NonFatalErrors $ Set1.fromList tcerrs- -- Otherwise we simply record the warnings- mapM_ (\ w -> warning' (dwLocation w) $ NicifierIssue w) warns- case result of- Left (DeclarationException loc e) -> do- reportSLn "error" 2 $ "Error raised at " ++ prettyShow loc- setCurrentRange e $ typeError $ NicifierError e- Right ds -> ret ds---- | Wrapper to avoid instance conflict with generic list instance.-newtype Declarations = Declarations [C.Declaration]--instance ToAbstract Declarations where- type AbsOfCon Declarations = [A.Declaration]-- toAbstract (Declarations ds) = niceDecls DoWarn ds toAbstract---- | Where did these 'LetDef's come from?-data LetDefOrigin- = ExprLetDef- -- ^ A let expression or do statement- | RecordWhereLetDef- -- ^ A @record where@ expression- | RecordLetDef- -- ^ Definitions in a record declaration, before the last field- deriving (Eq, Show)--data LetDefs = LetDefs LetDefOrigin (List1 C.Declaration)-data LetDef = LetDef LetDefOrigin NiceDeclaration--instance ToAbstract LetDefs where- type AbsOfCon LetDefs = [A.LetBinding]-- toAbstract :: LetDefs -> ScopeM (AbsOfCon LetDefs)- toAbstract (LetDefs wh ds) =- List1.concat <$> niceDecls DoWarn (List1.toList ds) (toAbstract . map (LetDef wh))---- | Raise appropriate (error-)warnings for if a declaration with--- illegal access, macro flag, or abstractness appear in a let--- expression.-checkLetDefInfo :: LetDefOrigin -> Access -> IsMacro -> IsAbstract -> ScopeM ()-checkLetDefInfo wh access macro abstract = do- when (abstract == AbstractDef) $ warning AbstractInLetBindings-- when (macro == MacroDef) $ warning MacroInLetBindings-- case access of- -- Marking a let declaration as private should only raise a warning- -- in explicit, user-written expressions.- --- -- It should not raise a warning when scope-checking the type of a- -- record constructor (it has an effect there), or when elaborating- -- the lets generated by a 'record where' expression.- PrivateAccess rng _- | wh == ExprLetDef -> scopeWarning (UselessPrivate rng)- _ -> pure ()--instance ToAbstract LetDef where- type AbsOfCon LetDef = List1 A.LetBinding- toAbstract :: LetDef -> ScopeM (AbsOfCon LetDef)- toAbstract (LetDef wh d) = setCurrentRange d case d of- NiceMutual _ _ _ _ d@[C.FunSig _ access _ instanc macro info _ _ x t, C.FunDef _ _ abstract _ _ _ _ [cl]] -> do- checkLetDefInfo wh access macro abstract-- t <- toAbstract t- -- We bind the name here to make sure it's in scope for the LHS (#917).- -- It's unbound for the RHS in letToAbstract.- fx <- getConcreteFixity x-- x <- A.unBind <$> toAbstract (NewName LetBound $ mkBoundName x fx)- (x', e) <- letToAbstract cl-- -- There are sometimes two instances of the let-bound variable,- -- one declaration and one definition (see issue #1618).- -- Andreas, 2015-08-27 keeping both the range of x and x' solves Issue 1618.- -- The situation is- -- @- -- let y : t- -- y = e- -- @- -- and we need to store the ranges of both occurences of y so that- -- the highlighter does the right thing.- let x2 = setRange (fuseRange x x') x-- -- If InstanceDef set info to Instance- let info' = case instanc of- InstanceDef _ -> makeInstance info- NotInstanceDef -> info-- return $- A.LetBind (LetRange $ getRange d) info' (A.mkBindName x2) t e :|- []-- -- Function signature without a body- C.Axiom _ acc abs instanc info x t -> do- checkLetDefInfo wh acc NotMacroDef abs-- t <- toAbstract t- fx <- getConcreteFixity x- x <- toAbstract (NewName LetBound $ mkBoundName x fx)-- let- info' = case instanc of- InstanceDef _ -> makeInstance info- NotInstanceDef -> info-- pure $ A.LetAxiom (LetRange $ getRange d) info' x t :| []-- -- irrefutable let binding, like (x , y) = rhs- NiceFunClause r PublicAccess ConcreteDef tc cc catchall d@(C.FunClause lhs@(C.LHS p0 [] []) rhs0 whcl ca) -> do- noWhereInLetBinding whcl- rhs <- letBindingMustHaveRHS rhs0- -- Expand puns if optHiddenArgumentPuns is True.- p0 <- expandPunsOpt p0- mp <- setCurrentRange p0 $- (Right <$> parsePattern p0)- `catchError`- (return . Left)- case mp of- Right p -> do- rhs <- toAbstract rhs- setCurrentRange p0 $ do- p <- toAbstract p- checkValidLetPattern p- checkPatternLinearity p $ \ys ->- typeError $ RepeatedVariablesInPattern ys- bindVarsToBind- p <- toAbstract p- return $ singleton $ A.LetPatBind (LetRange r) p rhs- -- It's not a record pattern, so it should be a prefix left-hand side- Left err ->- case definedName p0 of- Nothing -> throwError err- Just x -> toAbstract $ LetDef wh $ NiceMutual empty tc cc YesPositivityCheck- [ C.FunSig r PublicAccess ConcreteDef NotInstanceDef NotMacroDef- (setOrigin Inserted defaultArgInfo) tc cc x (C.Underscore (getRange x) Nothing)- , C.FunDef r __IMPOSSIBLE__ ConcreteDef NotInstanceDef __IMPOSSIBLE__ __IMPOSSIBLE__ __IMPOSSIBLE__- [C.Clause x (ca <> catchall) lhs (C.RHS rhs) NoWhere []]- ]- where- definedName (C.IdentP _ (C.QName x)) = Just x- definedName C.IdentP{} = Nothing- definedName (C.RawAppP _ (List2 p _ _)) = definedName p- definedName (C.ParenP _ p) = definedName p- definedName C.WildP{} = Nothing -- for instance let _ + x = x in ... (not allowed)- definedName C.AbsurdP{} = Nothing- definedName C.AsP{} = Nothing- definedName C.DotP{} = Nothing- definedName C.EqualP{} = Nothing- definedName C.LitP{} = Nothing- definedName C.RecP{} = Nothing- definedName C.QuoteP{} = Nothing- definedName C.HiddenP{} = Nothing -- Not impossible, see issue #2291- definedName C.InstanceP{} = Nothing- definedName C.WithP{} = Nothing- definedName C.AppP{} = Nothing -- Not impossible, see issue #4586- definedName C.OpAppP{} = __IMPOSSIBLE__- definedName C.EllipsisP{} = Nothing -- Not impossible, see issue #3937-- -- You can't open public in a let- NiceOpen r x dir -> do- dir <- uselessPublic UselessPublicLet dir- m <- toAbstract (OldModuleName x)- adir <- openModule_ LetOpenModule x dir- let minfo = ModuleInfo- { minfoRange = r- , minfoAsName = Nothing- , minfoAsTo = renamingRange dir- , minfoOpenShort = Nothing- , minfoDirective = Just dir- }- return $ singleton $ A.LetOpen minfo m adir-- NiceModuleMacro r p erased x modapp open dir -> do- dir <- uselessPublic UselessPublicLet dir- -- Andreas, 2014-10-09, Issue 1299: module macros in lets need- -- to be private- singleton <$> checkModuleMacro LetApply LetOpenModule r- privateAccessInserted erased x modapp open dir-- _ -> notAValidLetBinding Nothing-- where- letToAbstract (C.Clause top _catchall (C.LHS p [] []) rhs0 wh []) = do- noWhereInLetBinding wh- rhs <- letBindingMustHaveRHS rhs0- (x, args) <- do- res <- setCurrentRange p $ parseLHS NoDisplayLHS (C.QName top) p- case res of- C.LHSHead x args -> return (x, args)- C.LHSProj{} -> __IMPOSSIBLE__ -- notAValidLetBinding $ Just CopatternsNotAllowed- C.LHSWith{} -> __IMPOSSIBLE__ -- notAValidLetBinding $ Just WithPatternsNotAllowed- C.LHSEllipsis{} -> __IMPOSSIBLE__ -- notAValidLetBinding $ Just EllipsisNotAllowed-- e <- localToAbstract args $ \args -> do- bindVarsToBind- -- Make sure to unbind the function name in the RHS, since lets are non-recursive.- rhs <- unbindVariable top $ toAbstract rhs- foldM lambda rhs (reverse args) -- just reverse because these are DomainFree- return (x, e)-- letToAbstract _ = notAValidLetBinding Nothing-- -- These patterns all have a chance of being accepted in a lambda:- allowedPat A.VarP{} = True- allowedPat A.ConP{} = True- allowedPat A.WildP{} = True- allowedPat (A.AsP _ _ x) = allowedPat x- allowedPat (A.RecP _ _ as) = all (allowedPat . view exprFieldA) as- allowedPat (A.PatternSynP _ _ as) = all (allowedPat . namedArg) as-- -- These have no chance:- allowedPat A.AbsurdP{} = False- allowedPat A.ProjP{} = False- allowedPat A.DefP{} = False- allowedPat A.EqualP{} = False- allowedPat A.WithP{} = False- allowedPat A.DotP{} = False- allowedPat A.LitP{} = False-- patternName (A.VarP bn) = Just bn- patternName (A.AsP _ bn _) = Just bn- patternName _ = Nothing-- -- Named patterns not allowed in let definitions- lambda :: A.Expr -> A.NamedArg (A.Pattern' C.Expr) -> TCM A.Expr- lambda e ai@(Arg info (Named thing pat)) | allowedPat pat = do- let- i = ExprRange (fuseRange pat e)-- pat <- toAbstract pat-- bn <- case pat of- A.VarP bn -> pure bn- A.AsP _ bn _ -> pure bn- _ -> fmap mkBindName . freshAbstractName_ =<< freshConcreteName (getRange pat) 0 patternInTeleName-- -- Annoyingly, for the lambdas to be elaborated properly, we- -- have to generate domainful binders. Domain-free binders can- -- not be named (or have pattern matching!).- --- -- Moreover, we need to avoid generating named patterns that are- -- like {B = B @ B}.-- let- pat' = case pat of- A.VarP{} -> Nothing- pat -> Just pat- binder = Arg info (Named thing (A.Binder pat' InsertedBinderName bn)) :| []-- pure $ A.Lam i (A.DomainFull (A.TBind (getRange ai) empty binder (A.Underscore empty))) e-- lambda _ _ = notAValidLetBinding Nothing-- noWhereInLetBinding :: C.WhereClause -> ScopeM ()- noWhereInLetBinding = \case- NoWhere -> return ()- wh -> setCurrentRange wh $ notAValidLetBinding $ Just WhereClausesNotAllowed- letBindingMustHaveRHS :: C.RHS -> ScopeM C.Expr- letBindingMustHaveRHS = \case- C.RHS e -> return e- C.AbsurdRHS -> notAValidLetBinding $ Just MissingRHS-- -- Only record patterns allowed, but we do not exclude data constructors here.- -- They will fail in the type checker.- checkValidLetPattern :: A.Pattern' e -> ScopeM ()- checkValidLetPattern a = unless (allowedPat a) do- notAValidLetBinding $ Just NotAValidLetPattern--checkFieldArgInfo :: Bool -> ArgInfo -> ScopeM ArgInfo-checkFieldArgInfo warn =- ensureContinuous msg >=>- ensureMixedPolarity msg- where- msg = if warn then Just "of field" else Nothing--instance ToAbstract NiceDeclaration where- type AbsOfCon NiceDeclaration = A.Declaration-- toAbstract d = annotateDecls $- traceS "scope.decl.trace" 50- [ "scope checking declaration"- , " " ++ prettyShow d- ] $- traceS "scope.decl.trace" 80 -- keep this debug message for testing issue #4016- [ "scope checking declaration (raw)"- , " " ++ show d- ] $- traceCall (ScopeCheckDeclaration d) $- -- Andreas, 2015-10-05, Issue 1677:- -- We record in the environment whether we are scope checking an- -- abstract definition. This way, we can propagate this attribute- -- the extended lambdas.- applyWhenJust (niceHasAbstract d) (\ a -> localTC $ \ e -> e { envAbstractMode = aDefToMode a }) $- case d of-- -- Axiom (actual postulate)- C.Axiom r p a i rel x t -> do- (y, decl) <- toAbstractNiceAxiom AxiomName d- -- check that we do not postulate in --safe mode, unless it is a- -- builtin module with safe postulates, or the axiom is generated- -- from a lone signature- whenM (andM [ Lens.getSafeMode <$> commandLineOptions- , not <$> (isBuiltinModuleWithSafePostulates . fromMaybe __IMPOSSIBLE__ =<< asksTC envCurrentPath)- , pure $ getOrigin rel /= Inserted- ])- (warning $ SafeFlagPostulate y)- -- check the postulate- return $ singleton decl-- C.NiceGeneralize r p i tac x t -> do- reportSLn "scope.decl" 30 $ "found nice generalize: " ++ prettyShow x- tac <- traverse (toAbstractCtx TopCtx) tac- t_ <- toAbstractCtx TopCtx t- let (s, t) = unGeneralized t_- reportSLn "scope.decl" 50 $ "generalizations: " ++ show (Set.toList s, t)- f <- getConcreteFixity x- y <- freshAbstractQName f x- bindName p GeneralizeName x y- let info = (mkDefInfo x f p ConcreteDef r) { defTactic = tac }- return [A.Generalize s info i y t]-- -- Fields- C.NiceField r p a i tac x (Arg ai t) -> do- unless (p == PublicAccess) $ typeError PrivateRecordField- ai <- checkFieldArgInfo False ai -- we already warned in recordConstructorType- tac <- traverse (toAbstractCtx TopCtx) tac- -- Interaction points for record fields have already been introduced- -- when checking the type of the record constructor.- -- To avoid introducing interaction points (IP) twice, we turn- -- all question marks to underscores. (See issue 1138.)- let maskIP (C.QuestionMark r _) = C.Underscore r Nothing- maskIP e = e- t <- toAbstractCtx TopCtx $ mapExpr maskIP t- f <- getConcreteFixity x- y <- freshAbstractQName f x- -- Andreas, 2018-06-09 issue #2170- -- We want dependent irrelevance without irrelevant projections,- -- thus, do not disable irrelevant projections via the scope checker.- -- irrProj <- optIrrelevantProjections <$> pragmaOptions- -- unless (isIrrelevant t && not irrProj) $- -- -- Andreas, 2010-09-24: irrelevant fields are not in scope- -- -- this ensures that projections out of irrelevant fields cannot occur- -- -- Ulf: unless you turn on --irrelevant-projections- bindName p FldName x y- let info = (mkDefInfoInstance x f p a i NotMacroDef r) { defTactic = tac }- return [ A.Field info y (Arg ai t) ]-- -- Primitive function- PrimitiveFunction r p a x t -> notAffectedByOpaque $ do- t' <- traverse (toAbstractCtx TopCtx) t- f <- getConcreteFixity x- y <- freshAbstractQName f x- bindName p PrimName x y- unfoldFunction y- let di = mkDefInfo x f p a r- return [ A.Primitive di y t' ]-- -- Definitions (possibly mutual)- NiceMutual kwr tc cc pc ds -> do- reportSLn "scope.mutual" 40 ("starting checking mutual definitions: " ++ prettyShow ds)- ds' <- toAbstract ds- reportSLn "scope.mutual" 40 ("finishing checking mutual definitions")- -- We only termination check blocks that do not have a measure.- return [ A.Mutual (MutualInfo tc cc pc (fuseRange kwr ds)) ds' ]-- C.NiceRecSig r er p a _pc _uc x ls t -> do- ensureNoLetStms ls- withLocalVars $ do- (ls', _) <- withCheckNoShadowing $- -- Minor hack: record types don't have indices so we include t when- -- computing generalised parameters, but in the type checker any named- -- generalizable arguments in the sort should be bound variables.- toAbstract (GenTelAndType (map makeDomainFull ls) t)- t' <- toAbstract t- f <- getConcreteFixity x- x' <- freshAbstractQName f x- bindName' p RecName (GeneralizedVarsMetadata $ generalizeTelVars ls') x x'- return [ A.RecSig (mkDefInfo x f p a r) er x' ls' t' ]-- C.NiceDataSig r er p a pc uc x ls t -> do- reportSLn "scope.data.sig" 40 ("checking DataSig for " ++ prettyShow x)- ensureNoLetStms ls- withLocalVars $ do- ls' <- withCheckNoShadowing $- toAbstract $ GenTel $ map makeDomainFull ls- t' <- toAbstract $ C.Generalized t- f <- getConcreteFixity x- x' <- freshAbstractQName f x- mErr <- bindName'' p DataName (GeneralizedVarsMetadata $ generalizeTelVars ls') x x'- whenJust mErr $ \case- err@(ClashingDefinition cn an _) -> do- resolveName (C.QName x) >>= \case- -- #4435: if a data type signature causes a ClashingDefinition error, and if- -- the data type name is bound to an Axiom, then the error may be caused by- -- the illegal type signature. Convert the NiceDataSig into a NiceDataDef- -- (which removes the type signature) and suggest it as a possible fix.- DefinedName p ax NoSuffix | anameKind ax == AxiomName -> do- let suggestion = NiceDataDef r Inserted a pc uc x ls []- typeError $ ClashingDefinition cn an (Just suggestion)- _ -> typeError err- otherErr -> typeError otherErr- return [ A.DataSig (mkDefInfo x f p a r) er x' ls' t' ]-- -- Type signatures- C.FunSig r p a i m rel _ _ x t -> do- let kind = if m == MacroDef then MacroName else FunName- singleton . snd <$> toAbstractNiceAxiom kind (C.Axiom r p a i rel x t)-- -- Function definitions- C.FunDef r ds a i _ _ x cs -> do- printLocals 30 $ "checking def " ++ prettyShow x- (x',cs) <- toAbstract (OldName x,cs)- -- Andreas, 2017-12-04 the name must reside in the current module- unlessM ((A.qnameModule x' ==) <$> getCurrentModule) $- __IMPOSSIBLE__- f <- getConcreteFixity x-- unfoldFunction x'- di <- updateDefInfoOpacity (mkDefInfoInstance x f PublicAccess a i NotMacroDef r)- return [ A.FunDef di x' cs ]-- -- Uncategorized function clauses- C.NiceFunClause _ _ _ _ _ _ (C.FunClause lhs _ _ _) ->- typeError $ MissingTypeSignature $ MissingFunctionSignature lhs- C.NiceFunClause{} -> __IMPOSSIBLE__-- -- Data definitions- C.NiceDataDef r o a _ uc x pars cons -> notAffectedByOpaque $ do- reportSLn "scope.data.def" 40 ("checking " ++ show o ++ " DataDef for " ++ prettyShow x)- (p, ax) <- resolveName (C.QName x) >>= \case- DefinedName p ax NoSuffix -> do- clashUnless x DataName ax -- Andreas 2019-07-07, issue #3892- livesInCurrentModule ax -- Andreas, 2017-12-04, issue #2862- clashIfModuleAlreadyDefinedInCurrentModule x ax- return (p, ax)- _ -> typeError $ MissingTypeSignature $ MissingDataSignature x- ensureNoLetStms pars- withLocalVars $ do- gvars <- bindGeneralizablesIfInserted o ax- -- Check for duplicate constructors- do cs <- mapM conName cons- List1.unlessNull (duplicates cs) $ \ dups -> do- let bad = filter (`elem` dups) cs- setCurrentRange bad $- typeError $ DuplicateConstructors dups-- pars <- catMaybes <$> toAbstract pars- let x' = anameName ax- -- Create the module for the qualified constructors- checkForModuleClash x -- disallow shadowing previously defined modules- let m = qnameToMName x'- createModule (Just IsDataModule) m- bindModule p x m -- make it a proper module- cons <- toAbstract (map (DataConstrDecl m a p) cons)- printScope "data" 40 $ "Checked data " ++ prettyShow x- f <- getConcreteFixity x- return [ A.DataDef (mkDefInfo x f PublicAccess a r) x' uc (DataDefParams gvars pars) cons ]- where- conName (C.Axiom _ _ _ _ _ c _) = return c- conName d = errorNotConstrDecl d-- -- Record definitions (mucho interesting)- C.NiceRecDef r o a _ uc x directives pars fields -> notAffectedByOpaque $ do- reportSLn "scope.rec.def" 40 ("checking " ++ show o ++ " RecDef for " ++ prettyShow x)- -- #3008: Termination pragmas are ignored in records- checkNoTerminationPragma InRecordDef fields- RecordDirectives ind eta pat cm <- gatherRecordDirectives directives- -- Andreas, 2020-04-19, issue #4560- -- 'pattern' declaration is incompatible with 'coinductive' or 'eta-equality'.- pat <- case pat of- Just r- | Just (Ranged _ CoInductive) <- ind -> Nothing <$ warn "coinductive"- | Just (Ranged _ YesEta) <- eta -> Nothing <$ warn "eta"- | otherwise -> return pat- where warn = setCurrentRange r . warning . UselessPatternDeclarationForRecord- Nothing -> return pat-- (p, ax) <- resolveName (C.QName x) >>= \case- DefinedName p ax NoSuffix -> do- clashUnless x RecName ax -- Andreas 2019-07-07, issue #3892- livesInCurrentModule ax -- Andreas, 2017-12-04, issue #2862- clashIfModuleAlreadyDefinedInCurrentModule x ax- return (p, ax)- _ -> typeError $ MissingTypeSignature $ MissingRecordSignature x- ensureNoLetStms pars- withLocalVars $ do- gvars <- bindGeneralizablesIfInserted o ax- -- Check that the generated module doesn't clash with a previously- -- defined module- checkForModuleClash x- pars <- catMaybes <$> toAbstract pars- let x' = anameName ax- -- We scope check the fields a first time when putting together- -- the type of the constructor.- contel <- localToAbstract (RecordConstructorType fields) return- m0 <- getCurrentModule- let m = A.qualifyM m0 $ mnameFromList1 $ singleton $ List1.last $ qnameToList x'- printScope "rec" 25 "before record"- createModule (Just IsRecordModule) m- -- We scope check the fields a second time, as actual fields.- afields <- withCurrentModule m $ do- afields <- toAbstract (Declarations fields)- printScope "rec" 25 "checked fields"- return afields- -- Andreas, 2017-07-13 issue #2642 disallow duplicate fields- -- Check for duplicate fields. (See "Check for duplicate constructors")- do let fs :: [C.Name]- fs = concat $ forMaybe fields $ \case- C.Field _ fs -> Just $ fs <&> \case- -- a Field block only contains field signatures- C.FieldSig _ _ f _ -> f- _ -> __IMPOSSIBLE__- _ -> Nothing- List1.unlessNull (duplicates fs) $ \ dups -> do- let bad = filter (`elem` dups) fs- setCurrentRange bad $- typeError $ DuplicateFields dups-- bindModule p x m- let kind = maybe ConName (conKindOfName . rangedThing) ind-- cm' <- case cm of- -- Andreas, 2019-11-11, issue #4189, no longer add record constructor to record module.- Just (c, _) -> NamedRecCon <$> bindRecordConstructorName c kind a p-- -- Amy, 2024-09-25: if the record does not have a named- -- constructor, then generate the QName here, and record it in- -- the TC state so that 'Record.constructor' can be resolved.- Nothing -> do- -- Technically it doesn't matter with what this name is- -- qualified since record constructor names have a special- -- printing rule in lookupQName.- constr <- withCurrentModule m $- freshAbstractQName noFixity' $ simpleName "constructor"- pure $ FreshRecCon constr-- setRecordConstructor x' (recordConName cm', fmap rangedThing ind)-- let inst = caseMaybe cm NotInstanceDef snd- printScope "rec" 25 "record complete"- f <- getConcreteFixity x- let params = DataDefParams gvars pars- let dir' = RecordDirectives ind eta pat cm'- return [ A.RecDef (mkDefInfoInstance x f PublicAccess a inst NotMacroDef r) x' uc dir' params contel afields ]-- NiceModule r p a e x@(C.QName name) tel ds -> notAffectedByOpaque $ do- reportSDoc "scope.decl" 70 $ vcat $- [ text $ "scope checking NiceModule " ++ prettyShow x- ]-- adecl <- traceCall (ScopeCheckDeclaration $- NiceModule r p a e x tel []) $ do- scopeCheckNiceModule r p e name tel $- toAbstract (Declarations ds)-- reportSDoc "scope.decl" 70 $ vcat $- [ text $ "scope checked NiceModule " ++ prettyShow x- , nest 2 $ prettyA adecl- ]- return [ adecl ]-- NiceModule _ _ _ _ m@C.Qual{} _ _ -> typeError QualifiedLocalModule-- NiceModuleMacro r p e x modapp open dir -> do- reportSDoc "scope.decl" 70 $ vcat $- [ text $ "scope checking NiceModuleMacro " ++ prettyShow x- ]-- adecl <- checkModuleMacro Apply TopOpenModule- r p e x modapp open dir-- reportSDoc "scope.decl" 70 $ vcat $- [ text $ "scope checked NiceModuleMacro " ++ prettyShow x- , nest 2 $ prettyA adecl- ]- return [ adecl ]-- NiceOpen r x dir -> do- (minfo, m, adir) <- checkOpen r Nothing x dir- return [A.Open minfo m adir]-- NicePragma r p -> do- ps <- toAbstract p -- could result in empty list of pragmas- return $ map (A.Pragma r) ps-- NiceImport r x as open dir -> setCurrentRange r $ do- dir <- notPublicWithoutOpen open dir-- -- Andreas, 2018-11-03, issue #3364, parse expression in as-clause as Name.- 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)- as <- case as of- -- Ok if no as-clause or it (already) contains a Name.- Nothing -> return Nothing- Just (AsName (Right asName) r) -> return $ Just $ AsName asName r- Just (AsName (Left (C.Ident (C.QName asName))) r) -> return $ Just $ AsName asName r- Just (AsName (Left C.Underscore{}) r) -> return $ Just $ AsName underscore r- 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 top $ do- printScope "import" 30 "before import:"- (m0, i) <- scopeCheckImport top- printScope "import" 30 $ "scope checked import: " ++ prettyShow i- -- We don't want the top scope of the imported module (things happening- -- before the module declaration)- return (m0 `withRangesOfQ` x, Map.delete noModuleName i)-- -- Bind the desired module name to the right abstract name.- (name, theAsSymbol, theAsName) <- case as of-- Just a | let y = asName a, not (isNoName y) -> do- bindModule privateAccessInserted y m- return (C.QName y, asRange a, Just y)-- _ -> do- -- Don't bind if @import ... as _@ with "no name"- whenNothing as $ bindQModule (privateAccessInserted) x m- return (x, noRange, Nothing)-- -- Open if specified, otherwise apply import directives- adir <- case open of-- -- With @open@ import directives apply to the opening.- -- The module is thus present in its qualified form without restrictions.- DoOpen -> do-- -- Merge the imported scopes with the current scopes.- -- This might override a previous import of @m@, but monotonously (add stuff).- modifyScopes $ \ ms -> Map.unionWith mergeScope (Map.delete m ms) i-- -- Andreas, 2019-05-29, issue #3818.- -- Pass the resolved name to open instead triggering another resolution.- -- This helps in situations like- -- @- -- module Top where- -- module M where- -- open import M- -- @- -- It is clear than in @open import M@, name @M@ must refer to a file- -- rather than the above defined local module @M@.- -- This already worked in the situation- -- @- -- module Top where- -- module M where- -- import M- -- @- -- Note that the manual desugaring of @open import@ as- -- @- -- module Top where- -- module M where- -- import M- -- open M- -- @- -- will not work, as @M@ is now ambiguous in @open M@;- -- the information that @M@ is external is lost here.- (_minfo, _m, adir) <- checkOpen r (Just m) name dir- return adir-- -- If not opening, import directives are applied to the original scope.- DontOpen -> do- (adir, i') <- Map.adjustM' (applyImportDirectiveM x dir) m i- -- Andreas, 2020-05-18, issue #3933- -- We merge the new imports without deleting old imports, to be monotone.- modifyScopes $ \ ms -> Map.unionWith mergeScope ms i'- return adir-- printScope "import" 30 "merged imported sig:"- let minfo = ModuleInfo- { minfoRange = r- , minfoAsName = theAsName- , minfoAsTo = getRange (theAsSymbol, renamingRange dir)- , minfoOpenShort = Just open- , minfoDirective = Just dir- }- return [ A.Import minfo m adir ]-- NiceUnquoteDecl r p a i tc cc xs e -> do- fxs <- mapM getConcreteFixity xs- ys <- zipWithM freshAbstractQName fxs xs- zipWithM_ (bindName p QuotableName) xs ys- e <- toAbstract e- zipWithM_ (rebindName p OtherDefName) xs ys- let mi = MutualInfo tc cc YesPositivityCheck r- mapM_ unfoldFunction ys- opaque <- contextIsOpaque- return [ A.Mutual mi- [ A.UnquoteDecl mi- [ (mkDefInfoInstance x fx p a i NotMacroDef r) { Info.defOpaque = opaque } | (fx, x) <- zip fxs xs ]- ys e- ] ]-- NiceUnquoteDef r p a _ _ xs e -> do- fxs <- mapM getConcreteFixity xs- ys <- mapM (toAbstract . OldName) xs- zipWithM_ (rebindName p QuotableName) xs ys- e <- toAbstract e- zipWithM_ (rebindName p OtherDefName) xs ys- mapM_ unfoldFunction ys- opaque <- contextIsOpaque- return [ A.UnquoteDef [ (mkDefInfo x fx PublicAccess a r) { Info.defOpaque = opaque } | (fx, x) <- zip fxs xs ] ys e ]-- NiceUnquoteData r p a pc uc x cs e -> notAffectedByOpaque $ 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" 30 $ "found nice pattern syn: " ++ prettyShow n- (as, p) <- withLocalVars $ do- -- Expand puns if optHiddenArgumentPuns is True.- p <- parsePatternSyn =<< expandPunsOpt p- p <- toAbstract p- when (containsAsPattern p) $- typeError AsPatternInPatternSynonym- checkPatternLinearity p $ \ys ->- typeError $ RepeatedVariablesInPattern ys- -- Bind the pattern variables accumulated by @ToAbstract Pattern@ applied to the rhs.- bindVarsToBind- p <- A.noDotOrEqPattern (typeError DotPatternInPatternSynonym) p- as <- mapM checkPatSynParam as- List1.unlessNull (patternVars p List.\\ map whThing as) $ \ xs -> do- typeError $ UnboundVariablesInPatternSynonym xs- return (as, p)- y <- freshAbstractQName' n- bindName a PatternSynName n y- -- Expanding pattern synonyms already at definition makes it easier to- -- fold them back when printing (issue #2762).- ep <- expandPatternSynonyms p- modifyPatternSyns (Map.insert y (as, ep))- return [A.PatternSynDef y (map (fmap BindName) as) p] -- only for highlighting, so use unexpanded version- where- checkPatSynParam :: WithHiding C.Name -> ScopeM (WithHiding A.Name)- checkPatSynParam (WithHiding h x) = do- let err = setCurrentRange x . typeError- resolveName (C.QName x) >>= \case- VarName a (PatternBound h')- | isInstance h, not (isInstance h') -> err $ IllegalInstanceVariableInPatternSynonym x- | otherwise -> return $ WithHiding h a- ConstructorName _ ys -> err $ PatternSynonymArgumentShadows IsConstructor x ys- PatternSynResName ys -> err $ PatternSynonymArgumentShadows IsPatternSynonym x ys- UnknownName -> err $ UnusedVariableInPatternSynonym x- -- Other cases are impossible because parsing the pattern syn rhs would have failed.- _ -> __IMPOSSIBLE__-- d@NiceLoneConstructor{} -> withCurrentCallStack $ \ stk -> do- warning $ NicifierIssue (DeclarationWarning stk (InvalidConstructorBlock (getRange d)))- pure []-- d@(NiceOpaque kwr xs decls) -> do- -- The names in an 'unfolding' clause must be unambiguous names of definitions:- -- Resolve all the names, and use them as an initial unfolding set:- names <- catMaybes <$> forM xs \ x -> do- setCurrentRange x $ unambiguousConOrDef (const . UnfoldingWrongName) x- -- Generate the identifier for this block:- oid <- fresh- -- Record the parent unfolding block, if any:- parent <- asksTC envCurrentOpaqueId-- let r = getRange d- stOpaqueBlocks `modifyTCLens` Map.insert oid OpaqueBlock- { opaqueId = oid- , opaqueUnfolding = HashSet.fromList names- , opaqueDecls = mempty- , opaqueParent = parent- , opaqueRange = r- }-- -- Keep going!- localTC (\e -> e { envCurrentOpaqueId = Just oid }) $ do- out <- traverse toAbstract decls- unless (any interestingOpaqueDecl out) $ setCurrentRange kwr $ warning UselessOpaque- pure $ UnfoldingDecl r names : out---- | Checking postulate or type sig. without checking safe flag.-toAbstractNiceAxiom :: KindOfName -> C.NiceDeclaration -> ScopeM (A.QName, A.Declaration)-toAbstractNiceAxiom kind (C.Axiom r p a i info x t) = do- -- Amy, 2025-05-04, issue 7856: type signatures (more- -- importantly extended lambdas within them) should not belong- -- to opaque blocks- --- -- Note that only scope checking the type happens outside the- -- block since a bit below we need the proper opaque id to- -- possibly update the info.- t' <- notUnderOpaque $ toAbstractCtx TopCtx t-- f <- getConcreteFixity x- mp <- getConcretePolarity x- y <- freshAbstractQName f x- let isMacro | kind == MacroName = MacroDef- | otherwise = NotMacroDef- bindName p kind x y- definfo <- updateDefInfoOpacity $ mkDefInfoInstance x f p a i isMacro r- return (y, A.Axiom kind definfo info mp y t')-toAbstractNiceAxiom _ _ = __IMPOSSIBLE__--interestingOpaqueDecl :: A.Declaration -> Bool-interestingOpaqueDecl (A.Mutual _ ds) = any interestingOpaqueDecl ds-interestingOpaqueDecl (A.ScopedDecl _ ds) = any interestingOpaqueDecl ds--interestingOpaqueDecl A.FunDef{} = True-interestingOpaqueDecl A.UnquoteDecl{} = True-interestingOpaqueDecl A.UnquoteDef{} = True--interestingOpaqueDecl _ = False---- ** Helper functions for @opaque@----------------------------------------------------------------------------- | Add a 'QName' to the set of declarations /contained in/ the current--- opaque block.-unfoldFunction :: A.QName -> ScopeM ()-unfoldFunction qn = asksTC envCurrentOpaqueId >>= \case- Just id -> do- let go Nothing = __IMPOSSIBLE__- go (Just ob) = Just ob{ opaqueDecls = qn `HashSet.insert` opaqueDecls ob }- stOpaqueBlocks `modifyTCLens` Map.alter go id- Nothing -> pure ()---- | Look up the current opaque identifier as a value in 'IsOpaque'.-contextIsOpaque :: ScopeM IsOpaque-contextIsOpaque = maybe TransparentDef OpaqueDef <$> asksTC envCurrentOpaqueId--updateDefInfoOpacity :: DefInfo -> ScopeM DefInfo-updateDefInfoOpacity di = (\a -> di { Info.defOpaque = a }) <$> contextIsOpaque---- | Raise a warning indicating that the current Declaration is not--- affected by opacity, but only if we are actually in an Opaque block.-notAffectedByOpaque :: ScopeM a -> ScopeM a-notAffectedByOpaque k = do- whenM ((NoWhere_ ==) <$> asksTC envCheckingWhere) $- whenJustM (asksTC envCurrentOpaqueId) \ _ ->- warning NotAffectedByOpaque- notUnderOpaque k---- * Helper functions for @variable@ generalization---------------------------------------------------------------------------unGeneralized :: A.Expr -> (Set A.QName, A.Expr)-unGeneralized (A.Generalized s t) = (Set1.toSet s, t)-unGeneralized (A.ScopedExpr si e) = A.ScopedExpr si <$> unGeneralized e-unGeneralized t = (mempty, t)--alreadyGeneralizing :: ScopeM Bool-alreadyGeneralizing = isJust <$> useTC stGeneralizedVars---- | In the context of scope checking an expression, given a resolved name @d@:------ * If @d@ is a @variable@ (generalizable), add it to the collection 'stGeneralizedVars'--- of variables we wish to abstract over.------ * Otherwise, do nothing.----class AddGeneralizable a where- addGeneralizable :: a -> ScopeM ()--instance AddGeneralizable AbstractName where- addGeneralizable :: AbstractName -> ScopeM ()- addGeneralizable d = case anameKind d of- GeneralizeName -> do- gvs <- useTC stGeneralizedVars- case gvs of -- Subtle: Use (left-biased) union instead of insert to keep the old name if- -- already present. This way we can sort by source location when generalizing- -- (Issue 3354).- Just s -> stGeneralizedVars `setTCLens` Just (s `Set.union` Set.singleton (anameName d))- Nothing -> typeError $ GeneralizeNotSupportedHere $ anameName d- DisallowedGeneralizeName -> typeError $ GeneralizedVarInLetOpenedModule $ anameName d- _ -> return ()--instance AddGeneralizable ResolvedName where- addGeneralizable = \case- -- Only 'DefinedName' can be a @variable@.- DefinedName _ d NoSuffix -> addGeneralizable d- DefinedName _ d Suffix{} -> return ()- VarName{} -> return ()- FieldName{} -> return ()- ConstructorName{} -> return ()- PatternSynResName{} -> return ()- UnknownName{} -> return ()--collectGeneralizables :: ScopeM a -> ScopeM (Set A.QName, a)-collectGeneralizables m =- -- #5683: No nested generalization- ifM alreadyGeneralizing ((Set.empty,) <$> m) $- {-else-} bracket_ open close $ do- a <- m- s <- useTC stGeneralizedVars- case s of- Nothing -> __IMPOSSIBLE__- Just s -> return (s, a)- where- open = do- gvs <- useTC stGeneralizedVars- stGeneralizedVars `setTCLens` Just mempty- pure gvs- close = (stGeneralizedVars `setTCLens`)--createBoundNamesForGeneralizables :: Set A.QName -> ScopeM (Map A.QName A.Name)-createBoundNamesForGeneralizables vs =- flip Map.traverseWithKey (Map.fromSet (const ()) vs) $ \ q _ -> do- let x = nameConcrete $ qnameName q- fx = nameFixity $ qnameName q- freshAbstractName fx x--collectAndBindGeneralizables :: ScopeM a -> ScopeM (Map A.QName A.Name, a)-collectAndBindGeneralizables m = do- fvBefore <- length <$> getLocalVars- (s, res) <- collectGeneralizables m- fvAfter <- length <$> getLocalVars- -- We should bind the named generalizable variables as fresh variables- binds <- createBoundNamesForGeneralizables s- -- Issue #3735: We need to bind the generalizable variables outside any variables bound by `m`.- outsideLocalVars (fvAfter - fvBefore) $ bindGeneralizables binds- return (binds, res)--bindGeneralizables :: Map A.QName A.Name -> ScopeM ()-bindGeneralizables vars =- forM_ (Map.toList vars) $ \ (q, y) ->- bindVariable LambdaBound (nameConcrete $ qnameName q) y---- | Bind generalizable variables if data or record decl was split by the system--- (origin == Inserted)-bindGeneralizablesIfInserted :: Origin -> AbstractName -> ScopeM (Set A.Name)-bindGeneralizablesIfInserted Inserted y = bound <$ bindGeneralizables gvars- where gvars = case anameMetadata y of- GeneralizedVarsMetadata gvars -> gvars- NoMetadata -> Map.empty- bound = Set.fromList (Map.elems gvars)-bindGeneralizablesIfInserted UserWritten _ = return Set.empty-bindGeneralizablesIfInserted _ _ = __IMPOSSIBLE__--newtype GenTel = GenTel C.Telescope-data GenTelAndType = GenTelAndType C.Telescope C.Expr--instance ToAbstract GenTel where- type AbsOfCon GenTel = A.GeneralizeTelescope- toAbstract (GenTel tel) =- uncurry A.GeneralizeTel <$> collectAndBindGeneralizables (catMaybes <$> toAbstract tel)--instance ToAbstract GenTelAndType where- type AbsOfCon GenTelAndType = (A.GeneralizeTelescope, A.Expr)-- toAbstract (GenTelAndType tel t) = do- (binds, (tel, t)) <- collectAndBindGeneralizables $- (,) <$> toAbstract tel <*> toAbstract t- return (A.GeneralizeTel binds (catMaybes tel), t)---- ** Record directives----------------------------------------------------------------------------- | Check for duplicate record directives.-gatherRecordDirectives :: [C.RecordDirective] -> ScopeM C.RecordDirectives-gatherRecordDirectives ds = mapM_ gatherRecordDirective ds `execStateT` empty---- | Fill the respective field of 'C.RecordDirectives' by the given 'C.RecordDirective'.------ Ignore it with a dead-code warning if the field is already filled.----gatherRecordDirective :: C.RecordDirective -> StateT C.RecordDirectives ScopeM ()-gatherRecordDirective d = do- dir@RecordDirectives{ recInductive = ind, recHasEta = eta, recPattern = pat, recConstructor = con } <- get- case d of- Induction ri -> assertNothing ind $ put dir{ recInductive = Just ri }- Eta re -> assertNothing eta $ put dir{ recHasEta = Just re }- PatternOrCopattern r -> assertNothing pat $ put dir{ recPattern = Just r }- C.Constructor x inst -> assertNothing con $ put dir{ recConstructor = Just (x, inst) }- where- assertNothing :: Maybe a -> StateT C.RecordDirectives ScopeM () -> StateT C.RecordDirectives ScopeM ()- assertNothing Nothing cont = cont- assertNothing Just{} _ = lift $ setCurrentRange d $ warning $ DuplicateRecordDirective d---- ** Helper functions for name clashes----------------------------------------------------------------------------- | Make sure definition is in same module as signature.-class LivesInCurrentModule a where- livesInCurrentModule :: a -> ScopeM ()--instance LivesInCurrentModule AbstractName where- livesInCurrentModule = livesInCurrentModule . anameName--instance LivesInCurrentModule A.QName where- livesInCurrentModule x = do- m <- getCurrentModule- reportS "scope.data.def" 30- [ " A.QName of data type: " ++ prettyShow x- , " current module: " ++ prettyShow m- ]- unless (A.qnameModule x == m) $- typeError $ DefinitionInDifferentModule x---- | Unless the resolved 'AbstractName' has the given 'KindOfName',--- report a 'ClashingDefinition' for the 'C.Name'.-clashUnless :: C.Name -> KindOfName -> AbstractName -> ScopeM ()-clashUnless x k ax = unless (anameKind ax == k) $- typeError $ ClashingDefinition (C.QName x) (anameName ax) Nothing---- | If a (data/record) module with the given name is already present in the current module,--- we take this as evidence that a data/record with that name is already defined.-clashIfModuleAlreadyDefinedInCurrentModule :: C.Name -> AbstractName -> ScopeM ()-clashIfModuleAlreadyDefinedInCurrentModule x ax = do- datRecMods <- catMaybes <$> do- mapM (isDatatypeModule . amodName) =<< lookupModuleInCurrentModule x- unlessNull datRecMods $ const $- typeError $ ClashingDefinition (C.QName x) (anameName ax) Nothing--lookupModuleInCurrentModule :: C.Name -> ScopeM [AbstractModule]-lookupModuleInCurrentModule x =- List1.toList' . Map.lookup x . nsModules . thingsInScope [PublicNS, PrivateNS] <$> getCurrentScope---- ** Helper functions for constructor declarations---------------------------------------------------------------------------data DataConstrDecl = DataConstrDecl A.ModuleName IsAbstract Access C.NiceDeclaration---- | Bind a @data@ constructor.-bindConstructorName- :: ModuleName -- ^ Name of @data@/@record@ module.- -> C.Name -- ^ Constructor name.- -> IsAbstract- -> Access- -> ScopeM A.QName-bindConstructorName m x a p = do- f <- getConcreteFixity x- -- The abstract name is the qualified one- y <- withCurrentModule m $ freshAbstractQName f x- -- Bind it twice, once unqualified and once qualified- bindName p' ConName x y- withCurrentModule m $ bindName p'' ConName x y- return y- where- -- An abstract constructor is private (abstract constructor means- -- abstract datatype, so the constructor should not be exported).- p' = case a of- AbstractDef -> privateAccessInserted- _ -> p- p'' = case a of- AbstractDef -> privateAccessInserted- _ -> PublicAccess---- | Record constructors do not live in the record module (as it is parameterized).--- Abstract constructors are bound privately, so that they are not exported.-bindRecordConstructorName :: C.Name -> KindOfName -> IsAbstract -> Access -> ScopeM A.QName-bindRecordConstructorName x kind a p = do- y <- freshAbstractQName' x- bindName p' kind x y- return y- where- -- An abstract constructor is private (abstract constructor means- -- abstract datatype, so the constructor should not be exported).- p' = case a of- AbstractDef -> privateAccessInserted- _ -> 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)- failure y = typeError $ ClashingDefinition (C.QName c) y Nothing- case r of- _ | isNoName c -> success- UnknownName -> success- ConstructorName i ds -> if all (isJust . isConName . anameKind) ds- then success- else failure $ anameName $ List1.head ds- DefinedName _ d _ -> failure $ anameName d- FieldName ds -> failure $ anameName $ List1.head ds- PatternSynResName ds -> failure $ anameName $ List1.head ds- VarName y _ -> failure $ qualify_ y- return c'--instance ToAbstract DataConstrDecl where- type AbsOfCon DataConstrDecl = A.Declaration-- toAbstract (DataConstrDecl m a p d) = traceCall (ScopeCheckDeclaration d) do- case d of- C.Axiom r p1 a1 i ai x t -> do- -- unless (p1 == p) __IMPOSSIBLE__ -- This invariant is currently violated by test/Succeed/Issue282.agda- unless (a1 == a) __IMPOSSIBLE__- ai <- checkConstructorArgInfo ai- t' <- toAbstractCtx TopCtx t- -- The abstract name is the qualified one- -- Bind it twice, once unqualified and once qualified- f <- getConcreteFixity x- y <- bindConstructorName m x a p- printScope "con" 25 "bound constructor"- let defInfo = mkDefInfoInstance x f p a i NotMacroDef r- return $ A.Axiom ConName defInfo ai Nothing y t'- _ -> errorNotConstrDecl d---- | Delete (with warning) attributes that are illegal for constructor declarations.-checkConstructorArgInfo :: ArgInfo -> ScopeM ArgInfo-checkConstructorArgInfo =- ensureRelevant msg >=>- ensureNotLinear msg >=>- ensureContinuous msg >=>- ensureMixedPolarity msg- where- msg = Just "of constructor"--errorNotConstrDecl :: C.NiceDeclaration -> ScopeM a-errorNotConstrDecl d = setCurrentRange d $- typeError $ IllegalDeclarationInDataDefinition $ notSoNiceDeclarations d--ensureRelevant :: LensRelevance a => Maybe String -> a -> ScopeM a-ensureRelevant ms info = do- if isRelevant info then return info else do- whenJust ms \ s -> warning $ FixingRelevance s (getRelevance info) relevant- return $ setRelevance relevant info--ensureNotLinear :: LensQuantity a => Maybe String -> a -> ScopeM a-ensureNotLinear s info = do- case getQuantity info of- Quantityω{} -> return info- Quantity0{} -> return info- q@Quantity1{} -> do- -- Andreas, 2024-08-24, "@1" is still not parsed, so this is impossible.- __IMPOSSIBLE__- -- TODO: linearity- -- let q' = Quantityω QωInferred- -- warning $ FixingQuantity s q q'- -- return $ setQuantity q' info--ensureContinuous :: LensCohesion a => Maybe String -> a -> ScopeM a-ensureContinuous ms info- | isContinuous info = return info- | otherwise = setCohesion Continuous info <$ do- whenJust ms \ s -> warning $ FixingCohesion s (getCohesion info) Continuous--ensureMixedPolarity :: LensModalPolarity a => Maybe String -> a -> ScopeM a-ensureMixedPolarity ms info- | splittablePolarity info = return info- | otherwise = setModalPolarity mixedPolarity info <$ do- whenJust ms \ s -> warning $ FixingPolarity s (getModalPolarity info) mixedPolarity---- ** More scope checking---------------------------------------------------------------------------instance ToAbstract C.Pragma where- type AbsOfCon C.Pragma = [A.Pragma]-- toAbstract (C.ImpossiblePragma _ strs) =- case strs of- "ReduceM" : _ -> impossibleTestReduceM strs- _ -> impossibleTest strs-- toAbstract (C.OptionsPragma _ opts) = return [ A.OptionsPragma opts ]-- toAbstract (C.RewritePragma _ _ []) = [] <$ warning EmptyRewritePragma- toAbstract (C.RewritePragma _ r xs) = singleton . A.RewritePragma r . catMaybes <$> do- forM xs \ x -> setCurrentRange x $ unambiguousConOrDef NotARewriteRule x-- toAbstract (C.ForeignPragma _ rb s) = [] <$ addForeignCode (rangedThing rb) s-- toAbstract (C.CompilePragma _ rb x s) =- maybe [] (\ y -> [ A.CompilePragma rb y s ]) <$>- unambiguousConOrDef PragmaCompileWrongName x-- toAbstract (C.StaticPragma _ x) = do- map A.StaticPragma . maybeToList <$> do- unambiguousDef (PragmaExpectsUnambiguousProjectionOrFunction "STATIC") x-- toAbstract (C.InjectivePragma _ x) = do- map A.InjectivePragma . maybeToList <$> do- unambiguousDef (PragmaExpectsUnambiguousProjectionOrFunction "INJECTIVE") x-- toAbstract (C.InjectiveForInferencePragma _ x) = do- map A.InjectiveForInferencePragma . maybeToList <$> do- scopeCheckDef (PragmaExpectsDefinedSymbol "INJECTIVE_FOR_INFERENCE") x-- toAbstract pragma@(C.InlinePragma _ b x) = do- caseMaybeM (toAbstract $ MaybeOldQName $ OldQName x Nothing) notInScope \case- A.Con (AmbQ xs) -> concatMapM ret $ List1.toList xs- A.Def x -> ret x- A.Proj _ p- | Just x <- getUnambiguous p -> ret x- | otherwise -> uselessPragma pragma $ sINLINE ++ " used on ambiguous name " ++ prettyShow x- _ -> uselessPragma pragma $ "Target of " ++ sINLINE ++ " pragma should be a function or constructor"- where- sINLINE = if b then "INLINE" else "NOINLINE"- notInScope = [] <$ notInScopeWarning x- ret y = return [ A.InlinePragma b y ]-- toAbstract (C.NotProjectionLikePragma _ x) = do- map A.NotProjectionLikePragma . maybeToList <$> do- unambiguousDef (PragmaExpectsUnambiguousProjectionOrFunction "NOT_PROJECTION_LIKE") x-- toAbstract (C.OverlapPragma _ xs i) = do- map (flip A.OverlapPragma i) . catMaybes <$> do- mapM (unambiguousConOrDef $ PragmaExpectsUnambiguousConstructorOrFunction pragma) xs- where- pragma = case i of- Overlappable -> "OVERLAPPABLE"- Overlapping -> "OVERLAPPING"- Overlaps -> "OVERLAPS"- Incoherent -> "INCOHERENT"- -- Never written by the user:- DefaultOverlap -> __IMPOSSIBLE__- FieldOverlap -> __IMPOSSIBLE__-- toAbstract pragma@(C.BuiltinPragma _ rb qx)- | Just b' <- b, isUntypedBuiltin b' = do- q <- resolveQName qx- bindUntypedBuiltin b' q- return [ A.BuiltinPragma rb q ]- -- Andreas, 2015-02-14- -- Some builtins cannot be given a valid Agda type,- -- thus, they do not come with accompanying postulate or definition.- | Just b' <- b, isBuiltinNoDef b' = do- case qx of- C.QName x -> do- -- The name shouldn't exist yet. If it does, we raise a warning- -- and drop the existing definition.- unlessM ((UnknownName ==) <$> resolveName qx) $ do- warning $ BuiltinDeclaresIdentifier b'- modifyCurrentScope $ removeNameFromScope PublicNS x- -- We then happily bind the name- y <- freshAbstractQName' x- let kind = fromMaybe __IMPOSSIBLE__ $ builtinKindOfName b'- bindName PublicAccess kind x y- return [ A.BuiltinNoDefPragma rb kind y ]- _ -> uselessPragma pragma $- "Pragma BUILTIN " ++ getBuiltinId b' ++ ": expected unqualified identifier, " ++- "but found " ++ prettyShow qx- | otherwise = do- q0 <- resolveQName qx-- -- Andreas, 2020-04-12, pr #4574. For highlighting purposes:- -- Rebind 'BuiltinPrim' as 'PrimName' and similar.- q <- case (q0, b >>= builtinKindOfName, qx) of- (DefinedName acc y suffix, Just kind, C.QName x)- | anameKind y /= kind- , kind `elem` [ PrimName, AxiomName ] -> do- rebindName acc kind x $ anameName y- return $ DefinedName acc y{ anameKind = kind } suffix- _ -> return q0-- return [ A.BuiltinPragma rb q ]- where b = builtinById (rangedThing rb)-- toAbstract (C.EtaPragma _ x) = do- map A.EtaPragma . maybeToList <$> do- scopeCheckDef (PragmaExpectsDefinedSymbol "ETA") x-- toAbstract pragma@(C.DisplayPragma _ lhs rhs) = do- maybeToList <$> do- withLocalVars $ runMaybeT do- let err = failure "DISPLAY pragma left-hand side must have form 'f e1 .. en'"- getHead (C.IdentP _ x) = return x- getHead (C.RawAppP _ (List2 p _ _)) = getHead p- getHead _ = err-- top <- getHead lhs-- (isPatSyn, hd) <- do- qx <- liftTCM $ resolveName' allKindsOfNames Nothing top- case qx of- VarName x' _ -> return . (False,) $ A.qnameFromList $ singleton x'- DefinedName _ d NoSuffix -> return . (False,) $ anameName d- DefinedName _ d Suffix{} -> failure $ "Invalid pattern " ++ prettyShow top- FieldName (d :| []) -> return . (False,) $ anameName d- FieldName ds -> failure $ "Ambiguous projection " ++ prettyShow top ++ ": " ++ prettyShow (AmbQ $ fmap anameName ds)- ConstructorName _ (d :| []) -> return . (False,) $ anameName d- ConstructorName _ ds -> failure $ "Ambiguous constructor " ++ prettyShow top ++ ": " ++ prettyShow (AmbQ $ fmap anameName ds)- UnknownName -> do liftTCM $ notInScopeWarning top; mzero- PatternSynResName (d :| []) -> return . (True,) $ anameName d- PatternSynResName ds -> failure $ "Ambiguous pattern synonym" ++ prettyShow top ++ ": " ++ prettyShow (fmap anameName ds)-- lhs <- liftTCM $ toAbstract $ LeftHandSide top lhs YesDisplayLHS- ps <- case lhs of- A.LHS _ (A.LHSHead _ ps) -> return ps- _ -> err-- -- Andreas, 2016-08-08, issue #2132- -- Remove pattern synonyms on lhs- (hd, ps) <- do- p <- liftTCM $ expandPatternSynonyms $- (if isPatSyn then A.PatternSynP else A.DefP) (PatRange $ getRange lhs) (unambiguous hd) ps- case p of- A.DefP _ f ps | Just hd <- getUnambiguous f -> return (hd, ps)- A.ConP _ c ps | Just hd <- getUnambiguous c -> return (hd, ps)- A.PatternSynP{} -> __IMPOSSIBLE__- _ -> err-- rhs <- liftTCM $ toAbstract rhs-- -- Andreas, 2024-10-06, issue #7533:- -- Check that all pattern variables occur on the rhs.- -- Otherwise, there might be a misunderstanding of what display forms do.- let used = allUsedNames rhs- List1.unlessNull (filter (not . (isNoName || (`Set.member` used))) $ patternVars ps) $- warning . UnusedVariablesInDisplayForm-- return $ A.DisplayPragma hd ps rhs- where- failure :: forall a. String -> MaybeT ScopeM a- failure msg = do warning (UselessPragma (getRange pragma) $ P.fwords msg); mzero-- -- A warning attached to an ambiguous name shall apply to all disambiguations.- toAbstract pragma@(C.WarningOnUsage _ x str) = do- ys <- resolveName x >>= \case- ConstructorName _ ds -> return $ List1.toList ds- FieldName ds -> return $ List1.toList ds- PatternSynResName ds -> return $ List1.toList ds- DefinedName _ d NoSuffix -> return $ singleton d- DefinedName _ d Suffix{} -> [] <$ notInScopeWarning x- UnknownName -> [] <$ notInScopeWarning x- VarName x _ -> [] <$ do- uselessPragma pragma $ "Not a defined name: " ++ prettyShow x- forM_ ys $ \ y -> stLocalUserWarnings `modifyTCLens` Map.insert (anameName y) str- return []-- toAbstract (C.WarningOnImport _ str) = do- stWarningOnImport `setTCLens` Just str- pure []-- -- Termination, Coverage, Positivity, Universe, and Catchall- -- pragmes are handled by the nicifier- toAbstract C.TerminationCheckPragma{} = __IMPOSSIBLE__- toAbstract C.NoCoverageCheckPragma{} = __IMPOSSIBLE__- toAbstract C.NoPositivityCheckPragma{} = __IMPOSSIBLE__- toAbstract C.NoUniverseCheckPragma{} = __IMPOSSIBLE__- toAbstract C.CatchallPragma{} = __IMPOSSIBLE__-- -- Polarity pragmas are handled by the niceifier.- toAbstract C.PolarityPragma{} = __IMPOSSIBLE__--uselessPragma :: HasRange p => p -> String -> ScopeM [a]-uselessPragma pragma = ([] <$) . warning . UselessPragma (getRange pragma) . P.fwords--unambiguousConOrDef :: (C.QName -> IsAmbiguous -> Warning) -> C.QName -> ScopeM (Maybe A.QName)-unambiguousConOrDef warn x = do- caseMaybeM (toAbstract $ MaybeOldQName $ OldQName x Nothing) notInScope $ \case- A.Def' y NoSuffix -> ret y- A.Def' y Suffix{} -> failure NotAmbiguous- A.Proj _ p- | Just y <- getUnambiguous p -> ret y- | otherwise -> failure $ YesAmbiguous p- A.Con c- | Just y <- getUnambiguous c -> ret y- | otherwise -> failure $ YesAmbiguous c- A.Var{} -> failure NotAmbiguous- A.PatternSyn{} -> failure NotAmbiguous- _ -> __IMPOSSIBLE__- where- notInScope = Nothing <$ notInScopeWarning x- failure = (Nothing <$) . warning . warn x- ret = return . Just--unambiguousDef :: (C.QName -> IsAmbiguous -> Warning) -> C.QName -> ScopeM (Maybe A.QName)-unambiguousDef warn x = do- caseMaybeM (toAbstract $ MaybeOldQName $ OldQName x Nothing) notInScope $ \case- A.Def' y NoSuffix -> ret y- A.Def' y Suffix{} -> failure NotAmbiguous- A.Proj _ p- | Just y <- getUnambiguous p -> ret y- | otherwise -> failure $ YesAmbiguous p- A.Con{} -> failure NotAmbiguous- A.Var{} -> failure NotAmbiguous- A.PatternSyn{} -> failure NotAmbiguous- _ -> __IMPOSSIBLE__- where- notInScope = Nothing <$ notInScopeWarning x- failure = (Nothing <$) . warning . warn x- ret = return . Just--scopeCheckDef :: (C.QName -> Warning) -> C.QName -> ScopeM (Maybe A.QName)-scopeCheckDef warn x = do- caseMaybeM (toAbstract $ MaybeOldQName $ OldQName x Nothing) notInScope $ \case- A.Def' y NoSuffix -> ret y- A.Def' y Suffix{} -> failure- A.Proj{} -> failure- A.Con{} -> failure- A.Var{} -> failure- A.PatternSyn{} -> failure- _ -> __IMPOSSIBLE__- where- notInScope = Nothing <$ notInScopeWarning x- failure = Nothing <$ do warning $ warn x- ret = return . Just--instance ToAbstract C.Clause where- type AbsOfCon C.Clause = A.Clause-- toAbstract (C.Clause top catchall lhs@(C.LHS p eqs with) rhs wh wcs) = withLocalVars $ do- -- Jesper, 2018-12-10, #3095: pattern variables bound outside the- -- module are locally treated as module parameters- modifyScope_ $ updateScopeLocals $ map $ second patternToModuleBound- -- Andreas, 2012-02-14: need to reset local vars before checking subclauses- vars0 <- getLocalVars- lhs' <- toAbstract $ LeftHandSide (C.QName top) p NoDisplayLHS- printLocals 30 "after lhs:"- vars1 <- getLocalVars- eqs <- mapM (toAbstractCtx TopCtx) eqs- vars2 <- getLocalVars- let vars = dropEnd (length vars1) vars2 ++ vars0- let wcs' = (vars, wcs)-- -- Handle rewrite equations first.- if not (null eqs)- then do- rhs <- toAbstractCtx TopCtx $ RightHandSide eqs with wcs' rhs wh- rhs <- toAbstract rhs- return $ A.Clause lhs' [] rhs A.noWhereDecls catchall- else do- -- the right hand side is checked with the module of the local definitions opened- (rhs, ds) <- whereToAbstract (getRange wh) wh $- toAbstractCtx TopCtx $ RightHandSide [] with wcs' rhs NoWhere- rhs <- toAbstract rhs- return $ A.Clause lhs' [] rhs ds catchall---whereToAbstract- :: Range -- ^ The range of the @where@ block.- -> C.WhereClause -- ^ The @where@ block.- -> ScopeM a -- ^ The scope-checking task to be run in the context of the @where@ module.- -> ScopeM (a, A.WhereDeclarations) -- ^ Additionally return the scope-checked contents of the @where@ module.-whereToAbstract r wh inner = do- case wh of- NoWhere -> ret- AnyWhere _ [] -> warnEmptyWhere- AnyWhere _ ds -> enter do- -- Andreas, 2016-07-17 issues #2081 and #2101- -- where-declarations are automatically private.- -- Andreas, 2025-03-29- -- While since PR #5192 (Feb 2021, issue #481) it is no longer the case- -- that we check their type signatures in abstract mode,- -- we still need to mark the declaration as private- -- e.g. to avoid spurious UnknownFixityInMixfixDecl warnings (issue #2889).- whereToAbstract1 r defaultErased Nothing- (singleton $ C.Private empty Inserted ds) inner- SomeWhere _ e m a ds0 -> enter $- List1.ifNull ds0 warnEmptyWhere {-else-} \ ds ->- -- Named where-modules do not default to private.- whereToAbstract1 r e (Just (m, a)) ds inner- where- enter = localTC \ env -> env { envCheckingWhere = C.whereClause_ wh }- ret = (,A.noWhereDecls) <$> inner- warnEmptyWhere = do- setCurrentRange r $ warning EmptyWhere- ret--whereToAbstract1- :: Range -- ^ The range of the @where@-block.- -> Erased -- ^ Is the where module erased?- -> Maybe (C.Name, Access) -- ^ The name of the @where@ module (if any).- -> List1 C.Declaration -- ^ The contents of the @where@ module.- -> ScopeM a -- ^ The scope-checking task to be run in the context of the @where@ module.- -> ScopeM (a, A.WhereDeclarations) -- ^ Additionally return the scope-checked contents of the @where@ module.-whereToAbstract1 r e whname whds inner = do- -- ASR (16 November 2015) Issue 1137: We ban termination- -- pragmas inside `where` clause.- checkNoTerminationPragma InWhereBlock whds-- -- Create a fresh concrete name if there isn't (a proper) one.- (m, acc) <- do- case whname of- Just (m, acc) | not (isNoName m) -> return (m, acc)- _ -> fresh <&> \ x -> (C.NoName (getRange whname) x, privateAccessInserted)- -- unnamed where's are private- old <- getCurrentModule- am <- toAbstract (NewModuleName m)- (scope, d) <- scopeCheckModule r e (C.QName m) am [] $- toAbstract $ Declarations $ List1.toList whds- setScope scope- x <- inner- setCurrentModule old- bindModule acc m am- -- Issue 848: if the module was anonymous (module _ where) open it public- let anonymousSomeWhere = maybe False (isNoName . fst) whname- when anonymousSomeWhere $- void $ -- We can ignore the returned default A.ImportDirective.- openModule TopOpenModule (Just am) (C.QName m) $- defaultImportDir { publicOpen = Just empty }- return (x, A.WhereDecls (Just am) (isNothing whname) $ singleton d)--data TerminationOrPositivity = Termination | Positivity- deriving (Show)--data WhereOrRecord = InWhereBlock | InRecordDef--checkNoTerminationPragma :: FoldDecl a => WhereOrRecord -> a -> ScopeM ()-checkNoTerminationPragma b ds =- -- foldDecl traverses into all sub-declarations.- forM_ (foldDecl (isPragma >=> isTerminationPragma) ds) \ (p, r) ->- setCurrentRange r $ warning $ UselessPragma r $ P.vcat- [ P.text $ show p ++ " pragmas are ignored in " ++ what b- , P.text $ "(see " ++ issue b ++ ")"- ]- where- what InWhereBlock = "where clauses"- what InRecordDef = "record definitions"- github n = "https://github.com/agda/agda/issues/" ++ show n- issue InWhereBlock = github 3355- issue InRecordDef = github 3008-- isTerminationPragma :: C.Pragma -> [(TerminationOrPositivity, Range)]- isTerminationPragma = \case- C.TerminationCheckPragma r _ -> [(Termination, r)]- C.NoPositivityCheckPragma r -> [(Positivity, r)]- C.OptionsPragma _ _ -> []- C.BuiltinPragma _ _ _ -> []- C.RewritePragma _ _ _ -> []- C.ForeignPragma _ _ _ -> []- C.CompilePragma _ _ _ _ -> []- C.StaticPragma _ _ -> []- C.InlinePragma _ _ _ -> []- C.ImpossiblePragma _ _ -> []- C.EtaPragma _ _ -> []- C.WarningOnUsage _ _ _ -> []- C.WarningOnImport _ _ -> []- C.InjectivePragma _ _ -> []- C.InjectiveForInferencePragma{} -> []- C.DisplayPragma _ _ _ -> []- C.CatchallPragma _ -> []- C.NoCoverageCheckPragma _ -> []- C.PolarityPragma _ _ _ -> []- C.NoUniverseCheckPragma _ -> []- C.NotProjectionLikePragma _ _ -> []- C.OverlapPragma _ _ _ -> []--data RightHandSide = RightHandSide- { _rhsRewriteEqn :: [RewriteEqn' () A.BindName A.Pattern A.Expr]- -- ^ @rewrite e | with p <- e in eq@ (many)- , _rhsWithExpr :: [C.WithExpr]- -- ^ @with e@ (many)- , _rhsSubclauses :: (LocalVars, [C.Clause])- -- ^ the subclauses spawned by a with (monadic because we need to reset the local vars before checking these clauses)- , _rhs :: C.RHS- , _rhsWhere :: WhereClause- -- ^ @where@ module.- }--data AbstractRHS- = AbsurdRHS'- | WithRHS' (List1 A.WithExpr) (List1 (ScopeM C.Clause))- -- ^ The with clauses haven't been translated yet- | RHS' A.Expr C.Expr- | RewriteRHS' [RewriteEqn' () A.BindName A.Pattern A.Expr] AbstractRHS A.WhereDeclarations--qualifyName_ :: A.Name -> ScopeM A.QName-qualifyName_ x = do- m <- getCurrentModule- return $ A.qualify m x--withFunctionName :: String -> ScopeM A.QName-withFunctionName s = do- NameId i _ <- fresh- qualifyName_ =<< freshName_ (s ++ show i)--instance ToAbstract (RewriteEqn' () A.BindName A.Pattern A.Expr) where- type AbsOfCon (RewriteEqn' () A.BindName A.Pattern A.Expr) = A.RewriteEqn- toAbstract = \case- Rewrite es -> fmap Rewrite $ forM es $ \ (_, e) -> do- qn <- withFunctionName "-rewrite"- pure (qn, e)- Invert _ pes -> do- qn <- withFunctionName "-invert"- pure $ Invert qn pes- LeftLet pes -> pure $ LeftLet pes--instance ToAbstract C.RewriteEqn where- type AbsOfCon C.RewriteEqn = RewriteEqn' () A.BindName A.Pattern A.Expr- toAbstract = \case- Rewrite es -> Rewrite <$> mapM toAbstract es- Invert _ npes -> Invert () <$> do- -- Given a list of irrefutable with expressions of the form @p <- e in q@- let (nps, es) = List1.unzip- $ fmap (\ (Named nm (p, e)) -> ((nm, p), e)) npes- -- we first check the expressions @e@: the patterns may shadow some of the- -- variables mentioned in them!- es <- toAbstract es- -- we then parse the pairs of patterns @p@ and names @q@ for the equality- -- constraints of the form @p ≡ e@.- nps <- forM nps $ \ (n, p) -> do- -- first the pattern- p <- toAbsPat p- -- and then the name- n <- toAbstract $ fmap (NewName WithBound . C.mkBoundName_) n- pure (n, p)- -- we finally reassemble the telescope- pure $ List1.zipWith (\ (n,p) e -> Named n (p, e)) nps es- LeftLet pes -> fmap LeftLet $ forM pes $ \ (p, e) -> do- -- first check the expression: the pattern may shadow- -- some of the variables mentioned in it!- e <- toAbstract e- p <- toAbsPat p- pure (p, e)- where- toAbsPat p = do- -- Expand puns if optHiddenArgumentPuns is True.- p <- expandPunsOpt p- p <- parsePattern p- p <- toAbstract p- checkPatternLinearity p (typeError . RepeatedVariablesInPattern)- bindVarsToBind- toAbstract p--instance ToAbstract AbstractRHS where- type AbsOfCon AbstractRHS = A.RHS-- toAbstract AbsurdRHS' = return A.AbsurdRHS- toAbstract (RHS' e c) = return $ A.RHS e $ Just c- toAbstract (RewriteRHS' eqs rhs wh) = do- eqs <- toAbstract eqs- rhs <- toAbstract rhs- return $ RewriteRHS eqs [] rhs wh- toAbstract (WithRHS' es cs) = do- aux <- withFunctionName "with-"- A.WithRHS aux es <$> do toAbstract =<< sequence cs--instance ToAbstract RightHandSide where- type AbsOfCon RightHandSide = AbstractRHS- toAbstract (RightHandSide eqs@(_:_) es cs rhs wh) = do- (rhs, ds) <- whereToAbstract (getRange wh) wh $- toAbstract (RightHandSide [] es cs rhs NoWhere)- return $ RewriteRHS' eqs rhs ds- toAbstract (RightHandSide [] [] (_ , _:_) _ _) = __IMPOSSIBLE__- toAbstract (RightHandSide [] (_:_) _ (C.RHS _) _) = typeError BothWithAndRHS -- issue #7760- toAbstract (RightHandSide [] [] (_ , []) rhs NoWhere) = toAbstract rhs- toAbstract (RightHandSide [] (z:zs)(lv , c:cs) C.AbsurdRHS NoWhere) = do- let (ns, es) = List1.unzipWith (\ (Named nm e) -> (NewName WithBound . C.mkBoundName_ <$> nm, e)) $ z :| zs- es <- toAbstractCtx TopCtx es- lvars0 <- getLocalVars- ns <- toAbstract ns- lvars1 <- getLocalVars- let lv' = dropEnd (length lvars0) lvars1 ++ lv- let cs' = for (c :| cs) $ \ c -> setLocalVars lv' $> c- let nes = List1.zipWith Named ns es- return $ WithRHS' nes cs'- -- TODO: some of these might be possible- toAbstract (RightHandSide [] (_ : _) _ C.AbsurdRHS AnyWhere{}) = __IMPOSSIBLE__- toAbstract (RightHandSide [] (_ : _) _ C.AbsurdRHS SomeWhere{}) = __IMPOSSIBLE__- toAbstract (RightHandSide [] (_ : _) _ C.AbsurdRHS NoWhere{}) = __IMPOSSIBLE__- toAbstract (RightHandSide [] [] (_, []) C.AbsurdRHS AnyWhere{}) = __IMPOSSIBLE__- toAbstract (RightHandSide [] [] (_, []) C.AbsurdRHS SomeWhere{}) = __IMPOSSIBLE__- toAbstract (RightHandSide [] [] (_, []) C.RHS{} AnyWhere{}) = __IMPOSSIBLE__- toAbstract (RightHandSide [] [] (_, []) C.RHS{} SomeWhere{}) = __IMPOSSIBLE__--instance ToAbstract C.RHS where- type AbsOfCon C.RHS = AbstractRHS-- toAbstract C.AbsurdRHS = return $ AbsurdRHS'- toAbstract (C.RHS e) = RHS' <$> toAbstract e <*> pure e---- | Wrapper to check lhs (possibly of a 'C.DisplayPragma').----data LeftHandSide = LeftHandSide- C.QName- -- ^ Name of the definition we are checking.- C.Pattern- -- ^ Full left hand side.- DisplayLHS- -- ^ Are we checking a 'C.DisplayPragma'?--instance ToAbstract LeftHandSide where- type AbsOfCon LeftHandSide = A.LHS-- toAbstract (LeftHandSide top lhs displayLhs) =- traceCall (ScopeCheckLHS top lhs) $ do- reportSLn "scope.lhs" 25 $ "original lhs: " ++ prettyShow lhs- reportSLn "scope.lhs" 60 $ "patternQNames: " ++ prettyShow (patternQNames lhs)- reportSLn "scope.lhs" 60 $ "original lhs (raw): " ++ show lhs-- -- Expand puns if optHiddenArgumentPuns is True. Note that pun- -- expansion should happen before the left-hand side is- -- parsed, because {(x)} is not treated as a pun, whereas {x}- -- is.- lhs <- expandPunsOpt lhs- reportSLn "scope.lhs" 25 $- "lhs with expanded puns: " ++ prettyShow lhs- reportSLn "scope.lhs" 60 $- "lhs with expanded puns (raw): " ++ show lhs-- lhscore <- parseLHS displayLhs top lhs- let ell = hasExpandedEllipsis lhscore- reportSLn "scope.lhs" 25 $ "parsed lhs: " ++ prettyShow lhscore- reportSLn "scope.lhs" 60 $ "parsed lhs (raw): " ++ show lhscore- printLocals 30 "before lhs:"- -- error if copattern parsed but --no-copatterns option- unlessM (optCopatterns <$> pragmaOptions) $- when (hasCopatterns lhscore) $- typeError $ NeedOptionCopatterns- -- scope check patterns except for dot patterns- lhscore <- toAbstract $ CLHSCore displayLhs lhscore- bindVarsToBind- -- reportSLn "scope.lhs" 25 $ "parsed lhs patterns: " ++ prettyShow lhscore -- TODO: Pretty A.LHSCore'- reportSLn "scope.lhs" 60 $ "parsed lhs patterns: " ++ show lhscore- printLocals 30 "checked pattern:"- -- scope check dot patterns- lhscore <- toAbstract lhscore- -- reportSLn "scope.lhs" 25 $ "parsed lhs dot patterns: " ++ prettyShow lhscore -- TODO: Pretty A.LHSCore'- reportSLn "scope.lhs" 60 $ "parsed lhs dot patterns: " ++ show lhscore- printLocals 30 "checked dots:"- return $ A.LHS (LHSInfo (getRange lhs) ell) lhscore---- | Expands hidden argument puns when option 'optHiddenArgumentPuns' is set.--expandPunsOpt :: C.Pattern -> ScopeM C.Pattern-expandPunsOpt p = do- pragmaOptions <&> optHiddenArgumentPuns <&> \case- True -> expandPuns p- False -> p---- | Expands hidden argument puns.--expandPuns :: C.Pattern -> C.Pattern-expandPuns = mapCPattern \case- C.HiddenP r p -> C.HiddenP r $ expand p- C.InstanceP r p -> C.InstanceP r $ expand p- p -> p- where- -- Only patterns of the form {x} or ⦃ x ⦄, where x is an unqualified- -- name (not @_@), are interpreted as puns.- expand :: Named_ C.Pattern -> Named_ C.Pattern- expand- (Named { namedThing = C.IdentP _ q@(C.QName x@C.Name{})- , nameOf = Nothing- }) =- Named { namedThing = C.IdentP False q- , nameOf = Just $- WithOrigin- { woOrigin = ExpandedPun- , woThing = unranged (prettyShow x)- }- }- expand p = p--hasExpandedEllipsis :: C.LHSCore -> ExpandedEllipsis-hasExpandedEllipsis core = case core of- C.LHSHead{} -> NoEllipsis- C.LHSProj{} -> hasExpandedEllipsis $ namedArg $ C.lhsFocus core -- can this ever be ExpandedEllipsis?- C.LHSWith{} -> hasExpandedEllipsis $ C.lhsHead core- C.LHSEllipsis r p -> case p of- C.LHSWith p wps _ -> hasExpandedEllipsis p <> ExpandedEllipsis r (length wps)- C.LHSHead{} -> ExpandedEllipsis r 0- C.LHSProj{} -> ExpandedEllipsis r 0- C.LHSEllipsis{} -> __IMPOSSIBLE__---- | Merges adjacent EqualP patterns into one:--- type checking expects only one pattern for each domain in the telescope.-mergeEqualPs :: [NamedArg (Pattern' e)] -> ScopeM [NamedArg (Pattern' e)]-mergeEqualPs = go (empty, [])- where- go acc (p@(Arg ai (Named mn (A.EqualP r es))) : ps) = setCurrentRange p $ do- -- Face constraint patterns must be defaultNamedArg; check this:- unless (getModality ai == defaultModality) __IMPOSSIBLE__- when (notVisible ai) $- warning $ FaceConstraintCannotBeHidden ai- whenJust mn $ \ x -> setCurrentRange x $- warning $ FaceConstraintCannotBeNamed x- go (acc `mappend` (r, List1.toList es)) ps- go (r, (e:es)) ps = (defaultNamedArg (A.EqualP r $ e :| es) :) <$> mergeEqualPs ps- go (_, []) [] = return []- go (_, []) (p : ps) = (p :) <$> mergeEqualPs ps----- | Scope-check a 'C.LHSCore' (of possibly a 'C.DisplayForm').--data CLHSCore = CLHSCore- DisplayLHS- -- ^ Are we checking the left hand side of a 'C.DisplayForm'?- C.LHSCore- -- ^ The lhs to scope-check.---- | Scope-check a 'C.LHSCore' not of a 'C.DisplayForm'.--instance ToAbstract C.LHSCore where- type AbsOfCon C.LHSCore = A.LHSCore' C.Expr-- toAbstract = toAbstract . CLHSCore NoDisplayLHS---- does not check pattern linearity-instance ToAbstract CLHSCore where- type AbsOfCon CLHSCore = A.LHSCore' C.Expr-- toAbstract (CLHSCore displayLhs core0) = case core0 of-- C.LHSHead x ps -> do- x <- withLocalVars do- setLocalVars []- toAbstract (OldName x)- ps <- toAbstract $ (fmap . fmap . fmap) (CPattern displayLhs) ps- A.LHSHead x <$> mergeEqualPs ps-- C.LHSProj d ps1 core ps2 -> do- unless (null ps1) $ typeError $ IllformedProjectionPatternConcrete (foldl C.AppP (C.IdentP True d) ps1)- ds <- resolveName d >>= \case- FieldName ds -> return $ fmap anameName ds- UnknownName -> notInScopeError d- _ -> typeError $ CopatternHeadNotProjection d- core <- toAbstract $ (fmap . fmap) (CLHSCore displayLhs) core- ps2 <- toAbstract $ (fmap . fmap . fmap) (CPattern displayLhs) ps2- A.LHSProj (AmbQ ds) core <$> mergeEqualPs ps2-- C.LHSWith core wps ps -> do- -- DISPLAY pragmas cannot have @with@, so no need to pass on @displayLhs@.- core <- toAbstract core- wps <- fmap defaultArg <$> toAbstract wps- ps <- toAbstract ps- return $ A.lhsCoreApp (A.lhsCoreWith core wps) ps-- -- In case of a part of the LHS which was expanded from an ellipsis,- -- we flush the @scopeVarsToBind@ in order to allow variables bound- -- in the ellipsis to be shadowed.- C.LHSEllipsis _ core -> do- core <- toAbstract core -- Cannot come from a DISPLAY pragma.- bindVarsToBind- return core--instance ToAbstract c => ToAbstract (WithHiding c) where- type AbsOfCon (WithHiding c) = WithHiding (AbsOfCon c)- toAbstract (WithHiding h a) = WithHiding h <$> toAbstractHiding h a--instance ToAbstract c => ToAbstract (Arg c) where- type AbsOfCon (Arg c) = Arg (AbsOfCon c)- toAbstract (Arg info e) =- Arg info <$> toAbstractHiding info e--instance ToAbstract c => ToAbstract (Named name c) where- type AbsOfCon (Named name c) = Named name (AbsOfCon c)- toAbstract = traverse toAbstract--instance ToAbstract c => ToAbstract (Ranged c) where- type AbsOfCon (Ranged c) = Ranged (AbsOfCon c)- toAbstract = traverse toAbstract--{- DOES NOT WORK ANYMORE with pattern synonyms-instance ToAbstract c a => ToAbstract (A.LHSCore' c) (A.LHSCore' a) where- toAbstract = mapM toAbstract--}--instance ToAbstract (A.LHSCore' C.Expr) where- type AbsOfCon (A.LHSCore' C.Expr) = A.LHSCore' A.Expr- toAbstract (A.LHSHead f ps) = A.LHSHead f <$> mapM toAbstract ps- toAbstract (A.LHSProj d lhscore ps) = A.LHSProj d <$> mapM toAbstract lhscore <*> mapM toAbstract ps- toAbstract (A.LHSWith core wps ps) = liftA3 A.LHSWith (toAbstract core) (toAbstract wps) (toAbstract ps)---- Patterns are done in two phases. First everything but the dot patterns, and--- then the dot patterns. This is because dot patterns can refer to variables--- bound anywhere in the pattern.--instance ToAbstract (A.Pattern' C.Expr) where- type AbsOfCon (A.Pattern' C.Expr) = A.Pattern' A.Expr- toAbstract = traverse $ insideDotPattern . toAbstractCtx DotPatternCtx -- Issue #3033--resolvePatternIdentifier ::- Bool- -- ^ Is the identifier allowed to refer to a constructor (or a pattern synonym)?- --- -- Value 'False' is only used when 'optHiddenArgumentPuns' is 'True'.- -- In this case, error 'InvalidPun' is thrown on identifiers that are not variables.- -> DisplayLHS- -- ^ Are definitions to be treated as constructors?- -- 'True' when we are checking a 'C.DisplayForm'.- -> Hiding- -- ^ Is the pattern variable hidden?- -> C.QName- -- ^ Identifier.- -> Maybe (Set1 A.Name)- -- ^ Possibly precomputed resolutions of the identifier (from the operator parser).- -> ScopeM (A.Pattern' C.Expr)-resolvePatternIdentifier canBeConstructor displayLhs h x ns = do- reportSLn "scope.pat" 60 $ "resolvePatternIdentifier " ++ prettyShow x ++ " at source position " ++ prettyShow r- toAbstract (PatName x ns h displayLhs) >>= \case-- VarPatName y -> do- reportSLn "scope.pat" 60 $ " resolved to VarPatName " ++ prettyShow y ++ " with range " ++ prettyShow (getRange y)- return $ VarP $ A.mkBindName y-- ConPatName ds -> do- unless canBeConstructor $ err IsConstructor- return $ ConP (ConPatInfo ConOCon info ConPatEager) (AmbQ $ fmap anameName ds) []-- PatternSynPatName ds -> do- unless canBeConstructor $ err IsPatternSynonym- return $ PatternSynP info (AmbQ $ fmap anameName ds) []-- DefPatName d -> do- unless displayLhs __IMPOSSIBLE__- return $ DefP info (AmbQ $ singleton $ anameName d) []-- where- r = getRange x- info = PatRange r- err s = setCurrentRange r $ typeError $ InvalidPun s x---- | Apply an abstract syntax pattern head to pattern arguments.------ Fails with 'InvalidPattern' if head is not a constructor pattern--- (or similar) that can accept arguments.----applyAPattern- :: C.Pattern -- ^ The application pattern in concrete syntax.- -> A.Pattern' C.Expr -- ^ Head of application.- -> NAPs1 C.Expr -- ^ Arguments of application.- -> ScopeM (A.Pattern' C.Expr)-applyAPattern p0 p ps1 = do- let ps = List1.toList ps1- setRange (getRange p0) <$> do- case p of- A.ConP i x as -> return $ A.ConP i x (as ++ ps)- A.DefP i x as -> return $ A.DefP i x (as ++ ps)- A.PatternSynP i x as -> return $ A.PatternSynP i x (as ++ ps)- -- Dotted constructors are turned into "lazy" constructor patterns.- A.DotP i (Ident x) -> resolveName x >>= \case- ConstructorName _ ds -> do- let cpi = ConPatInfo ConOCon i ConPatLazy- c = AmbQ (fmap anameName ds)- return $ A.ConP cpi c ps- _ -> failure- A.DotP{} -> failure- A.VarP{} -> failure- A.ProjP{} -> failure- A.WildP{} -> failure- A.AsP{} -> failure- A.AbsurdP{} -> failure- A.LitP{} -> failure- A.RecP{} -> failure- A.EqualP{} -> failure- A.WithP{} -> failure- where- failure = typeError $ InvalidPattern p0---- | Throw-away wrapper type for pattern translation.-data WithHidingInfo a = WithHidingInfo Hiding a--propagateHidingInfo :: NamedArg a -> NamedArg (WithHidingInfo a)-propagateHidingInfo a = fmap (fmap $ WithHidingInfo $ getHiding a) a---- | Hiding info is only used for pattern variables.-instance ToAbstract (WithHidingInfo C.Pattern) where- type AbsOfCon (WithHidingInfo C.Pattern) = A.Pattern' C.Expr-- toAbstract (WithHidingInfo h (C.IdentP canBeConstructor x)) =- resolvePatternIdentifier canBeConstructor NoDisplayLHS h x Nothing-- toAbstract (WithHidingInfo _ p) = toAbstract p---- | Scope check a 'C.Pattern' (of possibly a 'C.DisplayForm').----data CPattern = CPattern- DisplayLHS- -- ^ Are we checking a 'C.DisplayForm'?- C.Pattern- -- ^ The pattern to scope-check.---- | Scope check a 'C.Pattern' not belonging to a 'C.DisplayForm'.----instance ToAbstract C.Pattern where- type AbsOfCon C.Pattern = A.Pattern' C.Expr-- toAbstract = toAbstract . CPattern NoDisplayLHS--instance ToAbstract CPattern where- type AbsOfCon CPattern = A.Pattern' C.Expr-- toAbstract (CPattern displayLhs p0) = case p0 of-- C.IdentP canBeConstructor x ->- resolvePatternIdentifier canBeConstructor displayLhs empty x Nothing-- QuoteP _r ->- typeError $ CannotQuote CannotQuoteNothing-- AppP (QuoteP _) p- | IdentP _ x <- namedArg p -> do- if visible p then do- e <- toAbstract (OldQName x Nothing)- A.LitP (PatRange $ getRange x) . LitQName <$> quotedName e- else typeError $ CannotQuote CannotQuoteHidden- | otherwise -> typeError $ CannotQuote $ CannotQuotePattern p-- AppP p q -> do- reportSLn "scope.pat" 50 $ "distributeDots before = " ++ show p- p <- distributeDots p- reportSLn "scope.pat" 50 $ "distributeDots after = " ++ show p- p' <- toAbstract (wrap p)- -- Remember hiding info in argument to propagate to 'PatternBound'.- q' <- ifThenElse displayLhs- {-then-} (toAbstract $ (fmap . fmap) wrap q)- {-else-} (toAbstract $ propagateHidingInfo q)- applyAPattern p0 p' $ singleton q'-- where- distributeDots :: C.Pattern -> ScopeM C.Pattern- distributeDots p@(C.DotP kwr r e) = distributeDotsExpr kwr r e- distributeDots p = return p-- distributeDotsExpr :: KwRange -> Range -> C.Expr -> ScopeM C.Pattern- distributeDotsExpr kwr r e = parseRawApp e >>= \case- C.App r e a ->- AppP <$> distributeDotsExpr empty r e- <*> (traverse . traverse) (distributeDotsExpr empty r) a- OpApp r q ns as ->- case (traverse . traverse . traverse) fromNoPlaceholder as of- Just as -> OpAppP r q ns <$>- (traverse . traverse . traverse) (distributeDotsExpr empty r) as- Nothing -> return $ C.DotP empty r e- Paren r e -> ParenP r <$> distributeDotsExpr empty r e- _ -> return $ C.DotP kwr r e-- fromNoPlaceholder :: MaybePlaceholder (OpApp a) -> Maybe a- fromNoPlaceholder (NoPlaceholder _ (Ordinary e)) = Just e- fromNoPlaceholder _ = Nothing-- parseRawApp :: C.Expr -> ScopeM C.Expr- parseRawApp (RawApp r es) = parseApplication es- parseRawApp e = return e-- OpAppP r op ns ps -> do- reportSLn "scope.pat" 60 $ "ConcreteToAbstract.toAbstract OpAppP{}: " ++ show p0- p <- resolvePatternIdentifier True displayLhs empty op (Just ns)- -- Remember hiding info in arguments to propagate to 'PatternBound'.- ps <- ifThenElse displayLhs- {-then-} (toAbstract $ (fmap . fmap . fmap) wrap ps)- {-else-} (toAbstract $ fmap propagateHidingInfo ps)- applyAPattern p0 p ps-- EllipsisP _ mp -> maybe __IMPOSSIBLE__ toAbstract mp -- Not in DISPLAY pragma-- -- Removed when parsing- HiddenP _ _ -> __IMPOSSIBLE__- InstanceP _ _ -> __IMPOSSIBLE__- RawAppP _ _ -> __IMPOSSIBLE__-- C.WildP r -> return $ A.WildP $ PatRange r- -- Andreas, 2015-05-28 futile attempt to fix issue 819: repeated variable on lhs "_"- -- toAbstract p@(C.WildP r) = A.VarP <$> freshName r "_"- C.ParenP _ p -> toAbstract $ wrap p -- Andreas, 2024-09-27 not impossible- C.LitP r l -> setCurrentRange r $ A.LitP (PatRange r) l <$ checkLiteral l-- C.AsP r x p -> do- -- Andreas, 2018-06-30, issue #3147: as-variables can be non-linear a priori!- -- x <- toAbstract (NewName PatternBound x)- -- Andreas, 2020-05-01, issue #4631: as-variables should not shadow constructors.- -- x <- bindPatternVariable x- toAbstract (PatName (C.QName x) Nothing empty NoDisplayLHS) >>= \case- VarPatName x -> A.AsP (PatRange r) (A.mkBindName x) <$> toAbstract (wrap p)- ConPatName{} -> ignoreAsPat IsConstructor- PatternSynPatName{} -> ignoreAsPat IsPatternSynonym- DefPatName{} -> __IMPOSSIBLE__ -- because of @False@ in @PatName@- where- -- An @-bound name which shadows a constructor is illegal and becomes dead code.- ignoreAsPat b = do- setCurrentRange x $ warning $ AsPatternShadowsConstructorOrPatternSynonym b- toAbstract $ wrap p-- C.EqualP r es -> return $ A.EqualP (PatRange r) es-- -- We have to do dot patterns at the end since they can- -- refer to the variables bound by the other patterns.- C.DotP _kwr r e -> do- let fallback = return $ A.DotP (PatRange r) e- case e of- C.Ident x -> resolveName x >>= \case- -- Andreas, 2018-06-19, #3130- -- We interpret .x as postfix projection if x is a field name in scope- FieldName xs -> return $ A.ProjP (PatRange r) ProjPostfix $ AmbQ $- fmap anameName xs- _ -> fallback- _ -> fallback-- C.AbsurdP r -> return $ A.AbsurdP $ PatRange r- C.RecP kwr r fs -> A.RecP kwr (ConPatInfo ConORec (PatRange r) ConPatEager) <$> mapM (traverse $ toAbstract . wrap) fs- C.WithP r p -> A.WithP (PatRange r) <$> toAbstract p -- not in DISPLAY pragma-- where- -- Pass on @displayLhs@ context- wrap = CPattern displayLhs---- | An argument @OpApp C.Expr@ to an operator can have binders,--- in case the operator is some @syntax@-notation.--- For these binders, we have to create lambda-abstractions.-toAbstractOpArg :: Precedence -> OpApp C.Expr -> ScopeM A.Expr-toAbstractOpArg ctx (Ordinary e) = toAbstractCtx ctx e-toAbstractOpArg ctx (SyntaxBindingLambda r bs e) = toAbstractLam r bs e ctx---- | Turn an operator application into abstract syntax. Make sure to--- record the right precedences for the various arguments.-toAbstractOpApp :: C.QName -> Set1 A.Name -> OpAppArgs -> ScopeM A.Expr-toAbstractOpApp op ns es = do- -- Replace placeholders with bound variables.- (binders, es) <- replacePlaceholders $ List1.toList es- -- Get the notation for the operator.- nota <- getNotation op ns- let parts = notation nota- -- We can throw away the @VarPart@s, since binders- -- have been preprocessed into @OpApp C.Expr@.- 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__- -- Translate operator and its arguments (each in the right context).- op <- toAbstract (OldQName op (Just ns))- es <- left (notaFixity nota) nonBindingParts es- -- Prepend the generated section binders (if any).- let body = List.foldl' app op es- return $ foldr (A.Lam (ExprRange (getRange body))) body binders- where- -- Build an application in the abstract syntax, with correct Range.- app e (pref, arg) = A.App info e arg- where info = (defaultAppInfo r) { appOrigin = getOrigin arg- , appParens = pref }- r = fuseRange e arg-- inferParenPref :: NamedArg (Either A.Expr (OpApp C.Expr)) -> ParenPreference- inferParenPref e =- case namedArg e of- Right (Ordinary e) -> inferParenPreference e- Left{} -> PreferParenless -- variable inserted by section expansion- Right{} -> PreferParenless -- syntax lambda-- -- Translate an argument. Returns the paren preference for the argument, so- -- we can build the correct info for the A.App node.- toAbsOpArg :: Precedence ->- NamedArg (Either A.Expr (OpApp C.Expr)) ->- ScopeM (ParenPreference, NamedArg A.Expr)- toAbsOpArg cxt e = (pref,) <$> (traverse . traverse) (either return (toAbstractOpArg cxt)) e- where pref = inferParenPref e-- -- The hole left to the first @IdPart@ is filled with an expression in @LeftOperandCtx@.- left :: Fixity- -> [NotationPart]- -> [NamedArg (Either A.Expr (OpApp C.Expr))]- -> ScopeM [(ParenPreference, NamedArg A.Expr)]- left f (IdPart _ : xs) es = inside f xs es- left f (_ : xs) (e : es) = do- e <- toAbsOpArg (LeftOperandCtx f) e- es <- inside f xs es- return (e : es)- left f (_ : _) [] = __IMPOSSIBLE__- left f [] _ = __IMPOSSIBLE__-- -- The holes in between the @IdPart@s are filled with an expression in @InsideOperandCtx@.- inside :: Fixity- -> [NotationPart]- -> [NamedArg (Either A.Expr (OpApp C.Expr))]- -> ScopeM [(ParenPreference, NamedArg A.Expr)]- inside f [x] es = right f x es- inside f (IdPart _ : xs) es = inside f xs es- inside f (_ : xs) (e : es) = do- e <- toAbsOpArg InsideOperandCtx e- es <- inside f xs es- return (e : es)- inside _ [] [] = return []- inside _ (_ : _) [] = __IMPOSSIBLE__- inside _ [] (_ : _) = __IMPOSSIBLE__-- -- The hole right of the last @IdPart@ is filled with an expression in @RightOperandCtx@.- right :: Fixity- -> NotationPart- -> [NamedArg (Either A.Expr (OpApp C.Expr))]- -> ScopeM [(ParenPreference, NamedArg A.Expr)]- right _ (IdPart _) [] = return []- right f _ [e] = do- let pref = inferParenPref e- e <- toAbsOpArg (RightOperandCtx f pref) e- return [e]- right _ _ _ = __IMPOSSIBLE__-- replacePlaceholders ::- OpAppArgs0 e ->- ScopeM ([A.LamBinding], [NamedArg (Either A.Expr (OpApp e))])- replacePlaceholders [] = return ([], [])- replacePlaceholders (a : as) = case namedArg a of- NoPlaceholder _ x -> mapSnd (set (Right x) a :) <$>- replacePlaceholders as- Placeholder _ -> do- x <- freshName noRange "section"- let i = setOrigin Inserted $ argInfo a- (ls, ns) <- replacePlaceholders as- return ( A.mkDomainFree (unnamedArg i $ A.insertedBinder_ x) : ls- , set (Left (Var x)) a : ns- )- where- set :: a -> NamedArg b -> NamedArg a- set x arg = fmap (fmap (const x)) arg---- | Raises an error if the list of attributes contains an unsupported--- attribute.--checkAttributes :: Attributes -> ScopeM ()-checkAttributes [] = return ()-checkAttributes (Attr r s attr : attrs) =- case attr of- RelevanceAttribute{} -> cont- CA.TacticAttribute{} -> cont- LockAttribute IsNotLock -> cont- LockAttribute IsLock{} -> do- unlessM (optGuarded <$> pragmaOptions) $- setCurrentRange r $ typeError $ AttributeKindNotEnabled "Lock" "--guarded" s+import Control.Monad ( (>=>), foldM, forM, forM_, zipWithM, zipWithM_ )+import Control.Applicative ( liftA2, liftA3 )+import Control.Monad.Except ( runExceptT, MonadError(..) )+import Control.Monad.State ( StateT, execStateT, get, put )+import Control.Monad.Trans.Maybe+import Control.Monad.Trans ( lift )++import Data.Bifunctor+import Data.Foldable (traverse_)+import Data.Set (Set)+import Data.Map (Map)+import Data.Functor (void)+import qualified Data.List as List+import qualified Data.Set as Set+import qualified Data.Map as Map+import qualified Data.HashSet as HashSet+import Data.Maybe+import Data.Text qualified as Text+import Data.Void++import Agda.Syntax.Common+import qualified Agda.Syntax.Common.Pretty as P+import Agda.Syntax.Common.Pretty (render, Pretty, pretty, prettyShow)+import Agda.Syntax.Concrete as C+import Agda.Syntax.Concrete.Attribute as CA+import Agda.Syntax.Concrete.Generic+import Agda.Syntax.Concrete.Operators+import Agda.Syntax.Concrete.Pattern+import Agda.Syntax.Abstract as A+import Agda.Syntax.Abstract.Pattern as A+ ( patternVars, checkPatternLinearity, containsAsPattern, lhsCoreApp, lhsCoreWith, noDotOrEqPattern )+import Agda.Syntax.Abstract.Pretty+import Agda.Syntax.Abstract.UsedNames+ ( allUsedNames )+import qualified Agda.Syntax.Internal as I+import Agda.Syntax.Position+import Agda.Syntax.Literal+import Agda.Syntax.Info as Info+import Agda.Syntax.Concrete.Definitions as C+import Agda.Syntax.Fixity+import Agda.Syntax.Concrete.Fixity (DoWarn(..))+import Agda.Syntax.Notation+import Agda.Syntax.Scope.Base as A+import Agda.Syntax.Scope.Monad+import Agda.Syntax.Scope.UnusedImports (lookedupName)+import Agda.Syntax.Translation.AbstractToConcrete (ToConcrete, ConOfAbs)+import Agda.Syntax.DoNotation+import Agda.Syntax.IdiomBrackets+import Agda.Syntax.TopLevelModuleName++import qualified Agda.TypeChecking.Monad.Base.Warning as W+import Agda.TypeChecking.Monad.Base hiding (ModuleInfo, MetaInfo)+import Agda.TypeChecking.Monad.Builtin+import Agda.TypeChecking.Monad.Options (isTwoLevelEnabled, isPropEnabled)+import Agda.TypeChecking.Monad.Trace (traceCall, setCurrentRange)+import Agda.TypeChecking.Monad.State hiding (topLevelModuleName)+import qualified Agda.TypeChecking.Monad.State as TCM (topLevelModuleName)+import Agda.TypeChecking.Monad.Signature (notUnderOpaque)+import Agda.TypeChecking.Monad.MetaVars (registerInteractionPoint)+import Agda.TypeChecking.Monad.Debug+import Agda.TypeChecking.Monad.Env (insideDotPattern, isInsideDotPattern, getCurrentPath, currentModule)+import Agda.TypeChecking.Rules.Builtin (isUntypedBuiltin, bindUntypedBuiltin, builtinKindOfName)++import Agda.TypeChecking.Patterns.Abstract (expandPatternSynonyms)+import Agda.TypeChecking.Pretty hiding (pretty, prettyA)+import Agda.TypeChecking.Quote (quotedName)+import Agda.TypeChecking.Opacity+import Agda.TypeChecking.Warnings++import Agda.Interaction.FindFile (checkModuleName, rootNameModule, SourceFile(SourceFile))+-- import Agda.Interaction.Imports -- for type-checking in ghci+import {-# SOURCE #-} Agda.Interaction.Imports (scopeCheckFileImport)+import Agda.Interaction.Options+import qualified Agda.Interaction.Options.Lenses as Lens+import Agda.Interaction.Options.Warnings++import qualified Agda.Utils.AssocList as AssocList+import Agda.Utils.Boolean ( (||), ifThenElse )+import Agda.Utils.CallStack ( HasCallStack, withCurrentCallStack )+import Agda.Utils.Char+import Agda.Utils.Either+import Agda.Utils.FileName+import Agda.Utils.Function ( applyWhen, applyWhenJust, applyWhenM, applyUnless )+import Agda.Utils.Functor+import Agda.Utils.Hash (hashString)+import Agda.Utils.Lens+import Agda.Utils.List+import Agda.Utils.List1 ( List1, pattern (:|) )+import Agda.Utils.List2 ( List2, pattern List2 )+import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.Map as Map+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.Set1 ( Set1 )+import qualified Agda.Utils.Set1 as Set1+import Agda.Utils.Singleton+import Agda.Utils.Tuple+import Agda.Utils.POMonoid (hasLeftAdjoint)++import Agda.Utils.Impossible ( __IMPOSSIBLE__ )+import Agda.ImpossibleTest (impossibleTest, impossibleTestReduceM)+++{--------------------------------------------------------------------------+ Exceptions+ --------------------------------------------------------------------------}++notAnExpression :: (HasCallStack, MonadTCError m) => C.Expr -> m a+notAnExpression = locatedTypeError NotAnExpression++notAValidLetBinding :: (HasCallStack, MonadTCError m) => Maybe NotAValidLetBinding -> m a+notAValidLetBinding = locatedTypeError NotAValidLetBinding++{--------------------------------------------------------------------------+ Helpers+ --------------------------------------------------------------------------}++newtype RecordConstructorType = RecordConstructorType [C.Declaration]++instance ToAbstract RecordConstructorType where+ type AbsOfCon RecordConstructorType = A.Expr+ toAbstract (RecordConstructorType ds) = recordConstructorType ds++-- | Compute the type of the record constructor (with bogus target type)+recordConstructorType :: [C.Declaration] -> ScopeM A.Expr+recordConstructorType decls =+ -- Nicify all declarations since there might be fixity declarations after+ -- the the last field. Use NoWarn to silence fixity warnings. We'll get+ -- them again when scope checking the declarations to build the record+ -- module.+ niceDecls NoWarn decls $ buildType . takeFields+ where+ takeFields = List.dropWhileEnd notField++ notField NiceField{} = False+ notField _ = True++ buildType :: [C.NiceDeclaration] -> ScopeM A.Expr+ -- TODO: Telescope instead of Expr in abstract RecDef+ buildType ds = do+ -- 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++ makeBinding :: C.NiceDeclaration -> ScopeM (Maybe A.TypedBinding)+ makeBinding d = do+ let failure = typeError $ NotValidBeforeField d+ r = getRange d+ mkLet :: C.NiceDeclaration -> ScopeM (Maybe A.TypedBinding)+ mkLet d = Just . A.TLet r <$> scopeCheckLetDef RecordLetDef d+ setCurrentRange r $ case d of++ C.NiceField r pr ab inst tac x (Arg ai t) -> do+ fx <- getConcreteFixity x+ ai <- checkFieldArgInfo True ai+ let bv = Arg ai $ unnamed $ C.mkBinder $ (C.mkBoundName x fx) { bnameTactic = tac }+ toAbstract $ C.TBind r (singleton bv) t++ -- Public open is allowed and will take effect when scope checking as+ -- proper declarations.+ C.NiceOpen kwr m dir -> do+ mkLet $ C.NiceOpen kwr m dir{ publicOpen = Nothing }+ C.NiceModuleMacro r p e x modapp open dir -> do+ mkLet $ C.NiceModuleMacro r p e x modapp open+ dir{ publicOpen = Nothing }++ -- Do some rudimentary matching here to get NotValidBeforeField instead+ -- of NotAValidLetDecl.+ C.NiceMutual _ _ _ _+ ( C.FunSig _ _ _ _ macro _ _ _ _ _+ :| [ C.FunDef _ _ abstract _ _ _ _+ (C.Clause _ _ _ (C.LHS _p [] []) (C.RHS _) NoWhere [] :| [])+ ]) | abstract /= AbstractDef && macro /= MacroDef -> do+ mkLet d++ C.NiceLoneConstructor{} -> failure+ C.NiceMutual{} -> failure+ -- TODO: some of these cases might be __IMPOSSIBLE__+ C.Axiom{} -> failure+ C.PrimitiveFunction{} -> failure+ C.NiceModule{} -> failure+ C.NiceImport{} -> failure+ C.NicePragma{} -> failure+ C.NiceRecSig{} -> failure+ C.NiceDataSig{} -> failure+ C.NiceFunClause{} -> failure+ C.FunSig{} -> failure -- Note: these are bundled with FunDef in NiceMutual+ C.FunDef{} -> failure+ C.NiceDataDef{} -> failure+ C.NiceRecDef{} -> failure+ C.NicePatternSyn{} -> failure+ C.NiceGeneralize{} -> failure+ C.NiceUnquoteDecl{} -> failure+ C.NiceUnquoteDef{} -> failure+ C.NiceUnquoteData{} -> failure+ C.NiceOpaque{} -> failure++checkModuleApplication+ :: C.ModuleApplication+ -> ModuleName+ -> C.Name+ -> C.ImportDirective+ -> ScopeM (A.ModuleApplication, ScopeCopyInfo, A.ImportDirective)++checkModuleApplication (C.SectionApp _ tel m es) m0 x dir' = do+ reportSDoc "scope.decl" 70 $ vcat $+ [ text $ "scope checking ModuleApplication " ++ prettyShow x+ ]++ -- For the following, set the current module to be m0.+ withCurrentModule m0 $ do+ -- Parse the raw arguments of the module application. (See issue #1245.)+ args <- parseArguments (C.Ident m) es+ -- Scope check the telescope (introduces bindings!).+ tel' <- catMaybes <$> toAbstract tel+ -- Scope check the old module name and the module args.+ m1 <- toAbstract $ OldModuleName m+ args' <- toAbstractCtx (ArgumentCtx PreferParen) args+ -- Copy the scope associated with m and take the parts actually imported.+ (adir, s) <- applyImportDirectiveM (C.QName x) dir' =<< getNamedScope m1+ (s', copyInfo) <- copyScope m m0 s+ -- Set the current scope to @s'@+ modifyCurrentScope $ const s'+ recomputeInverseScope++ printScope "mod.inst" 40 "copied source module"+ reportS "scope.mod.inst" 30 $ pretty copyInfo+ let amodapp = A.SectionApp tel' m1 args'+ reportSDoc "scope.decl" 70 $ vcat $+ [ text $ "scope checked ModuleApplication " ++ prettyShow x+ ]+ reportSDoc "scope.decl" 70 $ vcat $+ [ nest 2 $ prettyA amodapp+ ]+ return (amodapp, copyInfo, adir)++checkModuleApplication (C.RecordModuleInstance _ recN) m0 x dir' =+ withCurrentModule m0 $ do+ m1 <- toAbstract $ OldModuleName recN+ s <- getNamedScope m1+ (adir, s) <- applyImportDirectiveM recN dir' s+ (s', copyInfo) <- copyScope recN m0 s+ modifyCurrentScope $ const s'+ recomputeInverseScope++ printScope "mod.inst" 40 "copied record module"+ return (A.RecordModuleInstance m1, copyInfo, adir)++-- | @checkModuleMacro mkApply range access concreteName modapp open dir@+--+-- Preserves local variables.++checkModuleMacro :: (ToConcrete a, Pretty (ConOfAbs a))+ => (ModuleInfo+ -> Erased+ -> ModuleName+ -> A.ModuleApplication+ -> ScopeCopyInfo+ -> A.ImportDirective+ -> a)+ -> OpenKind+ -- ^ 'LetOpen' or ordinary 'Open'.+ -> Range+ -- ^ Range of the module definition.+ -> Access+ -- ^ Whether the new module will be public or private.+ -> Erased+ -- ^ Whether the contents of the new module will be marked as erased.+ -> C.Name+ -- ^ Name of the new module.+ -> C.ModuleApplication+ -- ^ Definition of the new module.+ -> OpenShortHand+ -- ^ Whether to open it.+ -> C.ImportDirective+ -- ^ Restricting the exports of the module.+ -> ScopeM a+checkModuleMacro apply kind r p e x modapp open dir = do+ reportSDoc "scope.decl" 70 $ vcat $+ [ text $ "scope checking ModuleMacro " ++ prettyShow x+ ]+ dir <- notPublicWithoutOpen open dir++ m0 <- toAbstract (NewModuleName x)+ reportSDoc "scope.decl" 90 $ "NewModuleName: m0 =" <+> prettyA m0++ printScope "mod.inst" 40 "module macro"++ -- If we're opening a /named/ module, the import directive is+ -- applied to the "open", otherwise to the module itself. However,+ -- "public" is always applied to the "open".+ let (moduleDir, openDir) = case (open, isNoName x) of+ (DoOpen _, False) -> (defaultImportDir, dir)+ (DoOpen _, True) -> ( dir { publicOpen = Nothing }+ , defaultImportDir { publicOpen = publicOpen dir }+ )+ (DontOpen, _) -> (dir, defaultImportDir)++ -- Restore the locals after module application has been checked.+ (modapp', copyInfo, adir') <- withLocalVars $ checkModuleApplication modapp m0 x moduleDir++ printScope "mod.inst.app" 40 "checkModuleMacro, after checkModuleApplication"++ reportSDoc "scope.decl" 90 $ "after mod app: trying to print m0 ..."+ reportSDoc "scope.decl" 90 $ "after mod app: m0 =" <+> prettyA m0++ bindModule p x m0+ reportSDoc "scope.decl" 90 $ "after bindMod: m0 =" <+> prettyA m0++ printScope "mod.inst.copy.after" 40 "after copying"++ -- Open the module if DoOpen.+ -- Andreas, 2014-09-02: @openModule@ might shadow some locals!+ adir <- case open of+ DontOpen -> return adir'+ DoOpen kwr -> do+ adir'' <- openModule kwr kind (Just m0) (C.QName x) openDir+ -- Andreas, 2020-05-14, issue #4656+ -- Keep the more meaningful import directive for highlighting+ -- (the other one is a defaultImportDir).+ return $ if isNoName x then adir' else adir''++ printScope "mod.inst" 40 $ show open+ reportSDoc "scope.decl" 90 $ "after open : m0 =" <+> prettyA m0++ stripNoNames+ printScope "mod.inst.strip" 30 $ "after stripping"+ reportSDoc "scope.decl" 90 $ "after stripNo: m0 =" <+> prettyA m0++ let m = m0 `withRangesOf` singleton x+ adecl = apply info e m modapp' copyInfo adir++ reportSDoc "scope.decl" 70 $ vcat $+ [ text $ "scope checked ModuleMacro " ++ prettyShow x+ ]+ reportSLn "scope.decl" 90 $ "info = " ++ show info+ reportSLn "scope.decl" 90 $ "m = " ++ prettyShow m+ reportSLn "scope.decl" 90 $ "modapp' = " ++ show modapp'+ reportS "scope.decl" 90 $ pretty copyInfo+ reportSDoc "scope.decl" 70 $ nest 2 $ prettyA adecl+ return adecl+ where+ info = ModuleInfo+ { minfoRange = r+ , minfoAsName = Nothing+ , minfoAsTo = renamingRange dir+ , minfoOpenShort = open+ , minfoDirective = Just dir+ }++-- | The @public@ keyword must only be used together with @open@.++notPublicWithoutOpen :: OpenShortHand -> C.ImportDirective -> ScopeM C.ImportDirective+notPublicWithoutOpen (DoOpen _kwr) = return+notPublicWithoutOpen DontOpen = uselessPublic UselessPublicNoOpen++-- | Warn about useless @public@.++uselessPublic :: UselessPublicReason -> C.ImportDirective -> ScopeM C.ImportDirective+uselessPublic reason dir = do+ whenJust (publicOpen dir) \ r ->+ setCurrentRange r $ warning $ UselessPublic reason+ return $ dir { publicOpen = Nothing }++-- | Computes the range of all the \"to\" keywords used in a renaming+-- directive.++renamingRange :: C.ImportDirective -> Range+renamingRange = getRange . map renToRange . impRenaming++-- | Scope check a 'NiceOpen'.+checkOpen+ :: KwRange -- ^ Range of the @open@ keyword.+ -> Maybe A.ModuleName -- ^ Resolution of concrete module name (if already resolved).+ -> C.QName -- ^ Module to open.+ -> C.ImportDirective -- ^ Scope modifier.+ -> ScopeM (ModuleInfo, A.ModuleName, A.ImportDirective) -- ^ Arguments of 'A.Open'+checkOpen kwr mam x dir = do+ cm <- getCurrentModule+ reportSDoc "scope.decl" 70 $ do+ vcat $+ [ text "scope checking NiceOpen " <> return (pretty x)+ , text " getCurrentModule = " <> prettyA cm+ , text $ " getCurrentModule (raw) = " ++ show cm+ , text $ " C.ImportDirective = " ++ prettyShow dir+ ]+ -- Andreas, 2017-01-01, issue #2377: warn about useless `public`+ dir <- if null cm then uselessPublic UselessPublicPreamble dir else return dir++ m <- caseMaybe mam (toAbstract (OldModuleName x)) return+ printScope "open" 40 $ "opening " ++ prettyShow x+ adir <- openModule kwr TopOpenModule (Just m) x dir+ printScope "open" 40 $ "result:"+ let minfo = ModuleInfo+ { minfoRange = getRange (kwr, x, dir)+ , minfoAsName = Nothing+ , minfoAsTo = renamingRange dir+ , minfoOpenShort = DoOpen kwr+ , minfoDirective = Just dir+ }+ let adecls = [A.Open minfo m adir]+ reportSDoc "scope.decl" 70 $ vcat $+ text ( "scope checked NiceOpen " ++ prettyShow x+ ) : map (nest 2 . prettyA) adecls+ return (minfo, m, adir)++-- | Check a literal, issuing an error warning for bad literals.+checkLiteral :: Literal -> ScopeM ()+checkLiteral = \case+ LitChar c -> when (isSurrogateCodePoint c) $ warning $ InvalidCharacterLiteral c+ LitNat _ -> return ()+ LitWord64 _ -> return ()+ LitFloat _ -> return ()+ LitString _ -> return ()+ LitQName _ -> return ()+ LitMeta _ _ -> return ()++{--------------------------------------------------------------------------+ Translation+ --------------------------------------------------------------------------}++concreteToAbstract_ :: ToAbstract c => c -> ScopeM (AbsOfCon c)+concreteToAbstract_ = toAbstract++concreteToAbstract :: ToAbstract c => ScopeInfo -> c -> ScopeM (AbsOfCon c)+concreteToAbstract scope x = evalWithScope scope (toAbstract x)++-- | Things that can be translated to abstract syntax are instances of this+-- class.+class ToAbstract c where+ type AbsOfCon c+ toAbstract :: c -> ScopeM (AbsOfCon c)++-- | This function should be used instead of 'toAbstract' for things that need+-- to keep track of precedences to make sure that we don't forget about it.+toAbstractCtx :: ToAbstract c => Precedence -> c-> ScopeM (AbsOfCon c)+toAbstractCtx ctx c = withContextPrecedence ctx $ toAbstract c++--UNUSED Liang-Ting Chen 2019-07-16+--toAbstractTopCtx :: ToAbstract c a => c -> ScopeM a+--toAbstractTopCtx = toAbstractCtx TopCtx++toAbstractHiding :: (LensHiding h, ToAbstract c) => h -> c -> ScopeM (AbsOfCon c)+toAbstractHiding h | visible h = toAbstract -- don't change precedence if visible+toAbstractHiding _ = toAbstractCtx TopCtx++--UNUSED Liang-Ting Chen 2019-07-16+--setContextCPS :: Precedence -> (a -> ScopeM b) ->+-- ((a -> ScopeM b) -> ScopeM b) -> ScopeM b+--setContextCPS p ret f = do+-- old <- useScope scopePrecedence+-- withContextPrecedence p $ f $ \ x -> setContextPrecedence old >> ret x+--+--localToAbstractCtx :: ToAbstract c =>+-- Precedence -> c -> (AbsOfCon -> ScopeM (AbsOfCon c)) -> ScopeM (AbsOfCon c)+--localToAbstractCtx ctx c ret = setContextCPS ctx ret (localToAbstract c)++-- | This operation does not affect the scope, i.e. the original scope+-- is restored upon completion.+localToAbstract :: ToAbstract c => c -> (AbsOfCon c -> ScopeM b) -> ScopeM b+localToAbstract x ret = localScope $ ret =<< toAbstract x++instance ToAbstract () where+ type AbsOfCon () = ()+ toAbstract = pure++instance (ToAbstract c1, ToAbstract c2) => ToAbstract (c1, c2) where+ type AbsOfCon (c1, c2) = (AbsOfCon c1, AbsOfCon c2)+ toAbstract (x,y) = (,) <$> toAbstract x <*> toAbstract y++instance (ToAbstract c1, ToAbstract c2, ToAbstract c3) => ToAbstract (c1, c2, c3) where+ type AbsOfCon (c1, c2, c3) = (AbsOfCon c1, AbsOfCon c2, AbsOfCon c3)+ toAbstract (x,y,z) = flatten <$> toAbstract (x,(y,z))+ where+ flatten (x,(y,z)) = (x,y,z)++instance ToAbstract c => ToAbstract [c] where+ type AbsOfCon [c] = [AbsOfCon c]+ toAbstract = mapM toAbstract++instance ToAbstract c => ToAbstract (List1 c) where+ type AbsOfCon (List1 c) = List1 (AbsOfCon c)+ toAbstract = mapM toAbstract++instance (ToAbstract c1, ToAbstract c2) => ToAbstract (Either c1 c2) where+ type AbsOfCon (Either c1 c2) = Either (AbsOfCon c1) (AbsOfCon c2)+ toAbstract = traverseEither toAbstract toAbstract++instance ToAbstract c => ToAbstract (Maybe c) where+ type AbsOfCon (Maybe c) = Maybe (AbsOfCon c)+ toAbstract = traverse toAbstract++-- Names ------------------------------------------------------------------++data NewName a = NewName+ { newBinder :: A.BindingSource -- what kind of binder?+ , newName :: a+ } deriving (Functor)++data OldQName = OldQName+ C.QName+ -- ^ Concrete name to be resolved.+ (Maybe (Set1 A.Name))+ -- ^ If a set is given, then the first name must+ -- correspond to one of the names in the set.++-- | We sometimes do not want to fail hard if the name is not actually+-- in scope because we have a strategy to recover from this problem+-- (e.g. drop the offending COMPILE pragma)+data MaybeOldQName = MaybeOldQName OldQName++-- | Wrapper to resolve a name in a pattern.+data PatName = PatName+ C.QName+ -- ^ Concrete name to be resolved in a pattern.+ (Maybe (Set1 A.Name))+ -- ^ If a set is given, then the first name must correspond to one+ -- of the names in the set.+ Hiding+ -- ^ If pattern variable is hidden, its status is indicated in 'Hiding'.+ DisplayLHS+ -- ^ If we parse the lhs of a 'DisplayPragma',+ -- names of arbitrary definitions count as constructors.++instance ToAbstract (NewName C.Name) where+ type AbsOfCon (NewName C.Name) = A.Name+ toAbstract (NewName b x) = do+ y <- freshAbstractName_ x+ bindVariable b x y+ return y++instance ToAbstract (NewName C.BoundName) where+ type AbsOfCon (NewName C.BoundName) = A.BindName+ toAbstract NewName{ newBinder = b, newName = BName{ boundName = x, bnameFixity = fx }} = do+ y <- freshAbstractName fx x+ bindVariable b x y+ return $ A.BindName y++instance ToAbstract OldQName where+ type AbsOfCon OldQName = A.Expr+ toAbstract q@(OldQName x _) =+ fromMaybeM (notInScopeError x) $ toAbstract (MaybeOldQName q)++instance ToAbstract MaybeOldQName where+ type AbsOfCon MaybeOldQName = Maybe A.Expr+ toAbstract (MaybeOldQName (OldQName x ns)) = do+ qx <- resolveName' allKindsOfNames ns x+ lookedupName x qx -- Mark this name as used for the unused-imports analysis+ reportSLn "scope.name" 30 $ "resolved " ++ prettyShow x ++ ": " ++ prettyShow qx+ case qx of+ VarName x' _ -> return $ Just $ A.Var x'+ DefinedName _ d suffix -> do+ raiseWarningsOnUsage $ anameName d+ -- then we take note of generalized names used+ addGeneralizable d+ -- and then we return the name+ return $ withSuffix suffix $ nameToExpr d+ where+ withSuffix NoSuffix e = Just e+ withSuffix s@Suffix{} (A.Def x) = Just $ A.Def' x s+ withSuffix _ _ = Nothing++ FieldName ds -> ambiguous (A.Proj ProjPrefix) ds+ ConstructorName _ ds -> ambiguous A.Con ds+ PatternSynResName ds -> ambiguous A.PatternSyn ds+ UnknownName -> do+ reportSLn "scope.name.unknown" 80 $ "resolved : unknown " ++ prettyShow x+ pure Nothing+ where+ ambiguous :: (AmbiguousQName -> A.Expr) -> List1 AbstractName -> ScopeM (Maybe A.Expr)+ ambiguous f ds = do+ raiseWarningsOnUsageIfUnambiguous ds+ return $ Just $ f $ ambigName ds++ -- Note: user warnings on ambiguous names will be raised by the type checker,+ -- see 'storeDisambiguatedName'.+ raiseWarningsOnUsageIfUnambiguous :: List1 AbstractName -> ScopeM ()+ raiseWarningsOnUsageIfUnambiguous = \case+ x :| [] -> raiseWarningsOnUsage $ anameName x+ _ -> return ()++-- | Resolve a name and fail hard if it is not in scope.+--+resolveQName :: C.QName -> ScopeM ResolvedName+resolveQName x = resolveName x >>= \case+ UnknownName -> notInScopeError x+ q -> q <$ addGeneralizable q+ -- Issue #7575:+ -- If the name is a @variable@, add it to the things we wish to generalize.+ -- If generalization is not supported here, this will throw an error.++-- | A name resolved in a pattern.+data APatName+ = VarPatName A.Name+ -- ^ Pattern variable.+ | ConPatName (List1 AbstractName)+ -- ^ A (possibly ambiguous) constructor.+ -- When parsing a 'C.DisplayPragma', this can be the name of a definition.+ | PatternSynPatName (List1 AbstractName)+ -- ^ A (possibly ambiguous) pattern synonym.+ | DefPatName AbstractName+ -- ^ A defined name, only possible when checking a 'C.DisplayPragma'.++instance ToAbstract PatName where+ type AbsOfCon PatName = APatName+ toAbstract (PatName x ns h displayLhs) = do+ reportSLn "scope.pat" 30 $ "checking pattern name: " ++ prettyShow x+ let kinds = applyWhen displayLhs (defNameKinds ++) conLikeNameKinds+ rx <- resolveName' (someKindsOfNames kinds) ns x+ -- Andreas, 2013-03-21 ignore conflicting names which cannot+ -- be meant since we are in a pattern+ -- Andreas, 2020-04-11 CoConName:+ -- coinductive constructors will be rejected later, in the type checker+ reportSLn "scope.pat" 40 $ "resolved as " ++ prettyShow rx+ lookedupName x rx+ case rx of+ ConstructorName _ ds -> ConPatName ds <$ do+ reportSLn "scope.pat" 30 $ "it was a con: " ++ prettyShow (fmap anameName ds)+ PatternSynResName ds -> PatternSynPatName ds <$ do+ reportSLn "scope.pat" 30 $ "it was a pat syn: " ++ prettyShow (fmap anameName ds)+ DefinedName _ d suffix | YesDisplayLHS <- displayLhs, null suffix -> DefPatName d <$ do+ reportSLn "scope.pat" 30 $ "it was a def: " ++ prettyShow (anameName d)+ _ -> case x of+ C.QName y -> VarPatName <$> bindPatternVariable h y+ C.Qual{} -> typeError $ InvalidPattern $ C.IdentP True x++-- | Translate and possibly bind a pattern variable+-- (which could have been bound before due to non-linearity).+bindPatternVariable :: Hiding -> C.Name -> ScopeM A.Name+bindPatternVariable h x = do+ y <- (AssocList.lookup x <$> getVarsToBind) >>= \case+ Just (LocalVar y _ _) -> do+ reportSLn "scope.pat" 30 $ "it was a old var: " ++ prettyShow x+ return $ setRange (getRange x) y+ Nothing -> do+ reportSLn "scope.pat" 30 $ "it was a new var: " ++ prettyShow x+ freshAbstractName_ x+ addVarToBind x $ LocalVar y (PatternBound h) []+ return y++class ToQName a where+ toQName :: a -> C.QName++instance ToQName C.Name where toQName = C.QName+instance ToQName C.QName where toQName = id++-- | Resolve a concrete name that we already bound to an 'A.Def'.+toAbstractOldName :: ToQName a => a -> ScopeM A.QName+toAbstractOldName x = do+ resolveName (toQName x) >>= \case+ DefinedName _ d NoSuffix -> return $ anameName d+ DefinedName _ d Suffix{} -> __IMPOSSIBLE__+ VarName{} -> __IMPOSSIBLE__+ UnknownName -> __IMPOSSIBLE__+ -- We can get the cases below for DISPLAY pragmas+ 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)++newtype NewModuleName = NewModuleName C.Name+newtype NewModuleQName = NewModuleQName C.QName+newtype OldModuleName = OldModuleName C.QName++freshQModule :: A.ModuleName -> C.Name -> ScopeM A.ModuleName+freshQModule m x = A.qualifyM m . mnameFromList1 . singleton <$> freshAbstractName_ x++checkForModuleClash :: C.Name -> ScopeM ()+checkForModuleClash x = do+ ms :: [AbstractModule] <- scopeLookup (C.QName x) <$> getScope+ List1.unlessNull ms \ ms -> do+ reportSLn "scope.clash" 40 $ "clashing modules ms = " ++ prettyShow ms+ reportSLn "scope.clash" 60 $ "clashing modules ms = " ++ show ms+ setCurrentRange x $+ typeError $ ShadowedModule x $ fmap ((`withRangeOf` x) . amodName) ms++instance ToAbstract NewModuleName where+ type AbsOfCon NewModuleName = A.ModuleName+ toAbstract (NewModuleName x) = do+ checkForModuleClash x+ m <- getCurrentModule+ y <- freshQModule m x+ createModule Nothing y+ return y++instance ToAbstract NewModuleQName where+ type AbsOfCon NewModuleQName = A.ModuleName+ toAbstract (NewModuleQName m) = toAbs noModuleName m+ where+ toAbs m (C.QName x) = do+ y <- freshQModule m x+ createModule Nothing y+ return y+ toAbs m (C.Qual x q) = do+ m' <- freshQModule m x+ toAbs m' q++instance ToAbstract OldModuleName where+ type AbsOfCon OldModuleName = A.ModuleName++ toAbstract (OldModuleName q) = setCurrentRange q $ do+ amodName <$> resolveModule q++-- Expressions ------------------------------------------------------------+--UNUSED Liang-Ting Chen 2019-07-16+---- | Peel off 'C.HiddenArg' and represent it as an 'NamedArg'.+--mkNamedArg :: C.Expr -> NamedArg C.Expr+--mkNamedArg (C.HiddenArg _ e) = Arg (hide defaultArgInfo) e+--mkNamedArg (C.InstanceArg _ e) = Arg (makeInstance defaultArgInfo) e+--mkNamedArg e = Arg defaultArgInfo $ unnamed e++-- | Peel off 'C.HiddenArg' and represent it as an 'Arg', throwing away any name.+mkArg' :: ArgInfo -> C.Expr -> Arg C.Expr+mkArg' info (C.HiddenArg _ e) = Arg (hide info) $ namedThing e+mkArg' info (C.InstanceArg _ e) = Arg (makeInstance info) $ namedThing e+mkArg' info e = Arg (setHiding NotHidden info) e++inferParenPreference :: C.Expr -> ParenPreference+inferParenPreference C.Paren{} = PreferParen+inferParenPreference _ = PreferParenless++-- | Scope check the argument in an 'C.App', giving special treatment to 'C.Dot'+-- which in some situation can be interpreted as post-fix projection.+toAbstractArgument :: NamedArg C.Expr -> ScopeM (NamedArg A.Expr, ParenPreference)+toAbstractArgument e = do+ case namedArg e of++ -- Andreas, 2025-07-15, issue #7954: do not allow parentheses around postfix projections.+ C.Dot kwr ex+ | null (getArgInfo e) -> do+ -- @ex@ may only be an identifier+ y <- toAbstractIdent ex $ fail InvalidDottedExpression+ return (defaultNamedArg $ A.Dot (ExprRange $ getRange e) y, PreferParenless)++ -- Andreas, 2021-02-10, issue #3289: reject @e {.p}@ and @e ⦃ .p ⦄@.+ -- Raise an error if argument is a C.Dot with Hiding info.+ | otherwise -> fail $ IllegalHidingInPostfixProjection e++ -- Ordinary function argument.+ _ -> do+ let parenPref = inferParenPreference (namedArg e)+ (,parenPref) <$> toAbstractCtx (ArgumentCtx parenPref) e+ where+ fail :: TypeError -> ScopeM a+ fail = setCurrentRange e . typeError+++-- | Check an identifier in scope.+toAbstractIdent :: C.Expr -> ScopeM A.Expr -> ScopeM A.Expr+toAbstractIdent e fallback = traceCall (ScopeCheckExpr e) do+ case e of+ C.Ident x -> toAbstract (OldQName x Nothing)+ C.KnownIdent _ x -> toAbstract (OldQName x Nothing)+ _ -> fallback++-- | Parse a possibly dotted and braced @C.Expr@ as @A.Expr@,+-- interpreting dots as relevance and braces as hiding.+-- Only accept a layer of dotting/bracing if the respective accumulator is @Nothing@.+toAbstractDotHiding :: Maybe Relevance -> Maybe Hiding -> Precedence -> C.Expr -> ScopeM (A.Expr, Relevance, Hiding)+toAbstractDotHiding mr mh prec e = do+ reportSLn "scope.irrelevance" 100 $ "toAbstractDotHiding: " ++ render (pretty e)+ traceCall (ScopeCheckExpr e) $ case e of++ C.RawApp _ es -> toAbstractDotHiding mr mh prec =<< parseApplication es+ C.Paren _ e -> toAbstractDotHiding mr mh TopCtx e++ C.Dot kwr e+ | Nothing <- mr -> toAbstractDotHiding (Just $ Irrelevant $ OIrrDot $ getRange kwr) mh prec e++ C.DoubleDot kwr e+ | Nothing <- mr -> toAbstractDotHiding (Just $ ShapeIrrelevant $ OShIrrDotDot $ getRange kwr) mh prec e++ C.HiddenArg _ (Named Nothing e)+ | Nothing <- mh -> toAbstractDotHiding mr (Just Hidden) TopCtx e++ C.InstanceArg _ (Named Nothing e)+ | Nothing <- mh -> toAbstractDotHiding mr (Just $ Instance NoOverlap) TopCtx e++ e -> (, fromMaybe relevant mr, fromMaybe NotHidden mh) <$>+ toAbstractCtx prec e++-- | Translate concrete expression under at least one binder into nested+-- lambda abstraction in abstract syntax.+toAbstractLam :: Range -> List1 C.LamBinding -> C.Expr -> Precedence -> ScopeM A.Expr+toAbstractLam r bs e ctx = do+ -- Translate the binders+ lvars0 <- getLocalVars+ localToAbstract (fmap (C.DomainFull . makeDomainFull) bs) $ \ bs -> do+ lvars1 <- getLocalVars+ checkNoShadowing lvars0 lvars1+ -- Translate the body+ e <- toAbstractCtx ctx e+ -- We have at least one binder. Get first @b@ and rest @bs@.+ return $ case List1.catMaybes bs of+ -- Andreas, 2020-06-18+ -- There is a pathological case in which we end up without binder:+ -- λ (let+ -- mutual -- warning: empty mutual block+ -- ) -> Set+ [] -> e+ b:bs -> A.Lam (ExprRange r) b $ foldr mkLam e bs+ where+ mkLam b e = A.Lam (ExprRange $ fuseRange b e) b e++-- | Scope check extended lambda expression.+scopeCheckExtendedLam ::+ Range -> Erased -> List1 C.LamClause -> ScopeM A.Expr+scopeCheckExtendedLam r e cs = do+ whenM isInsideDotPattern $ typeError $ NotAllowedInDotPatterns PatternLambdas++ -- Find an unused name for the extended lambda definition.+ cname <- freshConcreteName r 0 extendedLambdaName+ name <- freshAbstractName_ cname+ a <- asksTC (^. lensIsAbstract)+ reportSDoc "scope.extendedLambda" 30 $ vcat+ [ text $ "new extended lambda name (" ++ show a ++ "): " ++ prettyShow name+ ]+ verboseS "scope.extendedLambda" 60 $ do+ forM_ cs $ \ c -> do+ reportSLn "scope.extendedLambda" 60 $ "extended lambda lhs: " ++ show (C.lamLHS c)+ qname <- qualifyName_ name+ bindName privateAccessInserted FunName cname qname++ -- Andreas, 2019-08-20+ -- Keep the following __IMPOSSIBLE__, which is triggered by -v scope.decl.trace:80,+ -- for testing issue #4016.+ d <- C.FunDef r __IMPOSSIBLE__ a NotInstanceDef __IMPOSSIBLE__ __IMPOSSIBLE__ cname <$> do+ forM cs $ \ (LamClause ps rhs ca) -> do+ let p = C.rawAppP $+ killRange (IdentP True $ C.QName cname) :| ps+ let lhs = C.LHS p [] []+ return $ C.Clause cname ca defaultArgInfo lhs rhs NoWhere []+ scdef <- fromMaybe __IMPOSSIBLE__ <$> toAbstract d++ -- Create the abstract syntax for the extended lambda.+ case scdef of+ A.ScopedDecl si (A.FunDef di qname' cs :| []) -> do+ setScope si -- This turns into an A.ScopedExpr si $ A.ExtendedLam...+ return $+ A.ExtendedLam (ExprRange r) di e qname' cs+ _ -> __IMPOSSIBLE__++-- | Scope check an expression.++instance ToAbstract C.Expr where+ type AbsOfCon C.Expr = A.Expr++ toAbstract e =+ traceCall (ScopeCheckExpr e) $ annotateExpr $ case e of++ -- Names+ C.Ident x -> toAbstract (OldQName x Nothing)+ C.KnownIdent _ x -> toAbstract (OldQName x Nothing)+ -- Just discard the syntax highlighting information.++ -- Literals+ C.Lit r l -> do+ checkLiteral l+ case l of+ LitNat n -> do+ let builtin | n < 0 = Just <$> primFromNeg -- negative literals are only allowed if FROMNEG is defined+ | otherwise = ensureInScope =<< getBuiltin' builtinFromNat+ builtin >>= \case+ Just (I.Def q _) -> return $ mkApp q $ A.Lit i $ LitNat $ abs n+ _ -> return alit++ LitString s -> do+ getBuiltin' builtinFromString >>= ensureInScope >>= \case+ Just (I.Def q _) -> return $ mkApp q alit+ _ -> return alit++ _ -> return alit+ where+ i = ExprRange r+ alit = A.Lit i l+ mkApp q = A.App (defaultAppInfo r) (A.Def q) . defaultNamedArg++ -- #4925: Require fromNat/fromNeg to be in scope *unqualified* for literal overloading to+ -- apply.+ ensureInScope :: Maybe I.Term -> ScopeM (Maybe I.Term)+ ensureInScope v@(Just (I.Def q _)) =+ ifM (isNameInScopeUnqualified q <$> getScope) (return v) (return Nothing)+ ensureInScope _ = return Nothing++ -- Meta variables+ C.QuestionMark r n -> do+ scope <- getScope+ -- Andreas, 2014-04-06 create interaction point.+ ii <- registerInteractionPoint True r n++ let info = MetaInfo+ { metaRange = r+ , metaScope = scope+ , metaNumber = Nothing+ , metaNameSuggestion = ""+ , metaKind = UnificationMeta+ }+ return $ A.QuestionMark info ii+ C.Underscore r n -> do+ scope <- getScope+ return $ A.Underscore $ MetaInfo+ { metaRange = r+ , metaScope = scope+ , metaNumber = __IMPOSSIBLE__ =<< n+ , metaNameSuggestion = fromMaybe "" n+ , metaKind = UnificationMeta+ }++ -- Raw application+ C.RawApp r es -> do+ e <- parseApplication es+ toAbstract e++ -- Application+ C.App r e1 e2 -> do+ e1 <- toAbstractCtx FunctionCtx e1+ (e2, parenPref) <- toAbstractArgument e2+ let info = (defaultAppInfo r) { appOrigin = UserWritten, appParens = parenPref }+ return $ A.App info e1 e2++ -- Operator application+ C.OpApp r op ns es -> toAbstractOpApp op ns es+ C.KnownOpApp _ r op ns es -> toAbstractOpApp op ns es++ -- With application+ C.WithApp r e es -> do+ e <- toAbstractCtx WithFunCtx e+ es <- mapM (toAbstractCtx WithArgCtx) es+ return $ A.WithApp (ExprRange r) e es++ -- Misplaced hidden argument. We can treat these as parentheses and+ -- raise an error-warning+ C.HiddenArg _ e' -> do+ warning (HiddenNotInArgumentPosition e)+ toAbstract (namedThing e')++ C.InstanceArg _ e' -> do+ warning (InstanceNotInArgumentPosition e)+ toAbstract (namedThing e')++ -- Lambda+ C.AbsurdLam r h -> return $ A.AbsurdLam (ExprRange r) h++ C.Lam r bs e -> toAbstractLam r bs e TopCtx++ -- Extended Lambda+ C.ExtendedLam r e cs -> scopeCheckExtendedLam r e cs++ -- Relevant and irrelevant non-dependent function type+ C.Fun r (Arg info1 e1) e2 -> do+ let arg = mkArg' info1 e1+ let mr = case getRelevance arg of+ Relevant{} -> Nothing+ r -> Just r+ let mh = case getHiding arg of+ NotHidden -> Nothing+ h -> Just h+ Arg info (e1', rel, hid) <- traverse (toAbstractDotHiding mr mh FunctionSpaceDomainCtx) arg+ let updRel = applyUnless (isRelevant rel) $ setRelevance rel+ let updHid = case hid of+ NotHidden -> id+ hid -> setHiding hid+ A.Fun (ExprRange r) (Arg (updRel $ updHid info) e1') <$> toAbstractCtx TopCtx e2++ -- Dependent function type+ e0@(C.Pi tel e) -> do+ lvars0 <- getLocalVars+ localToAbstract tel $ \tel -> do+ lvars1 <- getLocalVars+ checkNoShadowing lvars0 lvars1+ e <- toAbstractCtx TopCtx e+ let info = ExprRange (getRange e0)+ return $ A.mkPi info (List1.catMaybes tel) e++ -- Let+ e0@(C.Let _ ds (Just e)) ->+ ifM isInsideDotPattern (typeError $ NotAllowedInDotPatterns LetExpressions) {-else-} do+ localToAbstract (LetDefs ExprLetDef ds) $ \ds' -> do+ e <- toAbstractCtx TopCtx e+ let info = ExprRange (getRange e0)+ return $ A.mkLet info ds' e+ C.Let _ _ Nothing -> typeError $ NotAValidLetExpression MissingBody++ -- Record construction+ C.Rec kwr r fs -> do+ fs' <- toAbstractCtx TopCtx fs+ let ds' = [ d | Right (_, Just d) <- fs' ]+ fs'' = map (mapRight fst) fs'+ i = ExprRange r+ return $ A.mkLet i ds' (A.Rec kwr i fs'')++ -- Record update+ C.RecUpdate kwr r e fs -> do+ A.RecUpdate kwr (ExprRange r) <$> toAbstract e <*> toAbstractCtx TopCtx fs++ -- Parenthesis+ C.Paren _ e -> toAbstractCtx TopCtx e++ -- Idiom brackets+ C.IdiomBrackets r q es -> qualifiedExpression q $+ toAbstractCtx TopCtx =<< parseIdiomBracketsSeq r q es++ -- Do notation+ C.DoBlock _kwr q ss -> qualifiedExpression q $+ toAbstractCtx TopCtx =<< desugarDoNotation q ss++ -- Post-fix projections+ C.Dot _ _ -> typeError InvalidDottedExpression++ -- Pattern things+ C.As _ _ _ -> notAnExpression e+ C.Absurd _ -> notAnExpression e++ -- Impossible things+ C.Equal{} -> syntaxError "unexpected '='" -- triggered by 'f = (x = e)'+ C.Ellipsis _ -> syntaxError "unexpected '...'" -- triggered by 'f = ...'+ C.DoubleDot _ _ -> syntaxError "unexpected '..'" -- triggered by 'f = ..x'++ -- Quoting+ C.Quote r -> return $ A.Quote (ExprRange r)+ C.QuoteTerm r -> return $ A.QuoteTerm (ExprRange r)+ C.Unquote r -> return $ A.Unquote (ExprRange r)++ C.Tactic r e -> syntaxError "'tactic' can only appear in attributes"++ -- 'Flagged' expressions from internal syntax+ C.DontCare e -> A.DontCare <$> toAbstract e+ C.Highlighted m a -> A.Highlighted m <$> toAbstract a++ -- forall-generalize+ C.Generalized e -> do+ (s, e) <- collectGeneralizables $ toAbstract e+ pure $ A.generalized s e++instance ToAbstract C.ModuleAssignment where+ type AbsOfCon C.ModuleAssignment = (A.ModuleName, Maybe A.LetBinding)+ toAbstract (C.ModuleAssignment m es i)+ | null es && isDefaultImportDir i = (, Nothing) <$> toAbstract (OldModuleName m)+ | otherwise = do+ x <- C.NoName (getRange m) <$> fresh+ r <- checkModuleMacro LetApply LetOpenModule+ (getRange (m, es, i)) PublicAccess defaultErased x+ (C.SectionApp (getRange (m , es)) [] m es)+ DontOpen i+ case r of+ LetApply _ _ m' _ _ _ -> return (m', Just r)+ _ -> __IMPOSSIBLE__++instance ToAbstract c => ToAbstract (FieldAssignment' c) where+ type AbsOfCon (FieldAssignment' c) = FieldAssignment' (AbsOfCon c)++ toAbstract = traverse toAbstract++instance ToAbstract (C.Binder' (NewName C.BoundName)) where+ type AbsOfCon (C.Binder' (NewName C.BoundName)) = A.Binder++ toAbstract (C.Binder p o n) = do+ let name = C.boundName $ newName n++ -- If we do have a pattern then the variable needs to be inserted+ -- so we do need a proper internal name for it.+ --+ -- Amy, 2024-10-18: If we generated a name, then mark the binder+ -- name as being inserted.+ (n, o) <- if not (isNoName name && isJust p) then pure (n, o) else do+ n' <- freshConcreteName (getRange $ newName n) 0 patternInTeleName+ pure (fmap (\ n -> n { C.boundName = n' }) n, InsertedBinderName)++ n <- toAbstract n+ -- Expand puns if optHiddenArgumentPuns is True.+ p <- traverse expandPunsOpt p+ -- Actually parsing the pattern, checking it is linear,+ -- and bind its variables+ p <- traverse parsePattern p+ p <- toAbstract p+ checkPatternLinearity p $ \ys ->+ typeError $ RepeatedVariablesInPattern ys+ bindVarsToBind+ p <- toAbstract p+ pure $ A.Binder p o n++instance ToAbstract C.LamBinding where+ type AbsOfCon C.LamBinding = Maybe A.LamBinding++ toAbstract (C.DomainFree x) = do+ tac <- scopeCheckTactic x+ Just . A.DomainFree tac <$> toAbstract (updateNamedArg (fmap $ NewName LambdaBound) x)+ toAbstract (C.DomainFull tb) = fmap A.DomainFull <$> toAbstract tb++-- | Scope check tactic attribute, make sure they are only used in hidden arguments.+scopeCheckTactic :: NamedArg C.Binder -> ScopeM A.TacticAttribute+scopeCheckTactic x = do+ let ctac = bnameTactic $ C.binderName $ namedArg x+ let r = getRange ctac+ setCurrentRange r $ do+ tac <- traverse toAbstract ctac+ if null tac || hidden x then return tac else empty <$ warning UselessTactic++makeDomainFull :: C.LamBinding -> C.TypedBinding+makeDomainFull (C.DomainFull b) = b+makeDomainFull (C.DomainFree x) = C.TBind r (singleton x) $ C.Underscore r Nothing+ where r = getRange x++-- | Common code for finishing the scope checking of a "qualified" operation.+-- By itself, does not affect name resolution at all!+--+-- If the 'C.QName' is present, then it must refer to an existing+-- module, and a 'A.Qualified' wrapper is generated around the+-- expression.+qualifiedExpression :: Maybe C.QName -> ScopeM A.Expr -> ScopeM A.Expr+qualifiedExpression Nothing cont = cont+qualifiedExpression (Just mod) cont = do+ mod <- toAbstract (OldModuleName mod)+ A.Qualified mod <$> cont++instance ToAbstract C.TypedBinding where+ type AbsOfCon C.TypedBinding = Maybe A.TypedBinding++ toAbstract (C.TBind r xs t) = do+ t' <- toAbstractCtx TopCtx t+ -- Invariant: all tactics are the same+ -- (distributed in the parser, TODO: don't)+ let tacArg = List1.find (not . null . bnameTactic . C.binderName . namedArg) xs+ tac <- maybe (pure empty) scopeCheckTactic tacArg++ let fin = all (bnameIsFinite . C.binderName . namedArg) xs+ xs' <- toAbstract $ fmap (updateNamedArg (fmap $ NewName LambdaBound)) xs++ return $ Just $ A.TBind r (TypedBindingInfo tac fin) xs' t'+ toAbstract (C.TLet r ds) = A.mkTLet r <$> toAbstract (LetDefs ExprLetDef ds)++-- | Scope check a module (top level function).+--+scopeCheckNiceModule+ :: Range+ -> Access+ -> Erased+ -> C.Name+ -> C.Telescope+ -> ScopeM [A.Declaration]+ -> ScopeM A.Declaration+ -- ^ The returned declaration is an 'A.Section'.+scopeCheckNiceModule r p e name tel checkDs = do+ -- Andreas, 2025-03-29: clear @envCheckingWhere@+ -- We are no longer directly in a @where@ block if we enter a module.+ localTC (set eCheckingWhere C.NoWhere_) $+ checkWrappedModules p (splitModuleTelescope tel)+ where+ -- Andreas, 2013-12-10:+ -- If the module telescope contains open statements+ -- or module macros (Issue 1299),+ -- add an extra anonymous module around the current one.+ -- Otherwise, the open statements would create+ -- identifiers in the parent scope of the current module.+ -- But open statements in the module telescope should+ -- only affect the current module!+ -- Ulf, 2024-11-21 (#7440): We need the wrapper module to have to correct parameters, otherwise+ -- open public of a module created in the telescope will behave incorrectly when applying the+ -- outer module.+ splitModuleTelescope :: C.Telescope -> [C.Telescope]+ splitModuleTelescope [] = [[]]+ splitModuleTelescope (b : tel) =+ case b of+ C.TLet _ ds | any needsWrapper ds -> [] : addBind b (splitModuleTelescope tel)+ _ -> addBind b $ splitModuleTelescope tel+ where+ addBind b (tel : ms) = (b : tel) : ms+ addBind _ [] = __IMPOSSIBLE__++ needsWrapper C.ModuleMacro{} = True+ needsWrapper C.Open{} = True+ needsWrapper C.Import{} = True -- not __IMPOSSIBLE__, see Issue #1718+ -- However, it does not matter what we return here, as this will+ -- become an error later: "Not a valid let-declaration".+ -- (Andreas, 2015-11-17)+ needsWrapper (C.Mutual _ ds) = any needsWrapper ds+ needsWrapper (C.Abstract _ ds) = any needsWrapper ds+ needsWrapper (C.Private _ _ ds) = any needsWrapper ds+ needsWrapper _ = False++ checkWrappedModules :: Access -> [C.Telescope] -> ScopeM A.Declaration+ checkWrappedModules _ [] = __IMPOSSIBLE__+ checkWrappedModules p [tel] = scopeCheckNiceModule_ r p name tel checkDs+ checkWrappedModules p (tel : tels) =+ scopeCheckNiceModule_ r p noName_ tel $ singleton <$>+ checkWrappedModules PublicAccess tels -- Inner modules are PublicAccess (see #4350)++ -- The actual workhorse:+ scopeCheckNiceModule_ :: Range -> Access -> C.Name -> C.Telescope -> ScopeM [A.Declaration] -> ScopeM A.Declaration+ scopeCheckNiceModule_ r p name tel checkDs = do++ -- Check whether we are dealing with an anonymous module.+ -- This corresponds to a Coq/LEGO section.+ (name, p', open) <- do+ if isNoName name then do+ (i :: NameId) <- fresh+ return (C.NoName (getRange name) i, privateAccessInserted, True)+ else return (name, p, False)++ -- Check and bind the module, using the supplied check for its contents.+ aname <- toAbstract (NewModuleName name)+ d <- snd <$> do+ scopeCheckModule r e (C.QName name) aname tel checkDs+ bindModule p' name aname++ -- If the module was anonymous open it public+ -- unless it's private, in which case we just open it (#2099)+ when open $+ void $ -- We can discard the returned default A.ImportDirective.+ openModule empty TopOpenModule (Just aname) (C.QName name) $+ defaultImportDir { publicOpen = boolToMaybe (p == PublicAccess) empty }+ return d++-- | We for now disallow let-bindings in @data@ and @record@ telescopes.+-- This due "nested datatypes"; there is no easy interpretation of+-- @+-- data D (A : Set) (open M A) (b : B) : Set where+-- c : D (A × A) b → D A b+-- @+-- where @B@ is brought in scope by @open M A@.++class EnsureNoLetStms a where+ ensureNoLetStms :: a -> ScopeM ()++ default ensureNoLetStms :: (Foldable t, EnsureNoLetStms b, t b ~ a) => a -> ScopeM ()+ ensureNoLetStms = traverse_ ensureNoLetStms++instance EnsureNoLetStms C.Binder where+ ensureNoLetStms arg@(C.Binder p _ n) =+ when (isJust p) $ typeError $ IllegalPatternInTelescope arg++instance EnsureNoLetStms C.TypedBinding where+ ensureNoLetStms = \case+ tb@C.TLet{} -> typeError $ IllegalLetInTelescope tb+ C.TBind _ xs _ -> traverse_ (ensureNoLetStms . namedArg) xs++instance EnsureNoLetStms a => EnsureNoLetStms (LamBinding' a) where+ ensureNoLetStms = \case+ -- GA: DO NOT use traverse here: `LamBinding'` only uses its parameter in+ -- the DomainFull constructor so we would miss out on some potentially+ -- illegal lets! Cf. #4402+ C.DomainFree a -> ensureNoLetStms a+ C.DomainFull a -> ensureNoLetStms a++instance EnsureNoLetStms a => EnsureNoLetStms (Named_ a) where+instance EnsureNoLetStms a => EnsureNoLetStms (NamedArg a) where+instance EnsureNoLetStms a => EnsureNoLetStms [a] where+++-- | Returns the scope inside the checked module.+scopeCheckModule+ :: Range -- ^ The range of the module.+ -> Erased -- ^ Is the module erased?+ -> C.QName -- ^ The concrete name of the module.+ -> A.ModuleName -- ^ The abstract name of the module.+ -> C.Telescope -- ^ The module telescope.+ -> ScopeM [A.Declaration] -- ^ The code for checking the module contents.+ -> ScopeM (ScopeInfo, A.Declaration)+ -- ^ The returned declaration is an 'A.Section'.+scopeCheckModule r e x qm tel checkDs = do+ printScope "module" 40 $ "checking module " ++ prettyShow x+ -- Andreas, 2013-12-10: Telescope does not live in the new module+ -- but its parent, so check it before entering the new module.+ -- This is important for Nicolas Pouillard's open parametrized modules+ -- statements inside telescopes.+ res <- withLocalVars $ do+ tel <- toAbstract (GenTel tel)+ withCurrentModule qm $ do+ -- pushScope m+ -- qm <- getCurrentModule+ printScope "module" 40 $ "inside module " ++ prettyShow x+ ds <- checkDs+ scope <- getScope+ return (scope, A.Section r e (qm `withRangesOfQ` x) tel ds)++ -- Binding is done by the caller+ printScope "module" 40 $ "after module " ++ prettyShow x+ return res++-- | Temporary data type to scope check a file.+data TopLevel a = TopLevel+ { topLevelSourceFile :: SourceFile+ -- ^ The file from which we loaded this module.+ , topLevelExpectedName :: TopLevelModuleName+ -- ^ The expected module name+ -- (coming from the import statement that triggered scope checking this file).+ , topLevelTheThing :: a+ -- ^ The file content.+ }++data TopLevelInfo = TopLevelInfo+ { topLevelDecls :: [A.Declaration]+ , topLevelScope :: ScopeInfo -- ^ as seen from inside the module+ }++-- | The top-level module name.++topLevelModuleName :: TopLevelInfo -> A.ModuleName+topLevelModuleName = (^. scopeCurrent) . topLevelScope++-- | Top-level declarations are always+-- @+-- (import|open)* -- a bunch of possibly opened imports+-- module ThisModule ... -- the top-level module of this file+-- @+instance ToAbstract (TopLevel [C.Declaration]) where+ type AbsOfCon (TopLevel [C.Declaration]) = TopLevelInfo++ toAbstract (TopLevel src expectedMName ds) =+ -- A file is a bunch of preliminary decls (imports etc.)+ -- plus a single module decl.+ case C.spanAllowedBeforeModule ds of++ -- If there are declarations after the top-level module+ -- we have to report a parse error here.+ (_, C.Module{} : d : _) -> setCurrentRange d $ typeError DeclarationsAfterTopLevelModule++ -- Otherwise, proceed.+ (outsideDecls, [ C.Module r e m0 tel insideDecls ]) -> do+ -- If the module name is _ compute the name from the file path+ (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+ -- name as the file. In this case, it is highly likely that the user+ -- put some non-allowed declarations before the top-level module in error.+ -- Andreas, 2017-10-19, issue #2808+ -- Widen this check to:+ -- If the first module of the insideDecls has the same name as the file,+ -- report an error.+ case flip span insideDecls $ \case { C.Module{} -> False; _ -> True } of+ (ds0, (C.Module _ _ m1 _ _ : _))+ | 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.+ , r == beginningOfFile (getRange insideDecls) -> do++ -- GA #4888: We know we are in a bad place. But we still scopecheck+ -- the initial segment on the off chance we generate a better error+ -- message.+ void importPrimitives+ void $ scopeCheckDeclarations outsideDecls+ void $ scopeCheckDeclarations ds0+ -- Fail with a crude error otherwise+ setCurrentRange ds0 $ typeError IllegalDeclarationBeforeTopLevelModule++ -- Otherwise, reconstruct the top-level module name+ _ -> do+ file <- srcFilePath src+ let m = C.QName $ setRange (getRange m0) $+ C.simpleName $ stringToRawName $+ rootNameModule file+ top <- TCM.topLevelModuleName+ (rawTopLevelModuleNameForQName m){ rawModuleNameInferred = True }+ -- Andreas, 2026-03-01, issue #6173+ -- Need to make sure the reconstructed module name+ -- matches the one we use to import it,+ -- otherwise we get internal errors later.+ checkModuleName top src (Just expectedMName)+ 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+ -- -- its import. For flat file structures, this is the same.+ -- -- For hierarchical file structures, this reverses the behavior:+ -- -- Loading the file by itself will fail, but it can be imported.+ -- -- The previous behavior is: it can be loaded by itself, but not+ -- -- be imported+ -- then return $ C.fromTopLevelModuleName expectedMName+ else do+ -- Andreas, 2014-03-28 Issue 1078+ -- We need to check the module name against the file name here.+ -- Otherwise one could sneak in a lie and confuse the scope+ -- checker.+ top <- TCM.topLevelModuleName+ (rawTopLevelModuleNameForQName m0)+ checkModuleName top src (Just expectedMName)+ return (m0, top)+ setTopLevelModule top+ am <- toAbstract (NewModuleQName m)+ primitiveImport <- importPrimitives+ -- Scope check the declarations outside+ outsideDecls <- scopeCheckDeclarations outsideDecls+ (insideScope, insideDecl) <- scopeCheckModule r e m am tel $+ scopeCheckDeclarations insideDecls+ -- Andreas, 2020-05-13, issue #1804, #4647+ -- Do not eagerly remove private definitions, only when serializing+ -- let scope = over scopeModules (fmap $ restrictLocalPrivate am) insideScope+ let scope = insideScope+ setScope scope++ -- While scope-checking the top-level module we might have+ -- encountered several (possibly nested) opaque blocks. We+ -- must now ensure that these have transitively-closed+ -- unfolding sets.+ saturateOpaqueBlocks++ return $ TopLevelInfo (primitiveImport ++ outsideDecls ++ [ insideDecl ]) scope++ -- We hit a declaration that is not allowed before the top-level module:+ (_, d : _) -> setCurrentRange d $ typeError IllegalDeclarationBeforeTopLevelModule++ -- We already inserted the missing top-level module, see+ -- 'Agda.Syntax.Parser.Parser.figureOutTopLevelModule',+ -- thus, the case of no top-level module is impossible:+ _ -> __IMPOSSIBLE__+++-- | Declaration @open import Agda.Primitive using (Set)@ when 'optImportSorts'.+-- @Prop@ is added when 'optProp', and @SSet@ when 'optTwoLevel'.+importPrimitives :: ScopeM [A.Declaration]+importPrimitives = do+ ifNotM (optImportSorts <$> pragmaOptions) (return []) {- else -} do+ prop <- isPropEnabled+ twoLevel <- isTwoLevelEnabled+ -- Add implicit `open import Agda.Primitive using (Prop; Set; SSet)`+ let agdaPrimitiveName = Qual (C.simpleName "Agda") $ C.QName $ C.simpleName "Primitive"+ usingDirective = map (ImportedName . C.simpleName) $ concat+ [ [ "Prop" | prop ]+ , [ "Set" | True ]+ , [ "SSet" | twoLevel ]+ ]+ directives = ImportDirective noRange (Using usingDirective) [] [] Nothing+ importAgdaPrimitive = [C.Import (C.DoOpen empty) empty agdaPrimitiveName empty directives]+ -- We don't want UnusedImports warnings when importing the primitives,+ -- since the open statement was not assembled by the user.+ locallyTCState stWarningSet (Set.\\ unusedImportsWarnings) do+ scopeCheckDeclarations importAgdaPrimitive++-- | runs Syntax.Concrete.Definitions.niceDeclarations on main module+niceDecls :: DoWarn -> [C.Declaration] -> ([NiceDeclaration] -> ScopeM a) -> ScopeM a+niceDecls warn ds ret = setCurrentRange ds $ computeFixitiesAndPolarities warn ds $ do++ -- Some pragmas are not allowed in safe mode unless we are in a builtin module.+ -- So we need to tell the nicifier whether it should yell about unsafe pragmas.+ isSafe <- Lens.getSafeMode <$> pragmaOptions+ safeButNotBuiltin <- and2M+ -- NB: BlockArguments allow bullet-point style argument lists using @do@, hehe!+ do pure isSafe+ do not <$> do isBuiltinModuleWithSafePostulates . fromMaybe __IMPOSSIBLE__ =<< viewTC eCurrentPath++ -- We need to pass the fixities to the nicifier for clause grouping.+ fixs <- useScope scopeFixities+ niceEnv <- NiceEnv safeButNotBuiltin <$> viewTC eCheckingWhere++ -- Run nicifier.+ let (result, warns) = runNice niceEnv $ niceDeclarations fixs ds++ -- Respect the @DoWarn@ directive. For this to be sound, we need to know for+ -- sure that each @Declaration@ is checked at least once with @DoWarn@.+ unless (warn == NoWarn || null warns) $ do+ -- If there are some warnings and the --safe flag is set,+ -- we check that none of the NiceWarnings are fatal+ when isSafe $ do+ let (errs, ws) = List.partition unsafeDeclarationWarning warns+ -- If some of them are, we fail+ List1.unlessNull errs \ errs -> do+ List1.unlessNull ws \ ws -> warnings $ fmap NicifierIssue ws+ tcerrs <- mapM (warning_ . NicifierIssue) errs+ setCurrentRange errs $ typeError $ NonFatalErrors $ Set1.fromList tcerrs+ -- Otherwise we simply record the warnings+ mapM_ (\ w -> warning' (dwLocation w) $ NicifierIssue w) warns+ case result of+ Left (DeclarationException loc e) -> do+ reportSLn "error" 2 $ "Error raised at " ++ prettyShow loc+ setCurrentRange e $ typeError $ NicifierError e+ Right ds -> ret ds++-- | Wrapper to avoid instance conflict with generic list instance.+scopeCheckDeclarations :: [C.Declaration] -> ScopeM [A.Declaration]+scopeCheckDeclarations ds = niceDecls DoWarn ds \ niceds -> catMaybes <$> toAbstract niceds++-- | Where did these 'LetDef's come from?+data LetDefOrigin+ = ExprLetDef+ -- ^ A let expression or do statement+ | RecordLetDef+ -- ^ Definitions in a record declaration, before the last field+ deriving (Eq, Show)++data LetDefs = LetDefs LetDefOrigin (List1 C.Declaration)++instance ToAbstract LetDefs where+ type AbsOfCon LetDefs = [A.LetBinding]++ toAbstract :: LetDefs -> ScopeM (AbsOfCon LetDefs)+ toAbstract (LetDefs wh ds) =+ List1.concat <$> niceDecls DoWarn (List1.toList ds) \ nds -> mapM (scopeCheckLetDef wh) nds++-- | Raise appropriate (error-)warnings for if a declaration with+-- illegal access, macro flag, or abstractness appear in a let+-- expression.+checkLetDefInfo :: LetDefOrigin -> Access -> IsMacro -> IsAbstract -> ScopeM ()+checkLetDefInfo wh access macro abstract = do+ when (abstract == AbstractDef) $ warning AbstractInLetBindings++ when (macro == MacroDef) $ warning MacroInLetBindings++ case access of+ -- Marking a let declaration as private should only raise a warning+ -- in explicit, user-written expressions.+ --+ -- It should not raise a warning when scope-checking the type of a+ -- record constructor (it has an effect there).+ PrivateAccess rng _+ | wh == ExprLetDef -> scopeWarning (UselessPrivate rng)+ _ -> pure ()++scopeCheckLetDef :: LetDefOrigin -> NiceDeclaration -> ScopeM (List1 A.LetBinding)+scopeCheckLetDef wh d = setCurrentRange d do+ case d of+ NiceMutual _ _ _ _ d@(C.FunSig _ access _ instanc macro info _ _ x t :| [C.FunDef _ _ abstract _ _ _ _ (cl :| [])]) -> do+ checkLetDefInfo wh access macro abstract++ t <- toAbstract t+ -- We bind the name here to make sure it's in scope for the LHS (#917).+ -- It's unbound for the RHS in letToAbstract.+ fx <- getConcreteFixity x++ x <- A.unBind <$> toAbstract (NewName LetBound $ mkBoundName x fx)+ (x', e) <- letToAbstract cl++ -- There are sometimes two instances of the let-bound variable,+ -- one declaration and one definition (see issue #1618).+ -- Andreas, 2015-08-27 keeping both the range of x and x' solves Issue 1618.+ -- The situation is+ -- @+ -- let y : t+ -- y = e+ -- @+ -- and we need to store the ranges of both occurences of y so that+ -- the highlighter does the right thing.+ let x2 = setRange (fuseRange x x') x++ -- If InstanceDef set info to Instance+ let info' = case instanc of+ InstanceDef _ -> makeInstance info+ NotInstanceDef -> info++ return $+ A.LetBind (LetRange $ getRange d) info' (A.mkBindName x2) t e :|+ []++ -- Function signature without a body+ C.Axiom _ acc abs instanc info x t -> do+ checkLetDefInfo wh acc NotMacroDef abs++ t <- toAbstract t+ fx <- getConcreteFixity x+ x <- toAbstract (NewName LetBound $ mkBoundName x fx)++ mod <- currentModule+ checkAllowedAxiom info $ A.qualify mod (unBind x)++ let+ info' = case instanc of+ InstanceDef _ -> makeInstance info+ NotInstanceDef -> info++ pure $ A.LetAxiom (LetRange $ getRange d) info' x t :| []++ -- irrefutable let binding, like .(x , y) = rhs+ NiceFunClause r PublicAccess ConcreteDef tc cc catchall d@(C.FunClause ai lhs@(C.LHS p0 [] []) rhs0 whcl ca) -> do+ noWhereInLetBinding whcl+ rhs <- letBindingMustHaveRHS rhs0+ -- Expand puns if optHiddenArgumentPuns is True.+ p0 <- expandPunsOpt p0+ mp <- setCurrentRange p0 $+ (Right <$> parsePattern p0)+ `catchError`+ (return . Left)+ case mp of+ Right p -> do+ rhs <- toAbstract rhs+ setCurrentRange p0 $ do+ p <- toAbstract p+ checkValidLetPattern p+ checkPatternLinearity p $ \ys ->+ typeError $ RepeatedVariablesInPattern ys+ bindVarsToBind+ p <- toAbstract p+ return $ singleton $ A.LetPatBind (LetRange r) ai p rhs+ -- It's not a record pattern, so it should be a prefix left-hand side+ Left err ->+ case definedName p0 of+ Nothing -> throwError err+ Just x -> scopeCheckLetDef wh $ NiceMutual empty tc cc YesPositivityCheck+ (C.FunSig r PublicAccess ConcreteDef NotInstanceDef NotMacroDef+ info tc cc x (C.Underscore (getRange x) Nothing)+ :| [ C.FunDef r __IMPOSSIBLE__ ConcreteDef NotInstanceDef __IMPOSSIBLE__ __IMPOSSIBLE__ __IMPOSSIBLE__+ $ singleton $ C.Clause x (ca <> catchall) ai lhs (C.RHS rhs) NoWhere []+ ])+ where info = setOrigin Inserted ai+ where+ definedName (C.IdentP _ (C.QName x)) = Just x+ definedName C.IdentP{} = Nothing+ definedName (C.RawAppP _ (List2 p _ _)) = definedName p+ definedName (C.ParenP _ p) = definedName p+ definedName C.WildP{} = Nothing -- for instance let _ + x = x in ... (not allowed)+ definedName C.AbsurdP{} = Nothing+ definedName C.AsP{} = Nothing+ definedName C.DotP{} = Nothing+ definedName C.EqualP{} = Nothing+ definedName C.LitP{} = Nothing+ definedName C.RecP{} = Nothing+ definedName C.QuoteP{} = Nothing+ definedName C.HiddenP{} = Nothing -- Not impossible, see issue #2291+ definedName C.InstanceP{} = Nothing+ definedName C.WithP{} = Nothing+ definedName C.AppP{} = Nothing -- Not impossible, see issue #4586+ definedName C.OpAppP{} = __IMPOSSIBLE__+ definedName C.EllipsisP{} = Nothing -- Not impossible, see issue #3937++ -- You can't open public in a let+ NiceOpen kwr x dir -> do+ dir <- uselessPublic UselessPublicLet dir+ m <- toAbstract (OldModuleName x)+ adir <- openModule_ kwr LetOpenModule x dir+ let minfo = ModuleInfo+ { minfoRange = getRange (kwr, x, dir)+ , minfoAsName = Nothing+ , minfoAsTo = renamingRange dir+ , minfoOpenShort = DoOpen kwr+ , minfoDirective = Just dir+ }+ return $ singleton $ A.LetOpen minfo m adir++ NiceModuleMacro r p erased x modapp open dir -> do+ dir <- uselessPublic UselessPublicLet dir+ -- Andreas, 2014-10-09, Issue 1299: module macros in lets need+ -- to be private+ singleton <$> checkModuleMacro LetApply LetOpenModule r+ privateAccessInserted erased x modapp open dir++ _ -> notAValidLetBinding Nothing++ where+ letToAbstract (C.Clause top _catchall _ai (C.LHS p [] []) rhs0 wh []) = do+ noWhereInLetBinding wh+ rhs <- letBindingMustHaveRHS rhs0+ (x, args) <- do+ res <- setCurrentRange p $ parseLHS NoDisplayLHS (C.QName top) p+ case res of+ C.LHSHead x args -> return (x, args)+ C.LHSProj{} -> notAValidLetBinding $ Just CopatternsNotAllowed+ C.LHSWith{} -> __IMPOSSIBLE__ -- notAValidLetBinding $ Just WithPatternsNotAllowed+ C.LHSEllipsis{} -> __IMPOSSIBLE__ -- notAValidLetBinding $ Just EllipsisNotAllowed++ e <- localToAbstract args $ \args -> do+ bindVarsToBind+ -- Make sure to unbind the function name in the RHS, since lets are non-recursive.+ rhs <- unbindVariable top $ toAbstract rhs+ foldM lambda rhs (reverse args) -- just reverse because these are DomainFree+ return (x, e)++ letToAbstract _ = notAValidLetBinding Nothing++ -- These patterns all have a chance of being accepted in a lambda:+ allowedPat A.VarP{} = True+ allowedPat A.ConP{} = True+ allowedPat A.WildP{} = True+ allowedPat (A.AsP _ _ x) = allowedPat x+ allowedPat (A.RecP _ _ as) = all (allowedPat . view exprFieldA) as+ allowedPat (A.PatternSynP _ _ as) = all (allowedPat . namedArg) as++ -- These have no chance:+ allowedPat A.AbsurdP{} = False+ allowedPat A.ProjP{} = False+ allowedPat A.DefP{} = False+ allowedPat A.EqualP{} = False+ allowedPat A.WithP{} = False+ allowedPat A.DotP{} = False+ allowedPat A.LitP{} = False++ patternName (A.VarP bn) = Just bn+ patternName (A.AsP _ bn _) = Just bn+ patternName _ = Nothing++ -- Named patterns not allowed in let definitions+ lambda :: A.Expr -> NamedArg (A.Pattern' C.Expr) -> TCM A.Expr+ lambda e ai@(Arg info (Named thing pat)) | allowedPat pat = do+ let+ i = ExprRange (fuseRange pat e)++ pat <- toAbstract pat++ bn <- case pat of+ A.VarP bn -> pure bn+ A.AsP _ bn _ -> pure bn+ _ -> fmap mkBindName . freshAbstractName_ =<< freshConcreteName (getRange pat) 0 patternInTeleName++ -- Annoyingly, for the lambdas to be elaborated properly, we+ -- have to generate domainful binders. Domain-free binders can+ -- not be named (or have pattern matching!).+ --+ -- Moreover, we need to avoid generating named patterns that are+ -- like {B = B @ B}.++ let+ pat' = case pat of+ A.VarP{} -> Nothing+ pat -> Just pat+ binder = Arg info (Named thing (A.Binder pat' InsertedBinderName bn)) :| []++ pure $ A.Lam i (A.DomainFull (A.TBind (getRange ai) empty binder (A.Underscore empty))) e++ lambda _ _ = notAValidLetBinding Nothing++ noWhereInLetBinding :: C.WhereClause -> ScopeM ()+ noWhereInLetBinding = \case+ NoWhere -> return ()+ wh -> setCurrentRange wh $ notAValidLetBinding $ Just WhereClausesNotAllowed+ letBindingMustHaveRHS :: C.RHS -> ScopeM C.Expr+ letBindingMustHaveRHS = \case+ C.RHS e -> return e+ C.AbsurdRHS -> notAValidLetBinding $ Just MissingRHS++ -- Only record patterns allowed, but we do not exclude data constructors here.+ -- They will fail in the type checker.+ checkValidLetPattern :: A.Pattern' e -> ScopeM ()+ checkValidLetPattern a = unless (allowedPat a) do+ notAValidLetBinding $ Just NotAValidLetPattern++checkFieldArgInfo :: Bool -> ArgInfo -> ScopeM ArgInfo+checkFieldArgInfo warn =+ ensureLeftAdjoint msg >=>+ ensureMixedPolarity msg >=>+ ensureNotRew msg+ where+ msg = if warn then Just "field" else Nothing++instance ToAbstract NiceDeclaration where+ type AbsOfCon NiceDeclaration = Maybe A.Declaration++ toAbstract d = annotateDecls $+ traceS "scope.decl.trace" 50+ [ "scope checking declaration"+ , " " ++ prettyShow d+ ] $+ traceS "scope.decl.trace" 80 -- keep this debug message for testing issue #4016+ [ "scope checking declaration (raw)"+ , " " ++ show d+ ] $+ traceCall (ScopeCheckDeclaration d) $+ -- Andreas, 2015-10-05, Issue 1677:+ -- We record in the environment whether we are scope checking an+ -- abstract definition. This way, we can propagate this attribute+ -- the extended lambdas.+ applyWhenJust (niceHasAbstract d)+ (\ a -> localTC (set eAbstractMode (aDefToMode a))) $+ case d of++ -- Axiom (actual postulate)+ C.Axiom r p a i rel x t -> do+ (y, decl) <- toAbstractNiceAxiom AxiomName d+ checkAllowedAxiom rel y+ -- check the postulate+ return $ singleton decl++ C.NiceGeneralize r p i tac x t -> do+ reportSLn "scope.decl" 30 $ "found nice generalize: " ++ prettyShow x+ tac <- traverse (toAbstractCtx TopCtx) tac+ t_ <- toAbstractCtx TopCtx t+ let (s, t) = unGeneralized t_+ reportSLn "scope.decl" 50 $ "generalizations: " ++ show (Set.toList s, t)+ f <- getConcreteFixity x+ y <- freshAbstractQName f x+ bindName p GeneralizeName x y+ let info = (mkDefInfo x f p ConcreteDef r) { defTactic = tac }+ return $ singleton $ A.Generalize s info i y t++ -- Fields+ C.NiceField r p a i tac x (Arg ai t) -> do+ unless (p == PublicAccess) $ typeError PrivateRecordField+ ai <- checkFieldArgInfo False ai -- we already warned in recordConstructorType+ tac <- traverse (toAbstractCtx TopCtx) tac+ -- Interaction points for record fields have already been introduced+ -- when checking the type of the record constructor.+ -- To avoid introducing interaction points (IP) twice, we turn+ -- all question marks to underscores. (See issue 1138.)+ let maskIP (C.QuestionMark r _) = C.Underscore r Nothing+ maskIP e = e+ t <- toAbstractCtx TopCtx $ mapExpr maskIP t+ f <- getConcreteFixity x+ y <- freshAbstractQName f x+ -- Andreas, 2018-06-09 issue #2170+ -- We want dependent irrelevance without irrelevant projections,+ -- thus, do not disable irrelevant projections via the scope checker.+ -- irrProj <- optIrrelevantProjections <$> pragmaOptions+ -- unless (isIrrelevant t && not irrProj) $+ -- -- Andreas, 2010-09-24: irrelevant fields are not in scope+ -- -- this ensures that projections out of irrelevant fields cannot occur+ -- -- Ulf: unless you turn on --irrelevant-projections+ bindName' p FldName (instanceMetadata i) x y+ let info = (mkDefInfoInstance x f p a i NotMacroDef r) { defTactic = tac }+ return $ singleton $ A.Field info y (Arg ai t)++ -- Primitive function+ PrimitiveFunction r p a x t -> notAffectedByOpaque $ do+ t' <- traverse (toAbstractCtx TopCtx) t+ f <- getConcreteFixity x+ y <- freshAbstractQName f x+ bindName p PrimName x y+ unfoldFunction y+ let di = mkDefInfo x f p a r+ return $ singleton $ A.Primitive di y t'++ -- Definitions (possibly mutual)+ NiceMutual kwr tc cc pc ds -> do+ reportSLn "scope.mutual" 40 ("starting checking mutual definitions: " ++ prettyShow ds)+ ds' <- catMaybes <$> toAbstract (List1.toList ds)+ reportSLn "scope.mutual" 40 ("finishing checking mutual definitions")+ -- We only termination check blocks that do not have a measure.+ maybeToList <$> forM (List1.nonEmpty ds') \ ds' ->+ return $ A.Mutual (MutualInfo tc cc pc (fuseRange kwr ds)) ds'++ -- Type signatures+ C.FunSig r p a i m rel _ _ x t -> do+ let kind = if m == MacroDef then MacroName else FunName+ singleton . snd <$> toAbstractNiceAxiom kind (C.Axiom r p a i rel x t)++ -- Function definitions+ C.FunDef r ds a i _ _ x cs -> do+ printLocals 30 $ "checking def " ++ prettyShow x+ x' <- toAbstractOldName x+ cs <- toAbstract cs+ -- Andreas, 2017-12-04 the name must reside in the current module+ unlessM ((A.qnameModule x' ==) <$> getCurrentModule) $+ __IMPOSSIBLE__+ f <- getConcreteFixity x++ unfoldFunction x'+ di <- updateDefInfoOpacity (mkDefInfoInstance x f PublicAccess a i NotMacroDef r)+ return $ singleton $ A.FunDef di x' cs++ -- Uncategorized function clauses+ C.NiceFunClause _ _ _ _ _ _ (C.FunClause _ lhs _ _ _) ->+ typeError $ MissingTypeSignature $ MissingFunctionSignature lhs+ C.NiceFunClause{} -> __IMPOSSIBLE__++ -- Data definitions+ C.NiceDataSig r er p a pc uc x ls t -> do+ reportSLn "scope.data.sig" 40 ("checking DataSig for " ++ prettyShow x)+ singleton <$> scopeCheckDataOrRecSig IsData r er p a pc uc x ls t++ C.NiceDataDef r o a pc uc x pars cons -> singleton <$>+ scopeCheckDataDef r o a pc uc x pars cons++ -- Record definitions (mucho interesting)+ C.NiceRecSig r er p a pc uc eta x ls t -> do+ singleton <$> scopeCheckDataOrRecSig (IsRecord eta) r er p a pc uc x ls t++ C.NiceRecDef r o a pc uc eta x directives pars fields -> singleton <$>+ scopeCheckRecDef r o a pc uc eta x directives pars fields++ NiceModule r p a e x@(C.QName name) tel ds -> notAffectedByOpaque $ do+ reportSDoc "scope.decl" 70 $ vcat $+ [ text $ "scope checking NiceModule " ++ prettyShow x+ ]++ adecl <- traceCall (ScopeCheckDeclaration $+ NiceModule r p a e x tel []) $ do+ scopeCheckNiceModule r p e name tel $+ scopeCheckDeclarations ds++ reportSDoc "scope.decl" 70 $ vcat $+ [ text $ "scope checked NiceModule " ++ prettyShow x+ , nest 2 $ prettyA adecl+ ]+ return $ singleton adecl++ NiceModule _ _ _ _ m@C.Qual{} _ _ -> typeError QualifiedLocalModule++ NiceModuleMacro r p e x modapp open dir -> do+ reportSDoc "scope.decl" 70 $ vcat $+ [ text $ "scope checking NiceModuleMacro " ++ prettyShow x+ ]++ adecl <- checkModuleMacro Apply TopOpenModule+ r p e x modapp open dir++ reportSDoc "scope.decl" 70 $ vcat $+ [ text $ "scope checked NiceModuleMacro " ++ prettyShow x+ , nest 2 $ prettyA adecl+ ]+ return $ singleton adecl++ NiceOpen kwr x dir -> do+ (minfo, m, adir) <- checkOpen kwr Nothing x dir+ return $ singleton $ A.Open minfo m adir++ NicePragma r p -> do+ ps <- toAbstract p -- could result in empty list of pragmas+ return $ map (A.Pragma r) ps++ NiceImport doOpen kwR m (Left asClause) dir ->+ -- Case: already parsed @as@ clause.+ scopeCheckImport r m (Just asClause) doOpen dir+ where+ -- The Range of the whole declaration.+ r = getRange (doOpen, kwR, m, asClause, dir)++ NiceImport doOpen kwR m (Right []) dir ->+ -- Case: no module arguments, no @as@ clause.+ scopeCheckImport r m Nothing doOpen dir+ where+ -- The Range of the whole declaration.+ r = getRange (doOpen, kwR, m, dir)++ -- Case: some module arguments+ NiceImport doOpen kwR m (Right es) dir++ -- Subcase: @as@ clause+ | Just (asR, as) <- parseAsClause -> do++ -- Andreas, 2018-11-03, issue #3364, parse expression in as-clause as Name.+ 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)+ m' <- case as of+ -- Ok if no as-clause or it (already) contains a Name.+ Right asName -> return $ Just asName+ Left (C.Ident (C.QName asName)) -> return $ Just asName+ Left (C.Underscore r _) -> return $ Just $ C.noName r+ Left (C.Ident C.Qual{}) -> illformedAs "; a qualified name is not allowed here"+ Left e -> illformedAs ""++ if null initArgs then+ scopeCheckImport (getRange (doOpen, kwR, m, asR, m', dir)) m (m' <&> (`AsName` asR)) doOpen dir+ else do+ snoc <$> impStm asR+ <*> appStm (fromMaybe fresh' m') initArgs++ -- Subcase: no @as@ clause+ | DontOpen <- doOpen -> [] <$ do+ declarationWarning $ UselessImport fullRange+ | otherwise -> do+ snoc <$> impStm noRange+ <*> appStm (noName $ beginningOf $ getRange m) es++ where+ fullRange = getRange (doOpen, kwR, m, es, dir)+ impStm asR =+ scopeCheckImport (getRange (kwR, m))+ m (Just (AsName fresh asR))+ DontOpen defaultImportDir+ appStm m' es =+ checkModuleMacro Apply TopOpenModule (getRange (doOpen, m, es, dir))+ (PrivateAccess empty Inserted)+ defaultErased m' (C.SectionApp (getRange es) [] (C.QName fresh) es)+ doOpen dir+ (initArgs, last2Args) = splitAt (length es - 2) es+ parseAsClause = case last2Args of+ [ Ident (C.QName (C.Name asR InScope (Id x :| []))), e ]+ -- Andreas, 2018-11-03, issue #3364, accept anything after 'as'+ -- but require it to be a 'Name' in the scope checker.+ | rawNameToString x == "as" -> Just . (asR,) $+ if | Ident (C.QName m') <- e -> Right m'+ | otherwise -> Left e+ _ -> Nothing+ mkFresh i = C.Name (getRange m) C.NotInScope $ singleton $ Id $ stringToRawName $ ".#" ++ prettyShow m ++ "-" ++ show i+ unique = hashString $ prettyShow $ getRangeWithoutFile fullRange+ -- turn range into unique id, but delete file path+ -- which is absolute and messes up suite of failing tests+ -- (different hashs on different installations)+ -- TODO: Don't use (insecure) hashes in this way.+ fresh = mkFresh unique+ fresh' = mkFresh $ unique + 1++ NiceUnquoteDecl r p a i tc cc xs e -> do+ fxs <- mapM getConcreteFixity xs+ ys <- zipWithM freshAbstractQName fxs xs+ let meta = instanceMetadata i+ zipWithM_ (bindName' p QuotableName meta) xs ys+ e <- toAbstract e+ zipWithM_ (rebindName p OtherDefName meta) xs ys+ let mi = MutualInfo tc cc YesPositivityCheck r+ mapM_ unfoldFunction ys+ opaque <- contextIsOpaque+ return $ singleton $ A.Mutual mi $ singleton $+ A.UnquoteDecl mi+ [ (mkDefInfoInstance x fx p a i NotMacroDef r) { Info.defOpaque = opaque } | (fx, x) <- zip fxs xs ]+ ys e++ NiceUnquoteDef r p a _ _ xs e -> do+ fxs <- mapM getConcreteFixity xs+ ys <- mapM toAbstractOldName xs+ zipWithM_ (rebindName p QuotableName noMetadata) xs ys+ e <- toAbstract e+ zipWithM_ (rebindName p OtherDefName noMetadata) xs ys+ mapM_ unfoldFunction ys+ opaque <- contextIsOpaque+ return $ singleton $+ A.UnquoteDef+ [ (mkDefInfo x fx PublicAccess a r) { Info.defOpaque = opaque } | (fx, x) <- zip fxs xs ]+ ys e++ NiceUnquoteData r p a pc uc x cs e -> notAffectedByOpaque $ 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 noMetadata x x'+ zipWithM_ (rebindName p ConName noMetadata) cs cs'+ withCurrentModule m $ zipWithM_ (rebindName p ConName noMetadata) cs cs'++ fcs <- mapM getConcreteFixity cs+ let mi = MutualInfo TerminationCheck YesCoverageCheck pc r+ return $ singleton $+ A.Mutual mi $ singleton $+ 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" 30 $ "found nice pattern syn: " ++ prettyShow n+ reportSLn "scope.pat" 40 $ "arguments: " ++ prettyShow as+ (as, p) <- withLocalVars $ do+ -- Expand puns if optHiddenArgumentPuns is True.+ p <- parsePatternSyn =<< expandPunsOpt p+ p <- toAbstract p+ when (containsAsPattern p) $+ typeError AsPatternInPatternSynonym+ checkPatternLinearity p $ \ys ->+ typeError $ RepeatedVariablesInPattern ys+ -- Bind the pattern variables accumulated by @ToAbstract Pattern@ applied to the rhs.+ bindVarsToBind+ p <- A.noDotOrEqPattern (typeError DotPatternInPatternSynonym) p+ as <- mapM checkPatSynParam as+ List1.unlessNull (patternVars p List.\\ map whThing as) $ \ xs -> do+ typeError $ UnboundVariablesInPatternSynonym xs+ return (as, p)+ y <- freshAbstractQName' n+ bindName a PatternSynName n y+ -- Expanding pattern synonyms already at definition makes it easier to+ -- fold them back when printing (issue #2762).+ ep <- expandPatternSynonyms p+ modifyPatternSyns (Map.insert y (PatternSynDefn as ep))+ return $ singleton $ A.PatternSynDef y (map (fmap BindName) as) p -- only for highlighting, so use unexpanded version+ where+ checkPatSynParam :: WithHiding C.Name -> ScopeM (WithHiding A.Name)+ checkPatSynParam (WithHiding h x)+ | isUnderscore x = err $ UnusedVariableInPatternSynonym x+ | otherwise = resolveName (C.QName x) >>= \case+ VarName a (PatternBound h')+ | isInstance h, not (isInstance h') -> err $ IllegalInstanceVariableInPatternSynonym x+ | otherwise -> return $ WithHiding h a+ ConstructorName _ ys -> err $ PatternSynonymArgumentShadows IsConstructor x ys+ PatternSynResName ys -> err $ PatternSynonymArgumentShadows IsPatternSynonym x ys+ -- In the remaining cases, the name has not been bound by the pattern syn rhs.+ DefinedName{} -> failure+ FieldName{} -> failure+ VarName _ LambdaBound -> failure+ VarName _ LetBound -> failure+ VarName _ WithBound -> failure+ VarName _ MacroBound -> failure+ UnknownName -> failure+ where+ err = setCurrentRange x . typeError+ failure = err $ UnusedVariableInPatternSynonym x++ d@NiceLoneConstructor{} -> [] <$ do+ declarationWarning $ InvalidConstructorBlock $ getRange d++ d@(NiceOpaque kwr xs decls) -> do+ -- The names in an 'unfolding' clause must be unambiguous names of definitions:+ -- Resolve all the names, and use them as an initial unfolding set:+ names <- catMaybes <$> forM xs \ x -> do+ setCurrentRange x $ unambiguousConOrDef (const . UnfoldingWrongName) x+ -- Generate the identifier for this block:+ oid <- fresh+ -- Record the parent unfolding block, if any:+ parent <- viewTC eCurrentOpaqueId++ let r = getRange d+ stOpaqueBlocks `modifyTCLens` Map.insert oid OpaqueBlock+ { opaqueId = oid+ , opaqueUnfolding = HashSet.fromList names+ , opaqueDecls = mempty+ , opaqueParent = parent+ , opaqueRange = r+ }++ -- Keep going!+ localTC (set eCurrentOpaqueId (Just oid)) do+ out <- catMaybes <$> traverse toAbstract decls+ unless (any interestingOpaqueDecl out) $ setCurrentRange kwr $ warning UselessOpaque+ -- Andreas, 2025-12-12+ -- For reasons of caching, append the UnfoldingDecl (which is only for highlighting purposes)+ -- at the end. Otherwise, any change in the (potentially big) opaque block+ -- will invalidate caching for the whole block.+ -- With UnfoldingDecl at the end, it does not contribute to cache invalidation,+ -- because if something changed in the opaque block, one of its declarations changed+ -- which invalidates the cache for this declaration.+ pure $! out ++! [UnfoldingDecl r names]++declarationWarning :: MonadWarning m => DeclarationWarning' -> m ()+declarationWarning w = withCurrentCallStack \ stk -> do+ warning $ NicifierIssue $ DeclarationWarning stk w++-- | Scope check a data or record signature.+scopeCheckDataOrRecSig ::+ DataOrRecordEta+ -- ^ Whether we are checking a data or record signature.+ -> Range+ -- ^ The range of the data or record signature.+ -> Erased+ -- ^ Whether the data or record type is erased.+ -> Access+ -- ^ Whether the data or record type is private or public.+ -> IsAbstract+ -- ^ Whether the data or record type is abstract.+ -> PositivityCheck+ -- ^ Whether to perform positivity checking.+ -> UniverseCheck+ -- ^ Whether to check the constructors for universe consistency.+ -> C.Name+ -- ^ The name of the data or record type.+ -> C.Parameters+ -- ^ The parameters of the data or record type.+ -> C.Expr+ -- ^ The type of the data or record type.+ -> ScopeM A.Declaration+ -- ^ The resulting data or record signature in abstract syntax.+scopeCheckDataOrRecSig dataOrRec r er p a pc uc x ls t = do+ ensureNoLetStms ls+ withLocalVars $ do+ (ls', t') <- withCheckNoShadowing do+ case dataOrRec of+ IsData -> do+ (,) <$> toAbstract (GenTel $ map makeDomainFull ls)+ <*> toAbstract (C.Generalized t)+ IsRecord _ -> do+ -- Minor hack: record types don't have indices so we include t when+ -- computing generalised parameters, but in the type checker any named+ -- generalizable arguments in the sort should be bound variables.+ (,) <$> (fst <$> toAbstract (GenTelAndType (map makeDomainFull ls) t))+ <*> toAbstract t+ f <- getConcreteFixity x+ x' <- freshAbstractQName f x+ mErr <- bindName'' p namekind (generalizedVarsMetadata $ generalizeTelVars ls') x x'+ whenJust mErr $ \case+ err@(ClashingDefinition cn an _) | qnameModule (clashingQName an) == qnameModule x' -> do+ resolveName (C.QName x) >>= \case+ -- #4435: if a data type signature causes a ClashingDefinition error, and if+ -- the data type name is bound to an Axiom, then the error may be caused by+ -- the illegal type signature. Convert the NiceDataSig into a NiceDataDef+ -- (which removes the type signature) and suggest it as a possible fix.+ DefinedName p ax NoSuffix | anameKind ax == AxiomName -> do+ let suggestion = case dataOrRec of+ IsData -> NiceDataDef r Inserted a pc uc x (parametersToDefParameters ls) []+ IsRecord eta -> NiceRecDef r Inserted a pc uc eta x [] (parametersToDefParameters ls) []+ typeError $ ClashingDefinition cn an (Just suggestion)+ _ -> typeError err+ otherErr -> typeError otherErr+ return $ mkSig (mkDefInfo x f p a r) er x' ls' t'+ where+ namekind = case dataOrRec of+ IsData -> DataName+ IsRecord _ -> RecName+ mkSig = case dataOrRec of+ IsData -> A.DataSig+ IsRecord _ -> A.RecSig++-- | Scope check a data definition.+-- The data signature must have been checked already.+scopeCheckDataDef ::+ Range+ -- ^ The range of the data definition.+ -> Origin+ -- ^ The origin of the data definition.+ -- 'UserWritten' when the definition was written separately from the signature.+ -- 'Inserted' when there was no separate signature.+ -> IsAbstract+ -- ^ Whether the data definition is abstract.+ -> PositivityCheck+ -- ^ Whether to report positivity errors for this data type.+ -> UniverseCheck+ -- ^ Whether to check constructors' types for universe consistency.+ -> C.Name+ -- ^ The name of the data type.+ -> C.DefParameters+ -- ^ The parameters of the data type.+ -> [NiceDeclaration]+ -- ^ The constructors of the data type.+ -> ScopeM A.Declaration+scopeCheckDataDef r o a pc uc x pars cons =+ notAffectedByOpaque do+ reportSLn "scope.data.def" 40 ("checking " ++ show o ++ " DataDef for " ++ prettyShow x)+ (p, ax) <- retrieveDataOrRecName IsData x++ withLocalVars do+ -- Scope check parameters+ gvars <- bindGeneralizablesIfInserted o ax+ pars <- catMaybes <$> toAbstract (defParametersToParameters pars)++ -- Create the data module+ let x' = anameName ax+ -- Create the module for the qualified constructors+ let m = qnameToMName x'+ createModule (Just IsDataModule) m+ bindModule p x m -- make it a proper module++ cons <- checkConstructors cons+ cons <- toAbstract (map (DataConstrDecl m a p) cons)+ printScope "data" 40 $ "Checked data " ++ prettyShow x+ f <- getConcreteFixity x+ return $ A.DataDef (mkDefInfo x f PublicAccess a r) x' pc uc (DataDefParams gvars pars) cons+ where+ -- Filter out non-type signatures and error out on duplicate constructors.+ checkConstructors cons = do+ -- Only type signatures (for constructors) are allowed in data definitions.+ (cs, cons') <- unzip . catMaybes <$> forM cons \case+ d@(C.Axiom _ _ _ _ _ c _) -> pure $ Just (c, d)+ d -> Nothing <$ do+ setCurrentRange d $+ warning $ IllegalDeclarationInDataDefinition $ notSoNiceDeclarations d+ -- Check for duplicate constructors.+ List1.unlessNull (duplicates cs) $ \ dups -> do+ let bad = filter (`elem` dups) cs+ setCurrentRange bad $+ typeError $ DuplicateConstructors dups+ return cons'++-- | Scope check a record definition.+-- The record signature must have been checked already.+scopeCheckRecDef ::+ Range+ -- ^ The range of the record definition.+ -> Origin+ -- ^ The origin of the record definition.+ -- 'UserWritten' when the definition was written separately from the signature.+ -- 'Inserted' when there was no separate signature.+ -> IsAbstract+ -- ^ Whether the record definition is abstract.+ -> PositivityCheck+ -- ^ Whether to report positivity errors for this record type.+ -> UniverseCheck+ -- ^ Whether to check field types for universe consistency.+ -> ForceRecordEta+ -- ^ Whether this record comes with a @{-# ETA_EQUALITY #-}@ pragma.+ -> C.Name+ -- ^ The name of the record type.+ -> [RecordDirective]+ -- ^ The record directives, e.g., 'inductive', 'eta-equality', 'pattern'.+ -> C.DefParameters+ -- ^ The parameters of the record type.+ -> [C.Declaration]+ -- ^ The fields of the record type and other declarations in the record module.+ -> ScopeM A.Declaration+scopeCheckRecDef r o a pc uc forceEta x directives pars fields =+ notAffectedByOpaque do+ reportSLn "scope.rec.def" 40 ("checking " ++ show o ++ " RecDef for " ++ prettyShow x)++ -- #3008: Termination pragmas are ignored in records+ checkNoTerminationPragma InRecordDef fields++ -- Check record directives for consistency.+ RecordDirectives ind eta pat cm <- gatherRecordDirectives directives+ -- Andreas, 2020-04-19, issue #4560+ -- 'pattern' declaration is incompatible with 'coinductive' or 'eta-equality'.+ pat <- case pat of+ Just r+ | Just (Ranged _ CoInductive) <- ind -> Nothing <$ warn "coinductive"+ | Just (Ranged _ YesEta) <- eta -> Nothing <$ warn "eta"+ | otherwise -> return pat+ where warn = setCurrentRange r . warning . UselessPatternDeclarationForRecord+ Nothing -> return pat++ -- Retrieve the abstract name of the record type+ -- that was created when scope checking the record type signature.+ (p, ax) <- retrieveDataOrRecName IsRecord_ x+ let x' = anameName ax++ -- Preserve the local variable set since we add some generalizable ones.+ withLocalVars $ do+ gvars <- bindGeneralizablesIfInserted o ax+ pars <- catMaybes <$> toAbstract (defParametersToParameters pars)++ -- We scope check the fields a first time when putting together+ -- the type of the constructor.+ contel <- localToAbstract (RecordConstructorType fields) return++ -- Use the name @x'@ of the record type also as name of the new record module.+ let m = qnameToMName x'+ printScope "rec" 25 "before record"+ createModule (Just IsRecordModule) m++ -- We scope check the fields a second time, as actual fields.+ afields <- withCurrentModule m $ do+ afields <- scopeCheckDeclarations fields+ printScope "rec" 25 "checked fields"+ return afields++ -- Andreas, 2017-07-13 issue #2642 disallow duplicate fields+ -- Check for duplicate fields. (See "Check for duplicate constructors")+ do let fs :: [C.Name]+ fs = concat $ forMaybe fields $ \case+ C.Field _ fs -> Just $ fs <&> \case+ -- a Field block only contains field signatures+ C.FieldSig _ _ f _ -> f+ _ -> __IMPOSSIBLE__+ _ -> Nothing+ List1.unlessNull (duplicates fs) $ \ dups -> do+ let bad = filter (`elem` dups) fs+ setCurrentRange bad $+ typeError $ DuplicateFields dups++ bindModule p x m++ -- Name kind of the record constructor (inductive/coinductive).+ let conKind = maybe ConName (conKindOfName . rangedThing) ind++ -- Bind the record constructor.+ cm' <- case cm of++ -- Andreas, 2019-11-11, issue #4189, no longer add record constructor to record module.+ Just (c, inst) -> NamedRecCon <$> bindRecordConstructorName c conKind inst a p++ -- Amy, 2024-09-25: if the record does not have a named+ -- constructor, then generate the QName here.+ Nothing -> do+ -- The name is qualified by the record module @m@ so that it is+ -- copied along with the record module by 'copyScope'.+ -- (Record constructor names have a special printing rule in+ -- lookupQName, so the qualification does not show up in output.)+ constr <- withCurrentModule m $+ freshAbstractQName noFixity' $ simpleName "constructor"+ pure $ FreshRecCon constr++ -- Andreas, 2026-08-23: Make the constructor accessible as @R.constructor@+ -- by binding the pseudo-name @constructor@ in the record module.+ -- Note that this is just an alias; the constructor itself does not live+ -- in the record module (issue #4189).+ bindRecordConstructorPseudoName m conKind (recordConName cm')++ -- Return the translated record definition.+ let inst = caseMaybe cm NotInstanceDef snd+ printScope "rec" 25 "record complete"+ f <- getConcreteFixity x+ let params = DataDefParams gvars pars+ let dir' = RecordDirectives ind eta pat cm'+ return $ A.RecDef (mkDefInfoInstance x f PublicAccess a inst NotMacroDef r) x' pc uc forceEta dir' params contel afields++-- | Retrieve the abstract name of a data or record type+-- that was created by scope checking the data or record signature.+--+-- Check that this name does not clash with existing modules.+--+-- Also check that the data/record definition has been placed in the same module+-- as the data/record signature.+retrieveDataOrRecName :: DataOrRecord_ -> C.Name -> ScopeM (Access, AbstractName)+retrieveDataOrRecName dataOrRec x = do++ -- Retrieve the abstract name of the record type+ -- that was created when scope checking the record type signature.+ (p, ax) <- resolveName (C.QName x) >>= \case+ DefinedName p ax NoSuffix -> return (p, ax)+ _ -> typeError $ MissingTypeSignature $ ifThenElse dataOrRec MissingDataSignature MissingRecordSignature $ x++ -- Check for correct placement of this record definition wrt. the existing record signature.+ -- These checks give more precise errors than the generic 'checkForModuleClash' below.+ clashUnless x (ifThenElse dataOrRec DataName RecName) ax -- Andreas 2019-07-07, issue #3892+ livesInCurrentModule ax -- Andreas, 2017-12-04, issue #2862+ clashIfModuleAlreadyDefinedInCurrentModule x ax -- Andreas, 2019-07-07, issue #2576++ -- Andreas, 2026-02-28, issue #8435+ -- The nicifier bubbles signatures up, even beyond their matching definition.+ -- So, check that signature appeared before definition in the file.+ reportSDoc "scope.data.range" 40 $ vcat+ [ "ax = " <+> pure (pretty (PrintRange ax))+ , "defined at " <+> pure (pretty (PrintRange (nameBindingSite ax)))+ ]+ unless (getRange (nameBindingSite ax) <= getRange ax) do+ warning $ DefinitionBeforeDeclaration ax++ -- Check that the generated module doesn't clash with a previously+ -- defined module+ checkForModuleClash x++ return (p, ax)++-- | Scope check @[open] import M [as N] using/hiding/renaming@.+scopeCheckImport ::+ Range+ -- ^ Range of the whole import statement.+ -> C.QName+ -- ^ Name @M@ of the (file) module to import.+ -> Maybe (AsName' C.Name)+ -- ^ Possibly short name @as N@.+ -> OpenShortHand+ -- ^ Possibly @open@.+ -> C.ImportDirective+ -- ^ Limiting the scope.+ --+ -- In the case of @open@, this applies to the names brought in scope.+ --+ -- In the case of no @open@, this applies to the export list+ -- of the imported module itself.+ -- Several imports of the same file module accumulate accumulate exports,+ -- but see <https://github.com/agda/agda/issues/7656>.+ -> ScopeM [A.Declaration]+scopeCheckImport r x as open dir =+ setCurrentRange r do+ dir <- notPublicWithoutOpen open dir++ top <- TCM.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 top $ do+ printScope "import" 30 "before import:"+ (m0, i) <- scopeCheckFileImport top+ printScope "import" 30 $ "scope checked import: " ++ prettyShow i+ -- We don't want the top scope of the imported module (things happening+ -- before the module declaration)+ return (m0 `withRangesOfQ` x, Map.delete noModuleName i)++ -- Bind the desired module name to the right abstract name.+ (name, theAsSymbol, theAsName) <- case as of++ Just a | let y = asName a, not (isNoName y) -> do+ bindModule privateAccessInserted y m+ return (C.QName y, asRange a, Just y)++ _ -> do+ -- Don't bind if @import ... as _@ with "no name"+ whenNothing as $ bindQModule (privateAccessInserted) x m+ return (x, noRange, Nothing)++ -- Open if specified, otherwise apply import directives+ adir <- case open of++ -- With @open@ import directives apply to the opening.+ -- The module is thus present in its qualified form without restrictions.+ DoOpen kwr -> do++ -- Merge the imported scopes with the current scopes.+ -- This might override a previous import of @m@, but monotonously (add stuff).+ modifyScopes $ \ ms -> Map.unionWith mergeScope (Map.delete m ms) i+ recomputeInverseScope++ -- Andreas, 2019-05-29, issue #3818.+ -- Pass the resolved name to open instead triggering another resolution.+ -- This helps in situations like+ -- @+ -- module Top where+ -- module M where+ -- open import M+ -- @+ -- It is clear than in @open import M@, name @M@ must refer to a file+ -- rather than the above defined local module @M@.+ -- This already worked in the situation+ -- @+ -- module Top where+ -- module M where+ -- import M+ -- @+ -- Note that the manual desugaring of @open import@ as+ -- @+ -- module Top where+ -- module M where+ -- import M+ -- open M+ -- @+ -- will not work, as @M@ is now ambiguous in @open M@;+ -- the information that @M@ is external is lost here.+ (_minfo, _m, adir) <- checkOpen kwr (Just m) name dir+ return adir++ -- If not opening, import directives are applied to the original scope.+ DontOpen -> do+ (adir, i') <- Map.adjustM' (\m -> fmap recomputeNameParts <$> applyImportDirectiveM x dir m) m i+ -- Andreas, 2020-05-18, issue #3933+ -- We merge the new imports without deleting old imports, to be monotone.+ modifyScopes $ \ ms -> Map.unionWith mergeScope ms i'+ recomputeInverseScope+ return adir++ printScope "import" 30 "merged imported sig:"+ let minfo = ModuleInfo+ { minfoRange = r+ , minfoAsName = theAsName+ , minfoAsTo = getRange (theAsSymbol, renamingRange dir)+ , minfoOpenShort = open+ , minfoDirective = Just dir+ }+ return [ A.Import minfo m adir ]+++-- | Checking postulate or type sig. without checking safe flag.+toAbstractNiceAxiom :: KindOfName -> C.NiceDeclaration -> ScopeM (A.QName, A.Declaration)+toAbstractNiceAxiom kind (C.Axiom r p a i info x t) = do+ -- Amy, 2025-05-04, issue 7856: type signatures (more+ -- importantly extended lambdas within them) should not belong+ -- to opaque blocks+ --+ -- Note that only scope checking the type happens outside the+ -- block since a bit below we need the proper opaque id to+ -- possibly update the info.+ t' <- notUnderOpaque $ toAbstractCtx TopCtx t++ f <- getConcreteFixity x+ mp <- getConcretePolarity x+ y <- freshAbstractQName f x+ let isMacro | kind == MacroName = MacroDef+ | otherwise = NotMacroDef+ bindName' p kind (instanceMetadata i) x y+ definfo <- updateDefInfoOpacity $ mkDefInfoInstance x f p a i isMacro r+ return (y, A.Axiom kind definfo info mp y t')+toAbstractNiceAxiom _ _ = __IMPOSSIBLE__++-- | Check that the name is allowed to be postulated: either we are in a+-- builtin module, we are not in safe mode, or the axiom comes from a+-- lone type signature (and so will be reported later as a missing+-- definition)+checkAllowedAxiom :: ArgInfo -> A.QName -> ScopeM ()+checkAllowedAxiom info x = whenM+ (andM [ pure $ getOrigin info /= Inserted+ , Lens.getSafeMode <$> commandLineOptions+ , not <$> (isBuiltinModuleWithSafePostulates . fromMaybe __IMPOSSIBLE__ =<< viewTC eCurrentPath)+ ])+ (warning $ SafeFlagPostulate x)++interestingOpaqueDecl :: A.Declaration -> Bool+interestingOpaqueDecl (A.Mutual _ ds) = any interestingOpaqueDecl ds+interestingOpaqueDecl (A.ScopedDecl _ ds) = any interestingOpaqueDecl ds++interestingOpaqueDecl A.FunDef{} = True+interestingOpaqueDecl A.UnquoteDecl{} = True+interestingOpaqueDecl A.UnquoteDef{} = True++interestingOpaqueDecl _ = False++-- ** Helper functions for @opaque@+------------------------------------------------------------------------++-- | Add a 'QName' to the set of declarations /contained in/ the current+-- opaque block.+unfoldFunction :: A.QName -> ScopeM ()+unfoldFunction qn = viewTC eCurrentOpaqueId >>= \case+ Just id -> do+ let go Nothing = __IMPOSSIBLE__+ go (Just ob) = Just ob{ opaqueDecls = qn `HashSet.insert` opaqueDecls ob }+ stOpaqueBlocks `modifyTCLens` Map.alter go id+ Nothing -> pure ()++-- | Look up the current opaque identifier as a value in 'IsOpaque'.+contextIsOpaque :: ScopeM IsOpaque+contextIsOpaque = maybe TransparentDef OpaqueDef <$> viewTC eCurrentOpaqueId++updateDefInfoOpacity :: DefInfo -> ScopeM DefInfo+updateDefInfoOpacity di = (\a -> di { Info.defOpaque = a }) <$> contextIsOpaque++-- | Raise a warning indicating that the current Declaration is not+-- affected by opacity, but only if we are actually in an Opaque block.+notAffectedByOpaque :: ScopeM a -> ScopeM a+notAffectedByOpaque k = do+ whenM ((NoWhere_ ==) <$> viewTC eCheckingWhere) $+ whenJustM (viewTC eCurrentOpaqueId) \ _ ->+ warning NotAffectedByOpaque+ notUnderOpaque k++-- * Helper functions for @variable@ generalization+------------------------------------------------------------------------++unGeneralized :: A.Expr -> (Set A.QName, A.Expr)+unGeneralized (A.Generalized s t) = (Set1.toSet s, t)+unGeneralized (A.ScopedExpr si e) = A.ScopedExpr si <$> unGeneralized e+unGeneralized t = (mempty, t)++alreadyGeneralizing :: ScopeM Bool+alreadyGeneralizing = isJust <$> useTC stGeneralizedVars++-- | In the context of scope checking an expression, given a resolved name @d@:+--+-- * If @d@ is a @variable@ (generalizable), add it to the collection 'stGeneralizedVars'+-- of variables we wish to abstract over.+--+-- * Otherwise, do nothing.+--+class AddGeneralizable a where+ addGeneralizable :: a -> ScopeM ()++instance AddGeneralizable AbstractName where+ addGeneralizable :: AbstractName -> ScopeM ()+ addGeneralizable d = case anameKind d of+ GeneralizeName -> do+ gvs <- useTC stGeneralizedVars+ case gvs of -- Subtle: Use (left-biased) union instead of insert to keep the old name if+ -- already present. This way we can sort by source location when generalizing+ -- (Issue 3354).+ Just s -> stGeneralizedVars `setTCLens` Just (s `Set.union` Set.singleton (anameName d))+ Nothing -> typeError $ GeneralizeNotSupportedHere $ anameName d+ DisallowedGeneralizeName -> typeError $ GeneralizedVarInLetOpenedModule $ anameName d+ _ -> return ()++instance AddGeneralizable ResolvedName where+ addGeneralizable = \case+ -- Only 'DefinedName' can be a @variable@.+ DefinedName _ d NoSuffix -> addGeneralizable d+ DefinedName _ d Suffix{} -> return ()+ VarName{} -> return ()+ FieldName{} -> return ()+ ConstructorName{} -> return ()+ PatternSynResName{} -> return ()+ UnknownName{} -> return ()++collectGeneralizables :: ScopeM a -> ScopeM (Set A.QName, a)+collectGeneralizables m =+ -- #5683: No nested generalization+ ifM alreadyGeneralizing ((Set.empty,) <$> m) $+ {-else-} bracket_ open close $ do+ a <- m+ s <- useTC stGeneralizedVars+ case s of+ Nothing -> __IMPOSSIBLE__+ Just s -> return (s, a)+ where+ open = do+ gvs <- useTC stGeneralizedVars+ stGeneralizedVars `setTCLens` Just mempty+ pure gvs+ close = (stGeneralizedVars `setTCLens`)++createBoundNamesForGeneralizables :: Set A.QName -> ScopeM (Map A.QName A.Name)+createBoundNamesForGeneralizables vs =+ flip Map.traverseWithKey (Map.fromSet (const ()) vs) $ \ q _ -> do+ let x = nameConcrete $ qnameName q+ fx = nameFixity $ qnameName q+ freshAbstractName fx x++collectAndBindGeneralizables :: ScopeM a -> ScopeM (Map A.QName A.Name, a)+collectAndBindGeneralizables m = do+ fvBefore <- length <$> getLocalVars+ (s, res) <- collectGeneralizables m+ fvAfter <- length <$> getLocalVars+ -- We should bind the named generalizable variables as fresh variables+ binds <- createBoundNamesForGeneralizables s+ -- Issue #3735: We need to bind the generalizable variables outside any variables bound by `m`.+ outsideLocalVars (fvAfter - fvBefore) $ bindGeneralizables binds+ return (binds, res)++bindGeneralizables :: Map A.QName A.Name -> ScopeM ()+bindGeneralizables vars =+ forM_ (Map.toList vars) $ \ (q, y) ->+ bindVariable LambdaBound (nameConcrete $ qnameName q) y++-- | Bind generalizable variables if data or record decl was split by the system+-- (origin == Inserted)+bindGeneralizablesIfInserted :: Origin -> AbstractName -> ScopeM (Set A.Name)+bindGeneralizablesIfInserted Inserted y = bound <$ bindGeneralizables gvars+ where+ gvars = nameDataGeneralizedVars $ anameMetadata y+ bound = Set.fromList (Map.elems gvars)+bindGeneralizablesIfInserted UserWritten _ = return Set.empty+bindGeneralizablesIfInserted _ _ = __IMPOSSIBLE__++newtype GenTel = GenTel C.Telescope+data GenTelAndType = GenTelAndType C.Telescope C.Expr++instance ToAbstract GenTel where+ type AbsOfCon GenTel = A.GeneralizeTelescope+ toAbstract (GenTel tel) =+ uncurry A.GeneralizeTel <$> collectAndBindGeneralizables (catMaybes <$> toAbstract tel)++instance ToAbstract GenTelAndType where+ type AbsOfCon GenTelAndType = (A.GeneralizeTelescope, A.Expr)++ toAbstract (GenTelAndType tel t) = do+ (binds, (tel, t)) <- collectAndBindGeneralizables $+ (,) <$> toAbstract tel <*> toAbstract t+ return (A.GeneralizeTel binds (catMaybes tel), t)++-- ** Record directives+------------------------------------------------------------------------++-- | Check for duplicate record directives.+gatherRecordDirectives :: [C.RecordDirective] -> ScopeM C.RecordDirectives+gatherRecordDirectives ds = mapM_ gatherRecordDirective ds `execStateT` empty++-- | Fill the respective field of 'C.RecordDirectives' by the given 'C.RecordDirective'.+--+-- Ignore it with a dead-code warning if the field is already filled.+--+gatherRecordDirective :: C.RecordDirective -> StateT C.RecordDirectives ScopeM ()+gatherRecordDirective d = do+ dir@RecordDirectives{ recInductive = ind, recHasEta = eta, recPattern = pat, recConstructor = con } <- get+ case d of+ Induction ri -> assertNothing ind $ put dir{ recInductive = Just ri }+ Eta re -> assertNothing eta $ put dir{ recHasEta = Just re }+ PatternOrCopattern r -> assertNothing pat $ put dir{ recPattern = Just r }+ C.Constructor x inst -> assertNothing con $ put dir{ recConstructor = Just (x, inst) }+ where+ assertNothing :: Maybe a -> StateT C.RecordDirectives ScopeM () -> StateT C.RecordDirectives ScopeM ()+ assertNothing Nothing cont = cont+ assertNothing Just{} _ = lift $ setCurrentRange d $ warning $ DuplicateRecordDirective d++-- ** Helper functions for name clashes+------------------------------------------------------------------------++-- | Make sure definition is in same module as signature.+class LivesInCurrentModule a where+ livesInCurrentModule :: a -> ScopeM ()++instance LivesInCurrentModule AbstractName where+ livesInCurrentModule = livesInCurrentModule . anameName++instance LivesInCurrentModule A.QName where+ livesInCurrentModule x = do+ m <- getCurrentModule+ reportS "scope.data.def" 30+ [ " A.QName of data type: " ++ prettyShow x+ , " current module: " ++ prettyShow m+ ]+ unless (A.qnameModule x == m) $+ typeError $ DefinitionInDifferentModule x++-- | Unless the resolved 'AbstractName' has the given 'KindOfName',+-- report a 'ClashingDefinition' for the 'C.Name'.+clashUnless :: C.Name -> KindOfName -> AbstractName -> ScopeM ()+clashUnless x k ax = unless (anameKind ax == k) $+ typeError $ ClashingDefinition (C.QName x) (ClashingAbstractName ax) Nothing++-- | If a (data/record) module with the given name is already present in the current module,+-- we take this as evidence that a data/record with that name is already defined.+clashIfModuleAlreadyDefinedInCurrentModule :: C.Name -> AbstractName -> ScopeM ()+clashIfModuleAlreadyDefinedInCurrentModule x ax = do+ datRecMods <- catMaybes <$> do+ mapM (isDatatypeModule . amodName) =<< lookupModuleInCurrentModule x+ unlessNull datRecMods $ const $+ typeError $ ClashingDefinition (C.QName x) (ClashingAbstractName ax) Nothing++lookupModuleInCurrentModule :: C.Name -> ScopeM [AbstractModule]+lookupModuleInCurrentModule x =+ List1.toList' . Map.lookup x . nsModules . thingsInScope [PublicNS, PrivateNS] <$> getCurrentScope++-- ** Helper functions for constructor declarations+------------------------------------------------------------------------++data DataConstrDecl = DataConstrDecl A.ModuleName IsAbstract Access C.NiceDeclaration++-- | Bind a @data@ constructor.+bindConstructorName ::+ ModuleName -- ^ Name of @data@/@record@ module.+ -> C.Name -- ^ Constructor name.+ -> IsInstance+ -> IsAbstract+ -> Access+ -> ScopeM A.QName+bindConstructorName m x i a p = do+ f <- getConcreteFixity x+ -- The abstract name is the qualified one+ y <- withCurrentModule m $ freshAbstractQName f x+ -- Bind it twice, once unqualified and once qualified+ let meta = instanceMetadata i+ bindName' p' ConName meta x y+ withCurrentModule m $ bindName' p'' ConName meta x y+ return y+ where+ -- An abstract constructor is private (abstract constructor means+ -- abstract datatype, so the constructor should not be exported).+ p' = case a of+ AbstractDef -> privateAccessInserted+ _ -> p+ p'' = case a of+ AbstractDef -> privateAccessInserted+ _ -> PublicAccess++-- | Record constructors do not live in the record module (as it is parameterized).+-- Abstract constructors are bound privately, so that they are not exported.+bindRecordConstructorName :: C.Name -> KindOfName -> IsInstance -> IsAbstract -> Access -> ScopeM A.QName+bindRecordConstructorName x kind inst a p = do+ y <- freshAbstractQName' x+ bindName' p' kind (instanceMetadata inst) x y+ return y+ where+ -- An abstract constructor is private (abstract constructor means+ -- abstract datatype, so the constructor should not be exported).+ p' = case a of+ AbstractDef -> privateAccessInserted+ _ -> p++bindUnquoteConstructorName :: ModuleName -> Access -> C.Name -> ScopeM 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 = do+ modifyCurrentScope $ addNameToScope (localNameSpace p) c $ aname c'+ recomputeInverseScope -- András 2025-08-30: TODO: use addNameToInverseScope instead+ success = addName >> (withCurrentModule m $ addName)+ failure y = typeError $ ClashingDefinition (C.QName c) y Nothing+ case r of+ _ | isNoName c -> success+ UnknownName -> success+ ConstructorName i ds -> if all (isJust . isConName . anameKind) ds+ then success+ else failure $ ClashingAbstractName $ List1.head ds+ DefinedName _ d _ -> failure $ ClashingAbstractName d+ FieldName ds -> failure $ ClashingAbstractName $ List1.head ds+ PatternSynResName ds -> failure $ ClashingAbstractName $ List1.head ds+ VarName y _ -> failure $ ClashingQName $ qualify_ y+ return c'++instance ToAbstract DataConstrDecl where+ type AbsOfCon DataConstrDecl = A.Declaration++ toAbstract (DataConstrDecl m a p d) = traceCall (ScopeCheckDeclaration d) do+ case d of+ C.Axiom r p1 a1 i ai x t -> do+ -- unless (p1 == p) __IMPOSSIBLE__ -- This invariant is currently violated by test/Succeed/Issue282.agda+ unless (a1 == a) __IMPOSSIBLE__+ ai <- checkConstructorArgInfo ai+ t' <- toAbstractCtx TopCtx t+ -- The abstract name is the qualified one+ -- Bind it twice, once unqualified and once qualified+ f <- getConcreteFixity x+ y <- bindConstructorName m x i a p+ printScope "con" 25 "bound constructor"+ let defInfo = mkDefInfoInstance x f p a i NotMacroDef r+ return $ A.Axiom ConName defInfo ai Nothing y t'+ _ -> __IMPOSSIBLE__++-- | Delete (with warning) attributes that are illegal for constructor declarations.+checkConstructorArgInfo :: ArgInfo -> ScopeM ArgInfo+checkConstructorArgInfo =+ ensureRelevant msg >=>+ ensureNotLinear msg >=>+ ensureLeftAdjoint msg >=>+ ensureMixedPolarity msg >=>+ ensureNotRew msg+ where+ msg = Just "constructor"++ensureNotRew :: LensRewriteAnn a => Maybe String -> a -> ScopeM a+ensureNotRew ms = ignoreRew $ \ r ->+ whenJust ms \ s -> warning $ IgnoringRew s r++ensureRelevant :: LensRelevance a => Maybe String -> a -> ScopeM a+ensureRelevant ms info = do+ if isRelevant info then return info else do+ whenJust ms \ s -> warning $ FixingRelevance s (getRelevance info) relevant+ return $ setRelevance relevant info++ensureNotLinear :: LensQuantity a => Maybe String -> a -> ScopeM a+ensureNotLinear s info = do+ case getQuantity info of+ Quantityω{} -> return info+ Quantity0{} -> return info+ q@Quantity1{} -> do+ -- Andreas, 2024-08-24, "@1" is still not parsed, so this is impossible.+ __IMPOSSIBLE__+ -- TODO: linearity+ -- let q' = Quantityω QωInferred+ -- warning $ FixingQuantity s q q'+ -- return $ setQuantity q' info++ensureLeftAdjoint :: LensCohesion a => Maybe String -> a -> ScopeM a+ensureLeftAdjoint ms info+ | hasLeftAdjoint (UnderComposition (getCohesion info)) = return info+ | otherwise = setCohesion Continuous info <$ do+ whenJust ms \ s -> warning $ FixingCohesion s (getCohesion info) Continuous++ensureMixedPolarity :: LensModalPolarity a => Maybe String -> a -> ScopeM a+ensureMixedPolarity ms info+ | splittablePolarity info = return info+ | otherwise = setModalPolarity mixedPolarity info <$ do+ whenJust ms \ s -> warning $ FixingPolarity s (getModalPolarity info) mixedPolarity++-- ** More scope checking+------------------------------------------------------------------------++instance ToAbstract C.Pragma where+ type AbsOfCon C.Pragma = [A.Pragma]++ toAbstract (C.ImpossiblePragma _ strs) =+ case strs of+ "ReduceM" : _ -> impossibleTestReduceM strs+ _ -> impossibleTest strs++ toAbstract (C.OptionsPragma _ opts) = return [ A.OptionsPragma opts ]++ toAbstract (C.RewritePragma _ r xs) = do+ rewritingOption >>= \case++ -- If --rewriting is off, ignore the pragma.+ False -> [] <$ do+ warning $ UselessPragma r "Ignoring REWRITE pragma since option --rewriting is off"++ -- Warn about empty pragmas.+ True -> if null xs then [] <$ warning EmptyRewritePragma else do++ -- Check that names of rewrite rules are unambiguous.+ singleton . A.RewritePragma r . catMaybes <$> do+ forM xs \ x -> setCurrentRange x $ unambiguousConOrDef NotARewriteRule x++ toAbstract (C.ForeignPragma _ rb s) = pure [ A.ForeignPragma rb s ]+ -- Issue #8647: for the sake of caching, handle FOREIGN code in the type checker++ toAbstract (C.CompilePragma _ rb x s) =+ maybe [] (\ y -> [ A.CompilePragma rb y s ]) <$>+ unambiguousConOrDef PragmaCompileWrongName x++ toAbstract (C.StaticPragma _ x) = do+ map A.StaticPragma . maybeToList <$> do+ unambiguousDef (PragmaExpectsUnambiguousProjectionOrFunction "STATIC") x++ toAbstract (C.InjectivePragma _ x) = do+ map A.InjectivePragma . maybeToList <$> do+ unambiguousDef (PragmaExpectsUnambiguousProjectionOrFunction "INJECTIVE") x++ toAbstract (C.InjectiveForInferencePragma _ x) = do+ map A.InjectiveForInferencePragma . maybeToList <$> do+ scopeCheckDef (PragmaExpectsDefinedSymbol "INJECTIVE_FOR_INFERENCE") x++ toAbstract pragma@(C.InlinePragma _ b x) = do+ caseMaybeM (toAbstract $ MaybeOldQName $ OldQName x Nothing) notInScope \case+ A.Con c -> concatMapM ret $ List1.toList $ getAmbiguous c+ A.Def x -> ret x+ A.Proj _ p+ | Just x <- getUnambiguous p -> ret x+ | otherwise -> uselessPragma pragma $ sINLINE ++ " used on ambiguous name " ++ prettyShow x+ _ -> uselessPragma pragma $ "Target of " ++ sINLINE ++ " pragma should be a function or constructor"+ where+ sINLINE = if b then "INLINE" else "NOINLINE"+ notInScope = [] <$ notInScopeWarning x+ ret y = return [ A.InlinePragma b y ]++ toAbstract (C.NotProjectionLikePragma _ x) = do+ map A.NotProjectionLikePragma . maybeToList <$> do+ unambiguousDef (PragmaExpectsUnambiguousProjectionOrFunction "NOT_PROJECTION_LIKE") x++ toAbstract (C.OverlapPragma _ xs i) = do+ map (flip A.OverlapPragma i) . catMaybes <$> do+ mapM (unambiguousConOrDef $ PragmaExpectsUnambiguousConstructorOrFunction pragma) xs+ where+ pragma = case i of+ Overlappable -> "OVERLAPPABLE"+ Overlapping -> "OVERLAPPING"+ Overlaps -> "OVERLAPS"+ Incoherent -> "INCOHERENT"+ -- Never written by the user:+ DefaultOverlap -> __IMPOSSIBLE__+ FieldOverlap -> __IMPOSSIBLE__++ toAbstract pragma@(C.BuiltinPragma _ rb qx)+ | Just b' <- b, isUntypedBuiltin b' = do+ q <- resolveQName qx+ bindUntypedBuiltin b' qx q+ return [ A.BuiltinPragma rb q ]+ -- Andreas, 2015-02-14+ -- Some builtins cannot be given a valid Agda type,+ -- thus, they do not come with accompanying postulate or definition.+ | Just b' <- b, isBuiltinNoDef b' = do+ case qx of+ C.QName x -> do+ -- The name shouldn't exist yet. If it does, we raise a warning+ -- and drop the existing definition.+ unlessM ((UnknownName ==) <$> resolveName qx) $ do+ warning $ BuiltinDeclaresIdentifier b'+ modifyCurrentScope $ removeNameFromScope PublicNS x+ recomputeInverseScope+ -- We then happily bind the name+ y <- freshAbstractQName' x+ let kind = fromMaybe __IMPOSSIBLE__ $ builtinKindOfName b'+ bindName PublicAccess kind x y+ return [ A.BuiltinNoDefPragma rb kind y ]+ _ -> uselessPragma pragma $+ "Pragma BUILTIN " ++ getBuiltinId b' ++ ": expected unqualified identifier, " +++ "but found " ++ prettyShow qx+ | otherwise = do+ q0 <- resolveQName qx++ -- Andreas, 2020-04-12, pr #4574. For highlighting purposes:+ -- Rebind 'BuiltinPrim' as 'PrimName' and similar.+ q <- case (q0, b >>= builtinKindOfName, qx) of+ (DefinedName acc y suffix, Just kind, C.QName x)+ | anameKind y /= kind+ , kind `elem` [ PrimName, AxiomName ] -> do+ rebindName acc kind noMetadata x $ anameName y+ return $ DefinedName acc y{ anameKind = kind } suffix+ _ -> return q0++ return [ A.BuiltinPragma rb q ]+ where b = builtinById (rangedThing rb)++ toAbstract pragma@(C.EtaPragma _ x) = do+ uselessPragma pragma "The ETA pragma has been removed, use the attaching ETA_EQUALITY pragma instead"++ toAbstract pragma@(C.DisplayPragma _ lhs rhs) = do+ maybeToList <$> do+ withLocalVars $ runMaybeT do+ let err = failure "DISPLAY pragma left-hand side must have form 'f e1 .. en'"+ getHead (C.IdentP _ x) = return x+ getHead (C.RawAppP _ (List2 p _ _)) = getHead p+ getHead _ = err++ top <- getHead lhs++ (isPatSyn, hd) <- do+ qx <- liftTCM $ resolveName' allKindsOfNames Nothing top+ case qx of+ VarName x' _ -> return . (False,) $ A.qnameFromList $ singleton x'+ DefinedName _ d NoSuffix -> return . (False,) $ anameName d+ DefinedName _ d Suffix{} -> failure $ "Invalid pattern " ++ prettyShow top+ FieldName (d :| []) -> return . (False,) $ anameName d+ FieldName ds -> failure $ "Ambiguous projection " ++ prettyShow top ++ ": " ++ prettyShow (ambigName ds)+ ConstructorName _ (d :| []) -> return . (False,) $ anameName d+ ConstructorName _ ds -> failure $ "Ambiguous constructor " ++ prettyShow top ++ ": " ++ prettyShow (ambigName ds)+ UnknownName -> do liftTCM $ notInScopeWarning top; mzero+ PatternSynResName (d :| []) -> return . (True,) $ anameName d+ PatternSynResName ds -> failure $ "Ambiguous pattern synonym" ++ prettyShow top ++ ": " ++ prettyShow (fmap anameName ds)++ lhs <- liftTCM $ toAbstract $ LeftHandSide top lhs YesDisplayLHS+ ps <- case lhs of+ A.LHS _ (A.LHSHead _ ps) -> return ps+ _ -> err++ -- Andreas, 2016-08-08, issue #2132+ -- Remove pattern synonyms on lhs+ (hd, ps) <- do+ p <- liftTCM $ expandPatternSynonyms $+ (if isPatSyn then A.PatternSynP else A.DefP) (PatRange $ getRange lhs) (unambiguous hd) ps+ case p of+ A.DefP _ f ps | Just hd <- getUnambiguous f -> return (hd, ps)+ A.ConP _ c ps | Just hd <- getUnambiguous c -> return (hd, ps)+ A.PatternSynP{} -> __IMPOSSIBLE__+ _ -> err++ rhs <- liftTCM $ toAbstract rhs++ -- Andreas, 2024-10-06, issue #7533:+ -- Check that all pattern variables occur on the rhs.+ -- Otherwise, there might be a misunderstanding of what display forms do.+ let used = allUsedNames rhs+ List1.unlessNull (filter (not . (isNoName || (`Set.member` used))) $ patternVars ps) $+ warning . UnusedVariablesInDisplayForm++ return $ A.DisplayPragma hd ps rhs+ where+ failure :: forall a. String -> MaybeT ScopeM a+ failure msg = do warning (UselessPragma (getRange pragma) $ P.fwords msg); mzero++ -- A warning attached to an ambiguous name shall apply to all disambiguations.+ toAbstract pragma@(C.WarningOnUsage _ x str) = do+ ys <- resolveName x >>= \case+ ConstructorName _ ds -> return $ List1.toList ds+ FieldName ds -> return $ List1.toList ds+ PatternSynResName ds -> return $ List1.toList ds+ DefinedName _ d NoSuffix -> return $ singleton d+ DefinedName _ d Suffix{} -> [] <$ notInScopeWarning x+ UnknownName -> [] <$ notInScopeWarning x+ VarName x _ -> [] <$ do+ uselessPragma pragma $ "Not a defined name: " ++ prettyShow x+ forM_ ys $ \ y -> stLocalUserWarnings `modifyTCLens` Map.insert (anameName y) str+ return []++ toAbstract (C.WarningOnImport _ str) = do+ stWarningOnImport `setTCLens` Just str+ pure []+++ -- Pragmas that are handled by the nicifier:+ toAbstract C.TerminationCheckPragma{} = __IMPOSSIBLE__+ toAbstract C.NoCoverageCheckPragma{} = __IMPOSSIBLE__+ toAbstract C.NoPositivityCheckPragma{} = __IMPOSSIBLE__+ toAbstract C.NoUniverseCheckPragma{} = __IMPOSSIBLE__+ toAbstract C.CatchallPragma{} = __IMPOSSIBLE__+ toAbstract C.EtaEqualityPragma{} = __IMPOSSIBLE__+ toAbstract C.PolarityPragma{} = __IMPOSSIBLE__++uselessPragma :: HasRange p => p -> String -> ScopeM [a]+uselessPragma pragma = ([] <$) . warning . UselessPragma (getRange pragma) . P.fwords++unambiguousConOrDef :: (C.QName -> IsAmbiguous -> Warning) -> C.QName -> ScopeM (Maybe A.QName)+unambiguousConOrDef warn x = do+ caseMaybeM (toAbstract $ MaybeOldQName $ OldQName x Nothing) notInScope $ \case+ A.Def' y NoSuffix -> ret y+ A.Def' y Suffix{} -> failure NotAmbiguous+ A.Proj _ p+ | Just y <- getUnambiguous p -> ret y+ | otherwise -> failure $ YesAmbiguous p+ A.Con c+ | Just y <- getUnambiguous c -> ret y+ | otherwise -> failure $ YesAmbiguous c+ A.Var{} -> failure NotAmbiguous+ A.PatternSyn{} -> failure NotAmbiguous+ _ -> __IMPOSSIBLE__+ where+ notInScope = Nothing <$ notInScopeWarning x+ failure = (Nothing <$) . warning . warn x+ ret = return . Just++unambiguousDef :: (C.QName -> IsAmbiguous -> Warning) -> C.QName -> ScopeM (Maybe A.QName)+unambiguousDef warn x = do+ caseMaybeM (toAbstract $ MaybeOldQName $ OldQName x Nothing) notInScope $ \case+ A.Def' y NoSuffix -> ret y+ A.Def' y Suffix{} -> failure NotAmbiguous+ A.Proj _ p+ | Just y <- getUnambiguous p -> ret y+ | otherwise -> failure $ YesAmbiguous p+ A.Con{} -> failure NotAmbiguous+ A.Var{} -> failure NotAmbiguous+ A.PatternSyn{} -> failure NotAmbiguous+ _ -> __IMPOSSIBLE__+ where+ notInScope = Nothing <$ notInScopeWarning x+ failure = (Nothing <$) . warning . warn x+ ret = return . Just++scopeCheckDef :: (C.QName -> Warning) -> C.QName -> ScopeM (Maybe A.QName)+scopeCheckDef warn x = do+ caseMaybeM (toAbstract $ MaybeOldQName $ OldQName x Nothing) notInScope $ \case+ A.Def' y NoSuffix -> ret y+ A.Def' y Suffix{} -> failure+ A.Proj{} -> failure+ A.Con{} -> failure+ A.Var{} -> failure+ A.PatternSyn{} -> failure+ _ -> __IMPOSSIBLE__+ where+ notInScope = Nothing <$ notInScopeWarning x+ failure = Nothing <$ do warning $ warn x+ ret = return . Just++-- | Does this left-hand side equation trigger a with-abstraction?+-- @using p <- e@ does not, it merely introduces a let-binding.+withAbstractingEqn :: RewriteEqn' qn nm p e -> Bool+withAbstractingEqn = \case+ Rewrite{} -> True -- @rewrite e@+ Invert{} -> True -- @with p <- e in eq@+ LeftLet{} -> False -- @using p <- e@++instance ToAbstract C.Clause where+ type AbsOfCon C.Clause = A.Clause++ toAbstract (C.Clause top catchall ai lhs@(C.LHS p eqs with) rhs wh wcs) = withLocalVars $ do+ -- Andreas, 2026-09-06, issue #8698:+ -- Establish the invariant of 'RightHandSide':+ -- no named @where@ module under @with@ or @rewrite@.+ -- The @where@ clause of a @rewrite@ clause is passed on to 'RightHandSide',+ -- whereas for @with@ it is the with-subclauses that carry the @where@ clause.+ when (not (null with) || any withAbstractingEqn eqs) do+ mapM_ rejectNamedWhereUnderWith $ wh : map (\ (C.Clause _ _ _ _ _ wh' _) -> wh') wcs++ -- Jesper, 2018-12-10, #3095: pattern variables bound outside the+ -- module are locally treated as module parameters+ modifyScope $ updateScopeLocals $ map $ second patternToModuleBound+ -- Andreas, 2012-02-14: need to reset local vars before checking subclauses+ vars0 <- getLocalVars+ lhs' <- toAbstract $ LeftHandSide (C.QName top) p NoDisplayLHS+ printLocals 30 "after lhs:"+ vars1 <- getLocalVars+ eqs <- mapM (toAbstractCtx TopCtx) eqs+ vars2 <- getLocalVars+ let vars = dropEnd (length vars1) vars2 ++ vars0+ let wcs' = (vars, wcs)++ -- Handle rewrite equations first.+ if not (null eqs)+ then do+ rhs <- toAbstractCtx TopCtx $ RightHandSide eqs with wcs' rhs wh+ rhs <- toAbstract rhs+ return $ A.Clause lhs' [] rhs A.noWhereDecls catchall+ else do+ -- the right hand side is checked with the module of the local definitions opened+ (rhs, ds) <- whereToAbstract (getRange wh) wh $+ toAbstractCtx TopCtx $ RightHandSide [] with wcs' rhs NoWhere+ rhs <- toAbstract rhs+ return $ A.Clause lhs' [] rhs ds catchall+ where+ -- Andreas, 2026-09-06, issue #8698.+ -- Reject a named @where@ module (@module M where@) in a @with@ or @rewrite@+ -- clause. With-abstraction can change the types of the module parameters+ -- inherited by @M@, so instantiating @M@ from outside is unsound.+ rejectNamedWhereUnderWith :: C.WhereClause -> ScopeM ()+ rejectNamedWhereUnderWith = \case+ SomeWhere r _ x _ _+ | isUnderscore x -> return ()+ | otherwise -> setCurrentRange r $ typeError NamedWhereModuleUnderWith+ AnyWhere{} -> return ()+ NoWhere -> return ()+++whereToAbstract+ :: Range -- ^ The range of the @where@ block.+ -> C.WhereClause -- ^ The @where@ block.+ -> ScopeM a -- ^ The scope-checking task to be run in the context of the @where@ module.+ -> ScopeM (a, A.WhereDeclarations) -- ^ Additionally return the scope-checked contents of the @where@ module.+whereToAbstract r wh inner = do+ case wh of+ NoWhere -> ret+ AnyWhere _ [] -> warnEmptyWhere+ AnyWhere _ ds -> enter do+ -- Andreas, 2016-07-17 issues #2081 and #2101+ -- where-declarations are automatically private.+ -- Andreas, 2025-03-29+ -- While since PR #5192 (Feb 2021, issue #481) it is no longer the case+ -- that we check their type signatures in abstract mode,+ -- we still need to mark the declaration as private+ -- e.g. to avoid spurious UnknownFixityInMixfixDecl warnings (issue #2889).+ whereToAbstract1 r defaultErased Nothing+ (singleton $ C.Private empty Inserted ds) inner+ SomeWhere _ e m a ds0 -> enter $+ List1.ifNull ds0 warnEmptyWhere {-else-} \ ds ->+ -- Named where-modules do not default to private.+ whereToAbstract1 r e (Just (m, a)) ds inner+ where+ enter = localTC (set eCheckingWhere (C.whereClause_ wh))+ ret = (,A.noWhereDecls) <$> inner+ warnEmptyWhere = do+ setCurrentRange r $ warning EmptyWhere+ ret++whereToAbstract1+ :: Range -- ^ The range of the @where@-block.+ -> Erased -- ^ Is the where module erased?+ -> Maybe (C.Name, Access) -- ^ The name of the @where@ module (if any).+ -> List1 C.Declaration -- ^ The contents of the @where@ module.+ -> ScopeM a -- ^ The scope-checking task to be run in the context of the @where@ module.+ -> ScopeM (a, A.WhereDeclarations) -- ^ Additionally return the scope-checked contents of the @where@ module.+whereToAbstract1 r e whname whds inner = do+ -- ASR (16 November 2015) Issue 1137: We ban termination+ -- pragmas inside `where` clause.+ checkNoTerminationPragma InWhereBlock whds++ -- Create a fresh concrete name if there isn't (a proper) one.+ (m, acc) <- do+ case whname of+ Just (m, acc) | not (isNoName m) -> return (m, acc)+ _ -> fresh <&> \ x -> (C.NoName (getRange whname) x, privateAccessInserted)+ -- unnamed where's are private+ old <- getCurrentModule+ am <- toAbstract (NewModuleName m)+ (scope, d) <- scopeCheckModule r e (C.QName m) am [] $+ scopeCheckDeclarations $ List1.toList whds+ setScope scope+ x <- inner+ setCurrentModule old+ bindModule acc m am+ -- Issue 848: if the module was anonymous (module _ where) open it public+ let anonymousSomeWhere = maybe False (isNoName . fst) whname+ when anonymousSomeWhere $+ void $ -- We can ignore the returned default A.ImportDirective.+ openModule empty TopOpenModule (Just am) (C.QName m) $+ defaultImportDir { publicOpen = Just empty }+ return (x, A.WhereDecls (Just am) (isNothing whname) $ singleton d)++data WhereOrRecord = InWhereBlock | InRecordDef++checkNoTerminationPragma :: FoldDecl a => WhereOrRecord -> a -> ScopeM ()+checkNoTerminationPragma b ds =+ -- foldDecl traverses into all sub-declarations.+ forM_ (foldDecl (isPragma >=> isTerminationPragma) ds) \ r ->+ setCurrentRange r $ warning $ UselessPragma r $ P.vcat+ [ P.fwords $ "Termination pragmas are ignored in " ++ what b+ , "(see " <> issue b <> ")"+ ]+ where+ what InWhereBlock = "where clauses"+ what InRecordDef = "record definitions"+ issue InWhereBlock = P.githubIssue 3355+ issue InRecordDef = P.githubIssue 3008++ isTerminationPragma :: C.Pragma -> [Range]+ isTerminationPragma = \case+ C.TerminationCheckPragma r _ -> [r]+ C.NoPositivityCheckPragma _ -> []+ C.OptionsPragma _ _ -> []+ C.BuiltinPragma _ _ _ -> []+ C.RewritePragma _ _ _ -> []+ C.ForeignPragma _ _ _ -> []+ C.CompilePragma _ _ _ _ -> []+ C.StaticPragma _ _ -> []+ C.InlinePragma _ _ _ -> []+ C.ImpossiblePragma _ _ -> []+ C.EtaPragma _ _ -> []+ C.WarningOnUsage _ _ _ -> []+ C.WarningOnImport _ _ -> []+ C.InjectivePragma _ _ -> []+ C.InjectiveForInferencePragma{} -> []+ C.DisplayPragma _ _ _ -> []+ C.CatchallPragma _ -> []+ C.EtaEqualityPragma _ -> []+ C.NoCoverageCheckPragma _ -> []+ C.PolarityPragma _ _ _ -> []+ C.NoUniverseCheckPragma _ -> []+ C.NotProjectionLikePragma _ _ -> []+ C.OverlapPragma _ _ _ -> []++-- | The right-hand side of a clause, before scope checking.+--+-- Invariant (issue #8698): if this is a @with@ or @rewrite@ clause,+-- i.e. if @_rhsWithExpr@ is not 'null' or @_rhsRewriteEqn@ contains a+-- 'withAbstractingEqn', then neither @_rhsWhere@ nor the @where@ clause of+-- any of the @_rhsSubclauses@ is a named @where@ module ('SomeWhere').+-- This is established by 'toAbstract' for 'C.Clause', the only producer of+-- 'RightHandSide', which otherwise throws 'NamedWhereModuleUnderWith'.+--+data RightHandSide = RightHandSide+ { _rhsRewriteEqn :: [RewriteEqn' () A.BindName A.Pattern A.Expr]+ -- ^ @rewrite e | with p <- e in eq@ (many).+ , _rhsWithExpr :: [C.WithExpr]+ -- ^ @with e@ (many).+ , _rhsSubclauses :: (LocalVars, [C.Clause])+ -- ^ the subclauses spawned by a @with@.+ , _rhs :: C.RHS+ , _rhsWhere :: WhereClause+ -- ^ @where@ module.+ }++data AbstractRHS+ = AbsurdRHS'+ | WithRHS' (List1 A.WithExpr) (List1 (ScopeM C.Clause))+ -- ^ The with clauses haven't been translated yet+ | RHS' A.Expr C.Expr+ | RewriteRHS' [RewriteEqn' () A.BindName A.Pattern A.Expr] AbstractRHS A.WhereDeclarations++qualifyName_ :: A.Name -> ScopeM A.QName+qualifyName_ x = do+ m <- getCurrentModule+ return $ A.qualify m x++withFunctionName :: String -> ScopeM A.QName+withFunctionName s = do+ NameId i _ <- fresh+ qualifyName_ =<< freshName_ (s ++ show i)++instance ToAbstract (RewriteEqn' () A.BindName A.Pattern A.Expr) where+ type AbsOfCon (RewriteEqn' () A.BindName A.Pattern A.Expr) = A.RewriteEqn+ toAbstract = \case+ Rewrite es -> fmap Rewrite $ forM es $ \ (_, e) -> do+ qn <- withFunctionName "-rewrite"+ pure (qn, e)+ Invert _ pes -> do+ qn <- withFunctionName "-invert"+ pure $ Invert qn pes+ LeftLet pes -> pure $ LeftLet pes++instance ToAbstract C.RewriteEqn where+ type AbsOfCon C.RewriteEqn = RewriteEqn' () A.BindName A.Pattern A.Expr+ toAbstract = \case+ Rewrite es -> Rewrite <$> mapM toAbstract es+ Invert _ npes -> Invert () <$> do+ -- Given a list of irrefutable with expressions of the form @p <- e in q@+ let (nps, es) = List1.unzip+ $ fmap (\ (Named nm (p, e)) -> ((nm, p), e)) npes+ -- we first check the expressions @e@: the patterns may shadow some of the+ -- variables mentioned in them!+ es <- toAbstract es+ -- we then parse the pairs of patterns @p@ and names @q@ for the equality+ -- constraints of the form @p ≡ e@.+ nps <- forM nps $ \ (n, p) -> do+ -- first the pattern+ p <- toAbsPat p+ -- and then the name+ n <- toAbstract $ fmap (NewName WithBound . C.mkBoundName_) n+ pure (n, p)+ -- we finally reassemble the telescope+ pure $ List1.zipWith (\ (n,p) e -> Named n (p, e)) nps es+ LeftLet pes -> fmap LeftLet $ forM pes $ \ (p, e) -> do+ -- first check the expression: the pattern may shadow+ -- some of the variables mentioned in it!+ e <- toAbstract e+ p <- toAbsPat p+ pure (p, e)+ where+ toAbsPat p = do+ -- Expand puns if optHiddenArgumentPuns is True.+ p <- expandPunsOpt p+ p <- parsePattern p+ p <- toAbstract p+ checkPatternLinearity p (typeError . RepeatedVariablesInPattern)+ bindVarsToBind+ toAbstract p++instance ToAbstract AbstractRHS where+ type AbsOfCon AbstractRHS = A.RHS++ toAbstract AbsurdRHS' = return A.AbsurdRHS+ toAbstract (RHS' e c) = return $ A.RHS e $ Just c+ toAbstract (RewriteRHS' eqs rhs wh) = do+ eqs <- toAbstract eqs+ rhs <- toAbstract rhs+ return $ RewriteRHS eqs [] rhs wh+ toAbstract (WithRHS' es cs) = do+ aux <- withFunctionName "with-"+ A.WithRHS aux es <$> do toAbstract =<< sequence cs++instance ToAbstract RightHandSide where+ type AbsOfCon RightHandSide = AbstractRHS+ toAbstract (RightHandSide eqs@(_:_) es cs rhs wh) = do+ (rhs, ds) <- whereToAbstract (getRange wh) wh $+ toAbstract (RightHandSide [] es cs rhs NoWhere)+ return $ RewriteRHS' eqs rhs ds+ toAbstract (RightHandSide [] [] (_ , _:_) _ _) = __IMPOSSIBLE__+ toAbstract (RightHandSide [] (_:_) _ (C.RHS _) _) = typeError BothWithAndRHS -- issue #7760+ toAbstract (RightHandSide [] [] (_ , []) rhs NoWhere) = toAbstract rhs+ toAbstract (RightHandSide [] (z:zs)(lv , c:cs) C.AbsurdRHS NoWhere) = do+ let (ns, es) = List1.unzipWith (\ (Named nm e) -> (NewName WithBound . C.mkBoundName_ <$> nm, e)) $ z :| zs+ es <- toAbstractCtx TopCtx es+ lvars0 <- getLocalVars+ ns <- toAbstract ns+ lvars1 <- getLocalVars+ let lv' = dropEnd (length lvars0) lvars1 ++ lv+ let cs' = for (c :| cs) $ \ c -> setLocalVars lv' $> c+ let nes = List1.zipWith Named ns es+ return $ WithRHS' nes cs'+ -- TODO: some of these might be possible+ toAbstract (RightHandSide [] (_ : _) _ C.AbsurdRHS AnyWhere{}) = __IMPOSSIBLE__+ toAbstract (RightHandSide [] (_ : _) _ C.AbsurdRHS SomeWhere{}) = __IMPOSSIBLE__+ toAbstract (RightHandSide [] (_ : _) _ C.AbsurdRHS NoWhere{}) = __IMPOSSIBLE__+ toAbstract (RightHandSide [] [] (_, []) C.AbsurdRHS AnyWhere{}) = __IMPOSSIBLE__+ toAbstract (RightHandSide [] [] (_, []) C.AbsurdRHS SomeWhere{}) = __IMPOSSIBLE__+ toAbstract (RightHandSide [] [] (_, []) C.RHS{} AnyWhere{}) = __IMPOSSIBLE__+ toAbstract (RightHandSide [] [] (_, []) C.RHS{} SomeWhere{}) = __IMPOSSIBLE__++instance ToAbstract C.RHS where+ type AbsOfCon C.RHS = AbstractRHS++ toAbstract C.AbsurdRHS = return $ AbsurdRHS'+ toAbstract (C.RHS e) = RHS' <$> toAbstract e <*> pure e++-- | Wrapper to check lhs (possibly of a 'C.DisplayPragma').+--+data LeftHandSide = LeftHandSide+ C.QName+ -- ^ Name of the definition we are checking.+ C.Pattern+ -- ^ Full left hand side.+ DisplayLHS+ -- ^ Are we checking a 'C.DisplayPragma'?++instance ToAbstract LeftHandSide where+ type AbsOfCon LeftHandSide = A.LHS++ toAbstract (LeftHandSide top lhs displayLhs) =+ traceCall (ScopeCheckLHS top lhs) $ do+ reportSLn "scope.lhs" 25 $ "original lhs: " ++ prettyShow lhs+ reportSLn "scope.lhs" 60 $ "patternQNames: " ++ prettyShow (patternQNames lhs)+ reportSLn "scope.lhs" 90 $ "original lhs (raw): " ++ show lhs++ -- Expand puns if optHiddenArgumentPuns is True. Note that pun+ -- expansion should happen before the left-hand side is+ -- parsed, because {(x)} is not treated as a pun, whereas {x}+ -- is.+ lhs <- expandPunsOpt lhs+ reportSLn "scope.lhs" 25 $+ "lhs with expanded puns: " ++ prettyShow lhs+ reportSLn "scope.lhs" 60 $+ "lhs with expanded puns (raw): " ++ show lhs++ lhscore <- parseLHS displayLhs top lhs+ let ell = hasExpandedEllipsis lhscore+ reportSLn "scope.lhs" 25 $ "parsed lhs: " ++ prettyShow lhscore+ reportSLn "scope.lhs" 60 $ "parsed lhs (raw): " ++ show lhscore+ printLocals 30 "before lhs:"+ -- error if copattern parsed but --no-copatterns option+ unlessM (optCopatterns <$> pragmaOptions) $+ when (hasCopatterns lhscore) $+ typeError $ NeedOptionCopatterns+ -- scope check patterns except for dot patterns+ lhscore <- toAbstract $ CLHSCore displayLhs lhscore+ bindVarsToBind+ -- reportSLn "scope.lhs" 25 $ "parsed lhs patterns: " ++ prettyShow lhscore -- TODO: Pretty A.LHSCore'+ reportSLn "scope.lhs" 90 $ "parsed lhs patterns: " ++ show lhscore+ printLocals 30 "checked pattern:"+ -- scope check dot patterns+ lhscore <- toAbstract lhscore+ -- reportSLn "scope.lhs" 25 $ "parsed lhs dot patterns: " ++ prettyShow lhscore -- TODO: Pretty A.LHSCore'+ reportSLn "scope.lhs" 90 $ "parsed lhs dot patterns: " ++ show lhscore+ printLocals 30 "checked dots:"+ return $ A.LHS (LHSInfo (getRange lhs) ell) lhscore++-- | Expands hidden argument puns when option 'optHiddenArgumentPuns' is set.++expandPunsOpt :: C.Pattern -> ScopeM C.Pattern+expandPunsOpt p = do+ pragmaOptions <&> optHiddenArgumentPuns <&> \case+ True -> expandPuns p+ False -> p++-- | Expands hidden argument puns.++expandPuns :: C.Pattern -> C.Pattern+expandPuns = mapCPattern \case+ C.HiddenP r p -> C.HiddenP r $ expand p+ C.InstanceP r p -> C.InstanceP r $ expand p+ p -> p+ where+ -- Only patterns of the form {x} or ⦃ x ⦄, where x is an unqualified+ -- name (not @_@), are interpreted as puns.+ expand :: Named_ C.Pattern -> Named_ C.Pattern+ expand+ (Named { namedThing = C.IdentP _ q@(C.QName x@C.Name{})+ , nameOf = Nothing+ }) =+ Named { namedThing = C.IdentP False q+ , nameOf = Just $+ WithOrigin+ { woOrigin = ExpandedPun+ , woThing = unranged (prettyShow x)+ }+ }+ expand p = p++hasExpandedEllipsis :: C.LHSCore -> ExpandedEllipsis+hasExpandedEllipsis core = case core of+ C.LHSHead{} -> NoEllipsis+ C.LHSProj{} -> hasExpandedEllipsis $ namedArg $ C.lhsFocus core -- can this ever be ExpandedEllipsis?+ C.LHSWith{} -> hasExpandedEllipsis $ C.lhsHead core+ C.LHSEllipsis r p -> case p of+ C.LHSWith p wps _ -> hasExpandedEllipsis p <> ExpandedEllipsis r (length wps)+ C.LHSHead{} -> ExpandedEllipsis r 0+ C.LHSProj{} -> ExpandedEllipsis r 0+ C.LHSEllipsis{} -> __IMPOSSIBLE__++-- | Merges adjacent EqualP patterns into one:+-- type checking expects only one pattern for each domain in the telescope.+mergeEqualPs :: [NamedArg (Pattern' e)] -> ScopeM [NamedArg (Pattern' e)]+mergeEqualPs = go (empty, [])+ where+ go acc (p@(Arg ai (Named mn (A.EqualP r es))) : ps) = setCurrentRange p $ do+ -- Face constraint patterns must be defaultNamedArg; check this:+ unless (getModality ai == defaultModality) __IMPOSSIBLE__+ when (notVisible ai) $+ warning $ FaceConstraintCannotBeHidden ai+ whenJust mn $ \ x -> setCurrentRange x $+ warning $ FaceConstraintCannotBeNamed x+ go (acc `mappend` (r, List1.toList es)) ps+ go (r, (e:es)) ps = (defaultNamedArg (A.EqualP r $ e :| es) :) <$> mergeEqualPs ps+ go (_, []) [] = return []+ go (_, []) (p : ps) = (p :) <$> mergeEqualPs ps+++-- | Scope-check a 'C.LHSCore' (of possibly a 'C.DisplayForm').++data CLHSCore = CLHSCore+ DisplayLHS+ -- ^ Are we checking the left hand side of a 'C.DisplayForm'?+ C.LHSCore+ -- ^ The lhs to scope-check.++-- | Scope-check a 'C.LHSCore' not of a 'C.DisplayForm'.++instance ToAbstract C.LHSCore where+ type AbsOfCon C.LHSCore = A.LHSCore' C.Expr++ toAbstract = toAbstract . CLHSCore NoDisplayLHS++-- does not check pattern linearity+instance ToAbstract CLHSCore where+ type AbsOfCon CLHSCore = A.LHSCore' C.Expr++ toAbstract (CLHSCore displayLhs core0) = case core0 of++ C.LHSHead x ps -> do+ x <- withLocalVars do+ setLocalVars []+ toAbstractOldName x+ ps <- toAbstract $ (fmap . fmap . fmap) (CPattern displayLhs) ps+ A.LHSHead x <$> mergeEqualPs ps++ C.LHSProj d ps1 core ps2 -> do+ unless (null ps1) $ typeError $ IllformedProjectionPatternConcrete (foldl C.AppP (C.IdentP True d) ps1)+ x <- resolveName d >>= \case+ FieldName ds -> pure (ambigName ds)+ UnknownName -> notInScopeError d+ _ -> typeError $ CopatternHeadNotProjection d+ core <- toAbstract $ (fmap . fmap) (CLHSCore displayLhs) core+ ps2 <- toAbstract $ (fmap . fmap . fmap) (CPattern displayLhs) ps2+ A.LHSProj x core <$> mergeEqualPs ps2++ C.LHSWith core wps ps -> do+ -- DISPLAY pragmas cannot have @with@, so no need to pass on @displayLhs@.+ core <- toAbstract core+ wps <- fmap defaultArg <$> toAbstract wps+ ps <- toAbstract ps+ return $ A.lhsCoreApp (A.lhsCoreWith core wps) ps++ -- In case of a part of the LHS which was expanded from an ellipsis,+ -- we flush the @scopeVarsToBind@ in order to allow variables bound+ -- in the ellipsis to be shadowed.+ C.LHSEllipsis _ core -> do+ core <- toAbstract core -- Cannot come from a DISPLAY pragma.+ bindVarsToBind+ return core++instance ToAbstract c => ToAbstract (WithHiding c) where+ type AbsOfCon (WithHiding c) = WithHiding (AbsOfCon c)+ toAbstract (WithHiding h a) = WithHiding h <$> toAbstractHiding h a++instance ToAbstract c => ToAbstract (Arg c) where+ type AbsOfCon (Arg c) = Arg (AbsOfCon c)+ toAbstract (Arg info e) =+ Arg info <$> toAbstractHiding info e++instance ToAbstract c => ToAbstract (Named name c) where+ type AbsOfCon (Named name c) = Named name (AbsOfCon c)+ toAbstract = traverse toAbstract++instance ToAbstract c => ToAbstract (Ranged c) where+ type AbsOfCon (Ranged c) = Ranged (AbsOfCon c)+ toAbstract = traverse toAbstract++{- DOES NOT WORK ANYMORE with pattern synonyms+instance ToAbstract c a => ToAbstract (A.LHSCore' c) (A.LHSCore' a) where+ toAbstract = mapM toAbstract+-}++instance ToAbstract (A.LHSCore' C.Expr) where+ type AbsOfCon (A.LHSCore' C.Expr) = A.LHSCore' A.Expr+ toAbstract (A.LHSHead f ps) = A.LHSHead f <$> mapM toAbstract ps+ toAbstract (A.LHSProj d lhscore ps) = A.LHSProj d <$> mapM toAbstract lhscore <*> mapM toAbstract ps+ toAbstract (A.LHSWith core wps ps) = liftA3 A.LHSWith (toAbstract core) (toAbstract wps) (toAbstract ps)++-- Patterns are done in two phases. First everything but the dot patterns, and+-- then the dot patterns. This is because dot patterns can refer to variables+-- bound anywhere in the pattern.++instance ToAbstract (A.Pattern' C.Expr) where+ type AbsOfCon (A.Pattern' C.Expr) = A.Pattern' A.Expr+ toAbstract = traverse $ insideDotPattern . toAbstractCtx DotPatternCtx -- Issue #3033++resolvePatternIdentifier ::+ Bool+ -- ^ Is the identifier allowed to refer to a constructor (or a pattern synonym)?+ --+ -- Value 'False' is only used when 'optHiddenArgumentPuns' is 'True'.+ -- In this case, error 'InvalidPun' is thrown on identifiers that are not variables.+ -> DisplayLHS+ -- ^ Are definitions to be treated as constructors?+ -- 'True' when we are checking a 'C.DisplayForm'.+ -> Hiding+ -- ^ Is the pattern variable hidden?+ -> C.QName+ -- ^ Identifier.+ -> Maybe (Set1 A.Name)+ -- ^ Possibly precomputed resolutions of the identifier (from the operator parser).+ -> ScopeM (A.Pattern' C.Expr)+resolvePatternIdentifier canBeConstructor displayLhs h x ns = do+ reportSLn "scope.pat" 60 $ "resolvePatternIdentifier " ++ prettyShow x ++ " at source position " ++ prettyShow r+ toAbstract (PatName x ns h displayLhs) >>= \case++ VarPatName y -> do+ reportSLn "scope.pat" 60 $ " resolved to VarPatName " ++ prettyShow y ++ " with range " ++ prettyShow (getRange y)+ return $ VarP $ A.mkBindName y++ ConPatName ds -> do+ unless canBeConstructor $ err IsConstructor+ return $ ConP (ConPatInfo ConOCon info ConPatEager) (ambigName ds) []++ PatternSynPatName ds -> do+ unless canBeConstructor $ err IsPatternSynonym+ return $ PatternSynP info (ambigName ds) []++ DefPatName d -> do+ unless displayLhs __IMPOSSIBLE__+ return $ DefP info (unambigName d) []++ where+ r = getRange x+ info = PatRange r+ err s = setCurrentRange r $ typeError $ InvalidPun s x++-- | Apply an abstract syntax pattern head to pattern arguments.+--+-- Fails with 'InvalidPattern' if head is not a constructor pattern+-- (or similar) that can accept arguments.+--+applyAPattern+ :: C.Pattern -- ^ The application pattern in concrete syntax.+ -> A.Pattern' C.Expr -- ^ Head of application.+ -> NAPs1 C.Expr -- ^ Arguments of application.+ -> ScopeM (A.Pattern' C.Expr)+applyAPattern p0 p ps1 = do+ let ps = List1.toList ps1+ setRange (getRange p0) <$> do+ case p of+ A.ConP i x as -> return $ A.ConP i x (as ++ ps)+ A.DefP i x as -> return $ A.DefP i x (as ++ ps)+ A.PatternSynP i x as -> return $ A.PatternSynP i x (as ++ ps)+ -- Dotted constructors are turned into "lazy" constructor patterns.+ A.DotP i (Ident x) -> resolveName x >>= \case+ ConstructorName _ ds -> do+ let cpi = ConPatInfo ConOCon i ConPatLazy+ c = ambigName ds+ return $ A.ConP cpi c ps+ _ -> failure+ A.DotP{} -> failure+ A.VarP{} -> failure+ A.ProjP{} -> failure+ A.WildP{} -> failure+ A.AsP{} -> failure+ A.AbsurdP{} -> failure+ A.LitP{} -> failure+ A.RecP{} -> failure+ A.EqualP{} -> failure+ A.WithP{} -> failure+ where+ failure = typeError $ InvalidPattern p0++-- | Throw-away wrapper type for pattern translation.+data WithHidingInfo a = WithHidingInfo Hiding a++propagateHidingInfo :: NamedArg a -> NamedArg (WithHidingInfo a)+propagateHidingInfo a = fmap (fmap $ WithHidingInfo $ getHiding a) a++-- | Hiding info is only used for pattern variables.+instance ToAbstract (WithHidingInfo C.Pattern) where+ type AbsOfCon (WithHidingInfo C.Pattern) = A.Pattern' C.Expr++ toAbstract (WithHidingInfo h (C.IdentP canBeConstructor x)) =+ resolvePatternIdentifier canBeConstructor NoDisplayLHS h x Nothing++ toAbstract (WithHidingInfo _ p) = toAbstract p++-- | Scope check a 'C.Pattern' (of possibly a 'C.DisplayForm').+--+data CPattern = CPattern+ DisplayLHS+ -- ^ Are we checking a 'C.DisplayForm'?+ C.Pattern+ -- ^ The pattern to scope-check.++-- | Scope check a 'C.Pattern' not belonging to a 'C.DisplayForm'.+--+instance ToAbstract C.Pattern where+ type AbsOfCon C.Pattern = A.Pattern' C.Expr++ toAbstract = toAbstract . CPattern NoDisplayLHS++instance ToAbstract CPattern where+ type AbsOfCon CPattern = A.Pattern' C.Expr++ toAbstract (CPattern displayLhs p0) = do+ case p0 of++ C.IdentP canBeConstructor x ->+ resolvePatternIdentifier canBeConstructor displayLhs empty x Nothing++ QuoteP _r ->+ typeError $ CannotQuote CannotQuoteNothing++ AppP (QuoteP _) p+ | IdentP _ x <- namedArg p -> do+ if visible p then do+ e <- toAbstract (OldQName x Nothing)+ A.LitP (PatRange $ getRange x) . LitQName <$> quotedName e+ else typeError $ CannotQuote CannotQuoteHidden+ | otherwise -> typeError $ CannotQuote $ CannotQuotePattern p++ AppP p q -> do+ reportSLn "scope.pat" 50 $ "distributeDots before = " ++ show p+ p <- distributeDots p+ reportSLn "scope.pat" 50 $ "distributeDots after = " ++ show p+ p' <- toAbstract (wrap p)+ -- Remember hiding info in argument to propagate to 'PatternBound'.+ q' <- ifThenElse displayLhs+ {-then-} (toAbstract $ (fmap . fmap) wrap q)+ {-else-} (toAbstract $ propagateHidingInfo q)+ applyAPattern p0 p' $ singleton q'++ where+ distributeDots :: C.Pattern -> ScopeM C.Pattern+ distributeDots p@(C.DotP kwr r _ppp e) = distributeDotsExpr kwr r e+ distributeDots p = return p++ distributeDotsExpr :: KwRange -> Range -> C.Expr -> ScopeM C.Pattern+ distributeDotsExpr kwr r e = parseRawApp e >>= \case+ C.App r e a ->+ AppP <$> distributeDotsExpr empty r e+ <*> (traverse . traverse) (distributeDotsExpr empty r) a+ OpApp r q ns as ->+ case (traverse . traverse . traverse) fromNoPlaceholder as of+ Just as -> OpAppP r q ns <$>+ (traverse . traverse . traverse) (distributeDotsExpr empty r) as+ Nothing -> return $ C.DotP empty r CannotBeProjectionPattern e+ Paren r e -> ParenP r <$> distributeDotsExpr empty r e+ _ -> return $ C.DotP kwr r CannotBeProjectionPattern e++ fromNoPlaceholder :: MaybePlaceholder (OpApp a) -> Maybe a+ fromNoPlaceholder (NoPlaceholder _ (Ordinary e)) = Just e+ fromNoPlaceholder _ = Nothing++ parseRawApp :: C.Expr -> ScopeM C.Expr+ parseRawApp (RawApp r es) = parseApplication es+ parseRawApp e = return e++ OpAppP r op ns ps -> do+ reportSLn "scope.pat" 60 $ "ConcreteToAbstract.toAbstract OpAppP{}: " ++ show p0+ p <- resolvePatternIdentifier True displayLhs empty op (Just ns)+ -- Remember hiding info in arguments to propagate to 'PatternBound'.+ ps <- ifThenElse displayLhs+ {-then-} (toAbstract $ (fmap . fmap . fmap) wrap ps)+ {-else-} (toAbstract $ fmap propagateHidingInfo ps)+ applyAPattern p0 p ps++ EllipsisP _ mp -> maybe __IMPOSSIBLE__ toAbstract mp -- Not in DISPLAY pragma++ -- Removed when parsing+ HiddenP _ _ -> __IMPOSSIBLE__+ InstanceP _ _ -> __IMPOSSIBLE__+ RawAppP _ _ -> __IMPOSSIBLE__++ C.WildP r -> return $ A.WildP $ PatRange r+ -- Andreas, 2015-05-28 futile attempt to fix issue 819: repeated variable on lhs "_"+ -- toAbstract p@(C.WildP r) = A.VarP <$> freshName r "_"+ C.ParenP _ p -> toAbstract $ wrap p -- Andreas, 2024-09-27 not impossible+ C.LitP r l -> setCurrentRange r $ A.LitP (PatRange r) l <$ checkLiteral l++ C.AsP r x p -> do+ -- Andreas, 2018-06-30, issue #3147: as-variables can be non-linear a priori!+ -- x <- toAbstract (NewName PatternBound x)+ -- Andreas, 2020-05-01, issue #4631: as-variables should not shadow constructors.+ -- x <- bindPatternVariable x+ toAbstract (PatName (C.QName x) Nothing empty NoDisplayLHS) >>= \case+ VarPatName x -> A.AsP (PatRange r) (A.mkBindName x) <$> toAbstract (wrap p)+ ConPatName{} -> ignoreAsPat IsConstructor+ PatternSynPatName{} -> ignoreAsPat IsPatternSynonym+ DefPatName{} -> __IMPOSSIBLE__ -- because of @False@ in @PatName@+ where+ -- An @-bound name which shadows a constructor is illegal and becomes dead code.+ ignoreAsPat b = do+ setCurrentRange x $ warning $ AsPatternShadowsConstructorOrPatternSynonym b+ toAbstract $ wrap p++ C.EqualP r es -> return $ A.EqualP (PatRange r) es++ -- We have to do dot patterns at the end since they can+ -- refer to the variables bound by the other patterns.+ C.DotP _kwr r CannotBeProjectionPattern e -> return $ A.DotP (PatRange r) e+ C.DotP _kwr r CouldBeProjectionPattern e -> do+ reportSLn "scope.pat" 90 $ "ConcreteToAbstract.toAbstract DotP{}: " ++ show p0+ case e of+ C.Ident x -> resolveName x >>= \case+ -- Andreas, 2018-06-19, #3130+ -- We interpret .x as postfix projection if x is a field name in scope+ FieldName xs -> do+ reportSLn "scope.pat" 80 $ "ConcreteToAbstract.toAbstract DotP{}: returning A.ProjP{}"+ return $ A.ProjP (PatRange r) ProjPostfix $ ambigName xs+ _ -> fallback+ _ -> fallback+ where+ fallback = do+ reportSLn "scope.pat" 80 $ "ConcreteToAbstract.toAbstract DotP{}: returning A.DotP{}"+ return $ A.DotP (PatRange r) e++ C.AbsurdP r -> return $ A.AbsurdP $ PatRange r+ C.RecP kwr r fs -> A.RecP kwr (ConPatInfo ConORec (PatRange r) ConPatEager) <$> mapM (traverse $ toAbstract . wrap) fs+ C.WithP r p -> A.WithP (PatRange r) <$> toAbstract p -- not in DISPLAY pragma++ where+ -- Pass on @displayLhs@ context+ wrap = CPattern displayLhs++-- | An argument @OpApp C.Expr@ to an operator can have binders,+-- in case the operator is some @syntax@-notation.+-- For these binders, we have to create lambda-abstractions.+toAbstractOpArg :: Precedence -> OpApp C.Expr -> ScopeM (Ranged A.Expr)+toAbstractOpArg ctx (Ordinary e) = Ranged (getRange e) <$> toAbstractCtx ctx e+toAbstractOpArg ctx (SyntaxBindingLambda r bs e) = Ranged r <$> toAbstractLam r bs e ctx++-- | Turn an operator application into abstract syntax. Make sure to+-- record the right precedences for the various arguments.+toAbstractOpApp :: C.QName -> Set1 A.Name -> OpAppArgs -> ScopeM A.Expr+toAbstractOpApp op ns es = do+ -- Replace placeholders with bound variables.+ (binders, es) <- replacePlaceholders $ List1.toList es+ -- Get the notation for the operator.+ nota <- getNotation op ns+ let parts = notation nota+ -- We can throw away the @VarPart@s, since binders+ -- have been preprocessed into @OpApp C.Expr@.+ 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__+ -- Translate operator and its arguments (each in the right context).+ op <- toAbstract (OldQName op (Just ns))+ es <- left (notaFixity nota) nonBindingParts es+ -- Prepend the generated section binders (if any).+ let body = List.foldl' app op es+ return $ foldr (A.Lam (ExprRange (getRange body))) body binders+ where+ -- Build an application in the abstract syntax, with correct Range.+ app e (pref, argR) = A.App info e arg+ where arg = (fmap rangedThing) <$> argR+ info = (defaultAppInfo r) { appOrigin = getOrigin arg+ , appParens = pref }+ r = fuseRange e argR++ inferParenPref :: NamedArg (Either A.Expr (OpApp C.Expr)) -> ParenPreference+ inferParenPref e =+ case namedArg e of+ Right (Ordinary e) -> inferParenPreference e+ Left{} -> PreferParenless -- variable inserted by section expansion+ Right{} -> PreferParenless -- syntax lambda++ -- Translate an argument. Returns the paren preference for the argument, so+ -- we can build the correct info for the A.App node.+ toAbsOpArg :: Precedence ->+ NamedArg (Either A.Expr (OpApp C.Expr)) ->+ ScopeM (ParenPreference, NamedArg (Ranged A.Expr))+ toAbsOpArg cxt e = (pref,) <$> (traverse . traverse) (either (return . Ranged noRange) (toAbstractOpArg cxt)) e+ where pref = inferParenPref e++ -- The hole left to the first @IdPart@ is filled with an expression in @LeftOperandCtx@.+ left :: Fixity+ -> [NotationPart]+ -> [NamedArg (Either A.Expr (OpApp C.Expr))]+ -> ScopeM [(ParenPreference, NamedArg (Ranged A.Expr))]+ left f (IdPart _ : xs) es = inside f xs es+ left f (_ : xs) (e : es) = do+ e <- toAbsOpArg (LeftOperandCtx f) e+ es <- inside f xs es+ return (e : es)+ left f (_ : _) [] = __IMPOSSIBLE__+ left f [] _ = __IMPOSSIBLE__++ -- The holes in between the @IdPart@s are filled with an expression in @InsideOperandCtx@.+ inside :: Fixity+ -> [NotationPart]+ -> [NamedArg (Either A.Expr (OpApp C.Expr))]+ -> ScopeM [(ParenPreference, NamedArg (Ranged A.Expr))]+ inside f [x] es = right f x es+ inside f (IdPart _ : xs) es = inside f xs es+ inside f (_ : xs) (e : es) = do+ e <- toAbsOpArg InsideOperandCtx e+ es <- inside f xs es+ return (e : es)+ inside _ [] [] = return []+ inside _ (_ : _) [] = __IMPOSSIBLE__+ inside _ [] (_ : _) = __IMPOSSIBLE__++ -- The hole right of the last @IdPart@ is filled with an expression in @RightOperandCtx@.+ right :: Fixity+ -> NotationPart+ -> [NamedArg (Either A.Expr (OpApp C.Expr))]+ -> ScopeM [(ParenPreference, NamedArg (Ranged A.Expr))]+ right _ (IdPart _) [] = return []+ right f _ [e] = do+ let pref = inferParenPref e+ e <- toAbsOpArg (RightOperandCtx f pref) e+ return [e]+ right _ _ _ = __IMPOSSIBLE__++ replacePlaceholders ::+ OpAppArgs0 e ->+ ScopeM ([A.LamBinding], [NamedArg (Either A.Expr (OpApp e))])+ replacePlaceholders [] = return ([], [])+ replacePlaceholders (a : as) = case namedArg a of+ NoPlaceholder _ x -> second (set (Right x) a :) <$>+ replacePlaceholders as+ Placeholder _ -> do+ x <- freshName noRange "section"+ let i = setOrigin Inserted $ argInfo a+ (ls, ns) <- replacePlaceholders as+ return ( A.mkDomainFree (unnamedArg i $ A.insertedBinder_ x) : ls+ , set (Left (Var x)) a : ns+ )+ where+ set :: a -> NamedArg b -> NamedArg a+ set x arg = fmap (fmap (const x)) arg++-- | Raises an error if the list of attributes contains an unsupported+-- attribute.++checkAttributes :: Attributes -> ScopeM ()+checkAttributes [] = return ()+checkAttributes (Attr r s attr : attrs) =+ case attr of+ RelevanceAttribute{} -> cont+ CA.TacticAttribute{} -> cont+ LockAttribute IsNotLock -> cont+ LockAttribute IsLock{} -> do+ unlessM (optGuarded <$> pragmaOptions) $+ setCurrentRange r $ typeError $ AttributeKindNotEnabled "Lock" "--guarded" s+ cont+ RewriteAttribute rew -> do+ when (isRewrite rew) $ unlessM localRewritingOption $+ setCurrentRange r $ typeError $ AttributeKindNotEnabled "Rewrite" "--local-rewriting" s cont QuantityAttribute Quantityω{} -> cont QuantityAttribute Quantity1{} -> __IMPOSSIBLE__
src/full/Agda/Syntax/Translation/InternalToAbstract.hs view
@@ -23,27 +23,27 @@ import Prelude hiding (null) +import Control.Monad.Trans.Maybe import Control.Applicative ( liftA2 )-import Control.Arrow ( (&&&) ) import Control.Monad ( filterM, forM ) -import qualified Data.List as List-import qualified Data.Map as Map+import Data.List qualified as List+import Data.Map qualified as Map import Data.Maybe-import Data.Semigroup ( Semigroup, (<>) ) import Data.Set (Set)-import qualified Data.Set as Set-import qualified Data.Text as T+import Data.Set qualified as Set+import Data.Text qualified as T import Data.Traversable (mapM) import Agda.Syntax.Literal import Agda.Syntax.Position import Agda.Syntax.Common-import qualified Agda.Syntax.Concrete.Name as C+import Agda.Syntax.Common.Aspect qualified as Asp+import Agda.Syntax.Concrete.Name qualified as C import Agda.Syntax.Concrete (FieldAssignment'(..), TacticAttribute'(..)) import Agda.Syntax.Info as Info import Agda.Syntax.Abstract as A hiding (Binder)-import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Abstract qualified as A import Agda.Syntax.Abstract.Pattern import Agda.Syntax.Abstract.Pretty import Agda.Syntax.Abstract.UsedNames@@ -62,16 +62,18 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.SyntacticEquality import Agda.TypeChecking.Telescope+import {-# SOURCE #-} Agda.TypeChecking.Records import Agda.Interaction.Options import Agda.Utils.Either+import Agda.Utils.Function (applyUnless) import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.List1 (List1, pattern (:|))-import qualified Agda.Utils.List1 as List1-import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.List1 qualified as List1+import Agda.Utils.Maybe.Strict qualified as Strict import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null@@ -79,6 +81,8 @@ import Agda.Syntax.Common.Pretty import Agda.Utils.Singleton import Agda.Utils.Size+import Agda.Utils.SmallSet (SmallSet)+import Agda.Utils.SmallSet qualified as SmallSet import Agda.Utils.Tuple import Agda.Utils.Impossible@@ -98,7 +102,7 @@ {-# SPECIALIZE apps :: Expr -> [Arg Expr] -> TCM Expr #-} -- | Drops hidden arguments unless --show-implicit. apps :: MonadReify m => Expr -> [Arg Expr] -> m Expr-apps e = elims e . map I.Apply+apps e = elims e . map' I.Apply -- Composition of reified eliminations ------------------------------------ @@ -111,8 +115,13 @@ nelims e (I.Apply arg : es) = do arg <- reify arg -- This replaces the arg by _ if irrelevant dontShowImp <- not <$> showImplicitArguments- let hd | notVisible arg && dontShowImp = e- | otherwise = A.App defaultAppInfo_ e arg+ let+ drop+ | ConversionFail <- argInfoOrigin (argInfo arg) = False+ | notVisible arg = dontShowImp+ | otherwise = False+ hd | drop = e+ | otherwise = A.App defaultAppInfo_ e arg nelims hd es nelims e (I.Proj ProjPrefix d : es) = nelimsProjPrefix e d es nelims e (I.Proj o d : es) | isSelf e = nelims (A.Proj ProjPrefix $ unambiguous d) es@@ -134,7 +143,7 @@ {-# SPECIALIZE elims :: Expr -> [I.Elim' Expr] -> TCM Expr #-} -- | Drops hidden arguments unless --show-implicit. elims :: MonadReify m => Expr -> [I.Elim' Expr] -> m Expr-elims e = nelims e . map (fmap unnamed)+elims e = nelims e . map' (fmap unnamed) -- Omitting information --------------------------------------------------- @@ -189,7 +198,7 @@ reifyWhen = reifyWhenE reify x = do- b <- asksTC envPrintMetasBare+ b <- viewTC ePrintMetasBare mvar <- lookupLocalMeta x let mi = mvInfo mvar let mi' = Info.MetaInfo@@ -250,7 +259,7 @@ -> A.Patterns -- ^ Remaining trailing patterns ("with patterns"). -> m (QName, A.Patterns) -- ^ New head symbol and new patterns. reifyDisplayFormP f ps wps = do- let fallback = return (f, ps ++ wps)+ let fallback = return (f, ps ++! wps) ifNotM displayFormsEnabled fallback $ {- else -} do -- Try to rewrite @f 0 1 2 ... |ps|-1@ to a dt. -- Andreas, 2014-06-11 Issue 1177:@@ -260,9 +269,9 @@ -- But apparently, it has no influence... -- Ulf, can you add an explanation? md <- -- addContext (replicate (length ps) "x") $- displayForm f $ zipWith (\ p i -> I.Apply $ p $> I.var i) ps [0..]- reportSLn "reify.display" 60 $- "display form of " ++ prettyShow f ++ " " ++ show ps ++ " " ++ show wps ++ ":\n " ++ show md+ displayForm f $ zipWith' (\ p i -> I.Apply $ p $> I.var i) ps [0..]+ reportSLn "reify.display" 95 $+ "display form of " ++! prettyShow f ++! " " ++! show ps ++! " " ++! show wps ++! ":\n " ++! show md case md of Just d | okDisplayForm d -> do -- In the display term @d@, @var i@ should be a placeholder@@ -271,12 +280,12 @@ -- Are we sure that @d@ did not use @var i@ otherwise? (f', ps', wps') <- displayLHS ps d reportSDoc "reify.display" 70 $ do- doc <- prettyA $ SpineLHS empty f' (ps' ++ wps' ++ wps)+ doc <- prettyA $ SpineLHS empty f' (ps' ++! wps' ++! wps) return $ vcat [ "rewritten lhs to" , " lhs' = " <+> doc ]- reifyDisplayFormP f' ps' (wps' ++ wps)+ reifyDisplayFormP f' ps' (wps' ++! wps) _ -> do reportSLn "reify.display" 70 $ "display form absent or not valid as lhs" fallback@@ -342,14 +351,13 @@ flattenWith :: DisplayTerm -> (QName, [I.Elim' DisplayTerm], [I.Elim' DisplayTerm]) flattenWith (DWithApp d ds1 es2) = let (f, es, ds0) = flattenWith d- in (f, es, ds0 ++ map (I.Apply . defaultArg) (List1.toList ds1) ++ map (fmap DTerm) es2)+ in (f, es, ds0 ++! map' (I.Apply . defaultArg) (List1.toList ds1) ++! map' (fmap DTerm) es2) flattenWith (DDef f es) = (f, es, []) -- .^ hacky, but we should only hit this when printing debug info- flattenWith (DTerm' (I.Def f es') es) = (f, map (fmap DTerm) $ es' ++ es, [])+ flattenWith (DTerm' (I.Def f es') es) = (f, map' (fmap DTerm) $ es' ++! es, []) flattenWith _ = __IMPOSSIBLE__ displayLHS- :: MonadReify m- => A.Patterns -- Patterns to substituted into display term.+ :: A.Patterns -- Patterns to substituted into display term. -> DisplayTerm -- Display term. -> m (QName, A.Patterns, A.Patterns) -- New head, patterns, with-patterns. displayLHS ps d = do@@ -358,27 +366,27 @@ wps <- mapM (updateNamedArg (A.WithP empty) <.> elimToPat) es return (f, ps, wps) where- argToPat :: MonadReify m => Arg DisplayTerm -> m (NamedArg A.Pattern)+ argToPat :: Arg DisplayTerm -> m (NamedArg A.Pattern) argToPat arg = traverse termToPat arg - elimToPat :: MonadReify m => I.Elim' DisplayTerm -> m (NamedArg A.Pattern)+ elimToPat :: I.Elim' DisplayTerm -> m (NamedArg A.Pattern) elimToPat (I.IApply _ _ r) = argToPat (Arg defaultArgInfo r) elimToPat (I.Apply arg) = argToPat arg- elimToPat (I.Proj o d) = return $ defaultNamedArg $ A.ProjP patNoRange o $ unambiguous d+ elimToPat (I.Proj o d) = return $! defaultNamedArg $ A.ProjP patNoRange o $ unambiguous d -- Substitute variables in display term by patterns.- termToPat :: MonadReify m => DisplayTerm -> m (Named_ A.Pattern)+ termToPat :: DisplayTerm -> m (Named_ A.Pattern) -- Main action HERE: termToPat (DTerm (I.Var n [])) =- return $ unArg $ fromMaybe __IMPOSSIBLE__ $ ps !!! n+ return $! unArg $ fromMaybe __IMPOSSIBLE__ $ ps !!! n termToPat (DCon c ci vs) = fmap unnamed <$> tryRecPFromConP =<< do A.ConP (ConPatInfo ci patNoRange ConPatEager) (unambiguous (conName c)) <$> mapM argToPat vs termToPat (DTerm' (I.Con c ci vs) es) = fmap unnamed <$> tryRecPFromConP =<< do A.ConP (ConPatInfo ci patNoRange ConPatEager) (unambiguous (conName c)) <$>- mapM (elimToPat . fmap DTerm) (vs ++ es)+ mapM (elimToPat . fmap DTerm) (vs ++! es) termToPat (DTerm (I.Def _ [])) = return $ unnamed $ A.WildP patNoRange termToPat (DDef _ []) = return $ unnamed $ A.WildP patNoRange@@ -393,13 +401,13 @@ len = length ps - argsToExpr :: MonadReify m => I.Args -> m [Arg A.Expr]+ argsToExpr :: I.Args -> m [Arg A.Expr] argsToExpr = mapM (traverse termToExpr) -- TODO: restructure this to avoid having to repeat the code for reify- termToExpr :: MonadReify m => Term -> m A.Expr+ termToExpr :: Term -> m A.Expr termToExpr v = do- reportSLn "reify.display" 60 $ "termToExpr " ++ show v+ reportSLn "reify.display" 60 $ "termToExpr " ++! show v -- After unSpine, a Proj elimination is __IMPOSSIBLE__! case unSpine v of I.Con c ci es -> do@@ -415,7 +423,7 @@ -- even the pattern variables @n < len@ can be -- applied to some args @vs@. e <- if n < len- then return $ patternToExpr $ namedArg $ indexWithDefault __IMPOSSIBLE__ ps n+ then return $! patternToExpr $ namedArg $ indexWithDefault __IMPOSSIBLE__ ps n else reify (I.var (n - len)) apps e =<< argsToExpr vs _ -> return underscore@@ -435,7 +443,7 @@ {-# SPECIALIZE reifyPathPConstAsPath :: QName -> Elims -> TCM (QName, Elims) #-} reifyPathPConstAsPath :: MonadReify m => QName -> Elims -> m (QName, Elims) reifyPathPConstAsPath x es@[I.Apply l, I.Apply t, I.Apply lhs, I.Apply rhs] = do- reportSLn "reify.def" 100 $ "reifying def path " ++ show (x,es)+ reportSLn "reify.def" 100 $ "reifying def path " ++! show (x,es) mpath <- getBuiltinName' builtinPath mpathp <- getBuiltinName' builtinPathP let fallback = return (x,es)@@ -456,11 +464,11 @@ -- | Check if the term matches an existing let-binding, in that case use the corresponding variable, -- otherwise reify using the continuation. tryReifyAsLetBinding :: MonadReify m => Term -> m Expr -> m Expr-tryReifyAsLetBinding v fallback = ifM (asksTC $ not . envFoldLetBindings) fallback $ do+tryReifyAsLetBinding v fallback = ifM (not <$> viewTC eFoldLetBindings) fallback $ do letBindings <- do- binds <- asksTC (Map.toAscList . envLetBindings)+ binds <- Map.toAscList <$> viewTC eLetBindings opened <- forM binds $ \ (name, open) -> (,name) <$> getOpen open- return [ (body, name) | (LetBinding UserWritten body _, name) <- opened, not $ isNoName name ] -- Only fold user-written lets+ return [ (body, name) | (LetBinding _isAxiom UserWritten body _, name) <- opened, not $ isNoName name ] -- Only fold user-written lets matchingBindings <- filterM (\t -> checkSyntacticEquality v (fst t) (\_ _ -> return True) (\_ _ -> return False)) letBindings case matchingBindings of (_, name) : _ -> return $ A.Var name@@ -468,18 +476,18 @@ {-# SPECIALIZE reifyTerm :: Bool -> Term -> TCM Expr #-} reifyTerm ::- MonadReify m+ forall m. MonadReify m => Bool -- ^ Try to expand away anonymous definitions? -> Term -> m Expr reifyTerm expandAnonDefs0 v0 = tryReifyAsLetBinding v0 $ do -- Jesper 2018-11-02: If 'PrintMetasBare', drop all meta eliminations.- metasBare <- asksTC envPrintMetasBare- reportSDoc "reify.term" 80 $ pure $ "reifyTerm v0 = " <+> pretty v0+ metasBare <- viewTC ePrintMetasBare+ reportS "reify.term" 80 $ "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+ reportS "reify.term" 80 $ "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@@ -500,7 +508,7 @@ -- print e.g. G .|_| as | G | , hasDisplay name ]- reportSDoc "reify.term" 80 $ pure $ "reifyTerm (unSpine v) = " <+> pretty (unSpine' prefixize v)+ reportS "reify.term" 80 $ "reifyTerm (unSpine v) = " <+> pretty (unSpine' prefixize v) case unSpine' prefixize v of -- Hack to print generalized field projections with nicer names. Should@@ -510,10 +518,10 @@ let fakeName = (qnameName p) {nameConcrete = C.simpleName name} -- TODO: infix names!? elims (A.Var fakeName) =<< reify es I.Var n es -> do- x <- fromMaybeM (freshName_ $ "@" ++ show n) $ nameOfBV' n+ x <- fromMaybeM (freshName_ $ "@" ++! show n) $ nameOfBV' n elims (A.Var x) =<< reify es I.Def x es -> do- reportSDoc "reify.def" 80 $ return $ "reifying def" <+> pretty x+ reportS "reify.def" 80 $ "reifying def" <+> pretty x (x, es) <- reifyPathPConstAsPath x es reifyDisplayForm x es $ reifyDef expandAnonDefs x es @@ -522,7 +530,6 @@ -- If the origin is a record expression, print a record expression. if ci == ConORec then recordExpression Nothing else do isRecordConstructor x >>= \case- -- If it is a generated constructor, print a record expression. Just (r, def) | not (_recNamedCon def) -> recordExpression $ Just (r, def) @@ -534,12 +541,11 @@ recordExpression mrdef = do (r, def) <- maybe (fromMaybe __IMPOSSIBLE__ <$> isRecordConstructor x) pure mrdef showImp <- showImplicitArguments- let keep (a, v) = showImp || visible a+ let keep (a, v) = showImp || ConversionFail == argInfoOrigin (argInfo v) || visible a A.Rec empty noExprInfo- . map (Left . uncurry FieldAssignment . mapFst unDom)- . filter keep- . zip (recordFieldNames def)- . map unArg+ . map' (Left . uncurry FieldAssignment . first unDom . second unArg)+ . filter' keep+ . zip' (recordFieldNames def) <$> reify (fromMaybe __IMPOSSIBLE__ $ allApplyElims es) constructorApplication = reifyDisplayForm x es $ do@@ -579,11 +585,11 @@ -- Andreas, 2012-09-18 -- If the first regular constructor argument is hidden, -- we keep the parameters to avoid confusion.- (Dom {domInfo = info} : _) | notVisible info -> do- let us = for (drop n pars) $ \(Dom {domInfo = ai}) ->+ ((view dInfo -> info) : _) | notVisible info -> do+ let us = for (drop n pars) $ \(view dInfo -> ai) -> -- setRelevance Relevant $ hideOrKeepInstance $ Arg ai underscore- apps h $ us ++ es -- Note: unless --show-implicit, @apps@ will drop @us@.+ apps h $ us ++! es -- Note: unless --show-implicit, @apps@ will drop @us@. -- otherwise, we drop all parameters _ -> apps h es @@ -593,28 +599,41 @@ -- #4160: Hacky solution: if --show-implicit, treat all lambdas as user-written. This will -- prevent them from being dropped by AbstractToConcrete (where we don't have easy access to -- the --show-implicit flag.- info <- ifM showImplicitArguments (return $ setOrigin UserWritten info) (return info)- return $ A.Lam exprNoRange (mkDomainFree $ unnamedArg info $ mkBinder_ x) e+ info <- ifM showImplicitArguments (return $! setOrigin UserWritten info) (return info)+ return $! A.Lam exprNoRange (mkDomainFree $ unnamedArg info $ mkBinder_ x) e -- Andreas, 2011-04-07 we do not need relevance information at internal Lambda I.Lit l -> reify l I.Level l -> reify l I.Pi a b -> case b of- NoAbs _ b'- | 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))- {- then -} (pure $ Arg (domInfo a) underscore)- {- else -} (reify a)+ _ | isIrrelevant a, domIsFinite a -> mkPartial (unEl (unDom a)) b $ mkPi b =<< reify a+ NoAbs _ b'+ | visible 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).+ | otherwise -> mkPi b =<< reify a+ b -> mkPi b =<< do+ ifM (domainFree a (absBody b))+ {- then -} (pure $ Arg (domInfo a) underscore)+ {- else -} (reify a) where+ mkPartial :: Term -> Abs I.Type -> m Expr -> m Expr+ mkPartial (I.Def io [I.Apply fm]) body cont = do+ ion <- getBuiltinName' builtinIsOne+ case reAbs body of+ _ | Just io /= ion -> cont+ NoAbs _ b' -> do+ pn <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinPartial+ hd <- reify (I.Def pn [])+ apps hd =<< traverse reify [ fm, defaultArg (unEl b') ]+ Abs nm b' -> do+ pn <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinPartialP+ hd <- reify (I.Def pn [])+ apps hd =<< traverse reify+ [ fm, defaultArg (I.Lam (setRelevance irrelevant defaultArgInfo) (Abs nm (unEl b'))) ]+ mkPartial _ _ fallback = fallback+ mkPi b (Arg info a') = ifM (skipGeneralizedParameter info) (snd <$> reify b) $ do tac <- TacticAttribute <$> do traverse (Ranged noRange <.> reify) $ domTactic a (x, b) <- reify b@@ -625,10 +644,10 @@ -- We can omit the domain type if it doesn't have any free variables -- and it's mentioned in the target type. domainFree a b = do- df <- asksTC envPrintDomainFreePi- return $ df && freeIn 0 b && closed a+ df <- viewTC ePrintDomainFreePi+ return $! df && freeIn 0 b && closed a - skipGeneralizedParameter :: MonadReify m => ArgInfo -> m Bool+ skipGeneralizedParameter :: ArgInfo -> m Bool skipGeneralizedParameter info = (not <$> showGeneralizedArguments) <&> (&& (argInfoOrigin info == Generalization)) I.Sort s -> reify s@@ -648,7 +667,7 @@ opt_show_ids <- showIdentitySubstitutions let- addNames [] es = map (fmap unnamed) es+ addNames [] es = map' (fmap unnamed) es addNames _ [] = [] addNames xs (I.Proj{} : _) = __IMPOSSIBLE__ addNames xs (I.IApply x y r : es) =@@ -660,7 +679,7 @@ p = mvPermutation mv applyPerm p vs = permute (takeP (size vs) p) vs - names = map (WithOrigin Inserted . unranged) $ p `applyPerm` teleNames meta_tel+ names = map' (WithOrigin Inserted . unranged) $ p `applyPerm` teleNames meta_tel named_es' = addNames names es' dropIdentitySubs sub_local2G sub_tel2G =@@ -671,7 +690,7 @@ where xv = deBruijnView $ unArg x sameVar _ _ = False- dropArg = take (size names) $ zipWith sameVar args_G es_G+ dropArg = take' (size names) $ zipWith' sameVar args_G es_G doDrop (b : xs) (e : es) = (if b then id else (e :)) $ doDrop xs es doDrop [] es = es doDrop _ [] = []@@ -688,22 +707,22 @@ showIrr <- optShowIrrelevant <$> pragmaOptions if | showIrr -> reifyTerm expandAnonDefs v | otherwise -> return underscore- I.Dummy s [] -> return $ A.Lit empty $ LitString (T.pack s)- I.Dummy "applyE" es | I.Apply (Arg _ h) : es' <- es -> do- h <- reify h- es' <- reify es'- elims h es'- | otherwise -> __IMPOSSIBLE__- I.Dummy s es -> do- s <- reify (I.Dummy s [])- es <- reify es- elims s es++ I.Dummy s es -> reifyDummy s es where+ reifyDummy kind es =+ case kind of+ I.DummyBrave h -> elims' (reify h)+ I.DummyNamed s -> elims (A.Lit empty $ LitString (T.pack s)) =<< reify es+ where+ elims' a = do { h <- a ; es <- reify es ; elims h es }+ asp o = empty { Asp.otherAspects = Set.singleton o }+ -- Andreas, 2012-10-20 expand a copy if not in scope -- to improve error messages. -- Don't do this if we have just expanded into a display form, -- otherwise we loop!- reifyDef :: MonadReify m => Bool -> QName -> I.Elims -> m Expr+ reifyDef :: Bool -> QName -> I.Elims -> m Expr reifyDef True x es = ifM (not . null . inverseScopeLookupName x <$> getScope) (reifyDef' x es) $ do r <- reduceDefCopy x es@@ -711,27 +730,35 @@ YesReduction _ v -> do reportS "reify.anon" 60 [ "reduction on defined ident. in anonymous module"- , "x = " ++ prettyShow x- , "v = " ++ show v+ , "x = " ++! prettyShow x+ , "v = " ++! show v ] reify v NoReduction () -> do reportS "reify.anon" 60 [ "no reduction on defined ident. in anonymous module"- , "x = " ++ prettyShow x- , "es = " ++ show es+ , "x = " ++! prettyShow x+ , "es = " ++! show es ] reifyDef' x es reifyDef _ x es = reifyDef' x es - reifyDef' :: MonadReify m => QName -> I.Elims -> m Expr+ discontiguous :: I.Elims -> Bool+ discontiguous [] = False+ discontiguous (I.IApply{}:es) = discontiguous es+ discontiguous (I.Proj{}:es) = discontiguous es+ discontiguous (I.Apply (Arg info _):es) =+ (notVisible info && ConversionFail == argInfoOrigin info) || discontiguous es++ reifyDef' :: QName -> I.Elims -> m Expr reifyDef' x es = do- reportSLn "reify.def" 60 $ "reifying call to " ++ prettyShow x+ reportSLn "reify.def" 60 $ "reifying call to " ++! prettyShow x -- We should drop this many arguments from the local context. n <- getDefFreeVars x- reportSLn "reify.def" 70 $ "freeVars for " ++ prettyShow x ++ " = " ++ show n+ reportSLn "reify.def" 70 $ "freeVars for " ++! prettyShow x ++! " = " ++! show n -- If the definition is not (yet) in the signature, -- we just do the obvious.+ showImp <- showImplicitArguments let fallback _ = elims (A.Def x) =<< reify (drop n es) caseEitherM (getConstInfo' x) fallback $ \ defn -> do let def = theDef defn@@ -748,10 +775,10 @@ if | n > length es -> do -- We don't have all arguments before the absurd one! let name (I.VarP _ x) = patVarNameToString $ dbPatVarName x name _ = __IMPOSSIBLE__ -- only variables before absurd pattern- vars = map (getArgInfo &&& name . namedArg) $ drop (length es) ps+ vars = map' (getArgInfo &&& name . namedArg) $ drop (length es) ps lam (i, s) = do x <- freshName_ s- return $ A.Lam exprNoRange (A.mkDomainFree $ unnamedArg i $ A.mkBinder_ x)+ return $! A.Lam exprNoRange (A.mkDomainFree $ unnamedArg i $ A.mkBinder_ x) foldr ($) absLam <$> mapM lam vars | otherwise -> elims absLam =<< reify (drop n es) @@ -795,7 +822,7 @@ (pad, nes :: [Elim' (Named_ Term)]) <- case def of Function{ funProjection = Right Projection{ projIndex = np } } | np > 0 -> do- reportSLn "reify.def" 70 $ " def. is a projection with projIndex = " ++ show np+ reportSLn "reify.def" 70 $ " def. is a projection with projIndex = " ++! show np -- This is tricky: -- * getDefFreeVars x tells us how many arguments@@ -813,11 +840,11 @@ scope <- getScope let underscore = A.Underscore $ Info.emptyMetaInfo { metaScope = scope } let pad :: [NamedArg Expr]- pad = for as $ \ (Dom{domInfo = ai, unDom = (x, _)}) ->+ pad = for as $ \ d -> let ai = d ^. dInfo; x = fst (unDom d) in Arg ai $ Named (Just $ WithOrigin Inserted $ unranged x) underscore -- TODO #3353 Origin from Dom? - -- Now pad' ++ es' = drop n (pad ++ es)+ -- Now pad' ++! es' = drop n (pad ++! es) let pad' = drop n pad es' = drop (max 0 (n - size pad)) es -- Andreas, 2012-04-21: get rid of hidden underscores {_} and {{_}}@@ -839,7 +866,7 @@ let (padVisNamed, padRest) = filterAndRest visible pad' -- Remove the names from the visible arguments.- let padVis = map (fmap $ unnamed . namedThing) padVisNamed+ let padVis = map' (fmap $ unnamed . namedThing) padVisNamed -- Keep only the rest with the same visibility of @dom@... let padTail = filter (sameHiding dom) padRest@@ -847,22 +874,50 @@ -- ... and even the same name. let padSame = filter ((Just (fst $ unDom dom) ==) . bareNameOf) padTail - return $ if null padTail || not showImp- then (padVis , map (fmap unnamed) es')- else (padVis ++ padSame, nameFirstIfHidden dom es')+ return $! if null padTail || not showImp+ then (padVis , map' (fmap unnamed) es')+ else (padVis ++! padSame, nameFirstIfHidden dom es') - -- If it is not a projection(-like) function, we need no padding.- _ -> return ([], map (fmap unnamed) $ drop n es)+ -- If the conversion checker asked us to show an implicit+ -- argument that would otherwise be hidden, it might need to+ -- be named.+ _ | not showImp && discontiguous es ->+ runMaybeT (nameElims False (I.Def x []) (defType defn) (drop n es)) >>= \case+ Just xs -> pure ([], xs)+ Nothing -> pure ([], map' (fmap unnamed) $ drop n es) - reportSDoc "reify.def" 100 $ return $ vcat+ -- Otherwise, we need no padding.+ _ -> return ([], map' (fmap unnamed) $ drop n es)++ reportS "reify.def" 100 $ vcat [ " pad =" <+> pshow pad , " nes =" <+> pshow nes ]- let hd0 | isProperProjection def = A.Proj ProjPrefix $ AmbQ $ singleton x+ let hd0 | isProperProjection def = A.Proj ProjPrefix $ unambiguous x | otherwise = A.Def x let hd = List.foldl' (A.App defaultAppInfo_) hd0 pad nelims hd =<< reify nes + -- Name any 'ConversionFail' arguments that are in the wrong position in the spine.+ nameElims :: Bool -> I.Term -> I.Type -> I.Elims -> MaybeT m [Elim' (Named_ Term)]+ nameElims _ _ _ [] = pure []+ nameElims needs acc ty (I.IApply _ _ tm:as) = nameElims needs acc ty (I.Apply (defaultArg tm):as)+ nameElims needs acc ty (elim@(I.Apply (Arg info tm)):as) =+ ifNotPiOrPathType ty (\_ -> mzero) \dom cod -> do+ let+ forced = notVisible info && (ConversionFail == argInfoOrigin info)+ arg = I.Apply if forced && needs+ then Arg info (Named (Just $ WithOrigin Inserted $ unranged $ absName cod) tm)+ else Arg info (unnamed tm)+ (arg:) <$> nameElims+ (if visible info then False else not forced)+ (acc `applyE` [elim]) (cod `lazyAbsApp` tm) as+ nameElims _ tm ty (I.Proj o n:as) = do+ ty <- reduce ty+ projectTyped tm ty o n >>= \case+ Nothing -> mzero+ Just (_, tm, ty) -> (I.Proj o n:) <$> nameElims False tm ty as+ -- Andreas, 2016-07-06 Issue #2047 -- With parameter refinement, the "parameter" patterns of an extended@@ -883,15 +938,14 @@ -- extended lambda, instead trying to construct the nice syntax. reifyExtLam- :: MonadReify m- => QName -> ArgInfo -> Int -> Maybe System -> [I.Clause]+ :: QName -> ArgInfo -> Int -> Maybe System -> [I.Clause] -> I.Elims -> m Expr 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+ reportS "reify.def" 10 $ "reifying extended lambda" <+> pretty x+ reportS "reify.def" 50 $ nest 2 $ vcat [ "npars =" <+> pretty npars- , "es =" <+> fsep (map (prettyPrec 10) es)- , "def =" <+> vcat (map pretty cls) ]+ , "es =" <+> fsep (map' (prettyPrec 10) es)+ , "def =" <+> vcat (map' pretty cls) ] -- As extended lambda clauses live in the top level, we add the whole -- section telescope to the number of parameters. let (pares, rest) = splitAt npars es@@ -919,9 +973,9 @@ nameFirstIfHidden :: Dom (ArgName, t) -> [Elim' a] -> [Elim' (Named_ a)] nameFirstIfHidden dom (I.Apply (Arg info e) : es) | notVisible info = I.Apply (Arg info (Named (Just $ WithOrigin Inserted $ unranged $ fst $ unDom dom) e)) :- map (fmap unnamed) es+ map' (fmap unnamed) es nameFirstIfHidden _ es =- map (fmap unnamed) es+ map' (fmap unnamed) es instance Reify i => Reify (Named n i) where type ReifiesTo (Named n i) = Named n (ReifiesTo i)@@ -933,9 +987,11 @@ instance Reify i => Reify (Arg i) where type ReifiesTo (Arg i) = Arg (ReifiesTo i) - reify (Arg info i) = Arg info <$> (flip reifyWhen i =<< condition)- where condition = (return (argInfoHiding info /= Hidden) `or2M` showImplicitArguments)- `and2M` (return (not $ isIrrelevant info) `or2M` showIrrelevantArguments)+ reify (Arg info i) = Arg info <$> (flip reifyWhen i =<< condition) where+ condition+ | ConversionFail <- argInfoOrigin info = pure True+ | otherwise = (return (argInfoHiding info /= Hidden) `or2M` showImplicitArguments)+ `and2M` (return (not $ isIrrelevant info) `or2M` showIrrelevantArguments) reifyWhen b i = traverse (reifyWhen b) i {-# SPECIALIZE reify :: Reify i => Arg i -> TCM (ReifiesTo (Arg i)) #-} @@ -978,20 +1034,20 @@ -> A.Patterns -> A.Patterns -> m A.Patterns stripImplicits toKeep params ps = do -- if --show-implicit we don't need the names- ifM showImplicitArguments (return $ map (fmap removeNameUnlessUserWritten) ps) $ do- reportSDoc "reify.implicit" 100 $ return $ vcat+ ifM showImplicitArguments (return $! map' (fmap removeNameUnlessUserWritten) ps) $ do+ reportS "reify.implicit" 100 $ vcat [ "stripping implicits" , nest 2 $ "ps =" <+> pshow ps ] let ps' = blankDots $ strip ps- reportSDoc "reify.implicit" 100 $ return $ vcat+ reportS "reify.implicit" 100 $ vcat [ nest 2 $ "ps' =" <+> pshow ps' ] return ps' where -- Replace variables in dot patterns by an underscore _ if they are hidden -- in the pattern. This is slightly nicer than making the implicts explicit.- blankDots ps = blank (varsBoundIn $ params ++ ps) ps+ blankDots ps = blank (varsBoundIn $ params ++! ps) ps strip ps = stripArgs True ps where@@ -1039,7 +1095,7 @@ p@(A.LitP _ _) -> p A.AsP i x p -> A.AsP i x $ stripPat p A.PatternSynP _ _ _ -> __IMPOSSIBLE__- A.RecP kwr i fs -> A.RecP kwr i $ map (fmap stripPat) fs -- TODO Andreas: is this right?+ A.RecP kwr i fs -> A.RecP kwr i $ map' (fmap stripPat) fs -- TODO Andreas: is this right? p@A.EqualP{} -> p -- EqualP cannot be blanked. A.WithP i p -> A.WithP i $ stripPat p -- TODO #2822: right? @@ -1057,10 +1113,10 @@ blankNotInScope :: (MonadTCEnv m, MonadDebug m, BlankVars a) => a -> m a blankNotInScope e = do ctxNames <- getContextNames- letNames <- map fst <$> getLetBindings- let names = Set.fromList . filter ((== C.InScope) . C.isInScope) $ ctxNames ++ letNames- reportSDoc "reify.blank" 80 . pure $ "names in scope for blanking:" <+> pretty names- return $ blank names e+ letNames <- map' fst <$> getLetBindings+ let names = Set.fromList . filter ((== C.InScope) . C.isInScope) $ ctxNames ++! letNames+ reportS "reify.blank" 80 $ "names in scope for blanking:" <+> pretty names+ return $! blank names e -- | @blank bound e@ replaces all variables in expression @e@ that are not in @bound@ by@@ -1084,6 +1140,9 @@ instance (BlankVars a, BlankVars b) => BlankVars (a, b) where blank bound (x, y) = (blank bound x, blank bound y) +instance (BlankVars a, BlankVars b, BlankVars c) => BlankVars (a, b, c) where+ blank bound (x, y, z) = (blank bound x, blank bound y, blank bound z)+ instance (BlankVars a, BlankVars b) => BlankVars (Either a b) where blank bound (Left x) = Left $ blank bound x blank bound (Right y) = Right $ blank bound y@@ -1155,6 +1214,8 @@ A.DontCare v -> A.DontCare $ blank bound v A.PatternSyn {} -> e A.Macro {} -> e+ A.Highlighted q e -> A.Highlighted q $ blank bound e+ A.Qualified q e -> A.Qualified q $ blank bound e instance BlankVars A.ModuleName where blank bound = id@@ -1223,7 +1284,7 @@ instance Binder A.LetBinding where varsBoundIn (LetBind _ _ x _ _) = varsBoundIn x varsBoundIn (LetAxiom _ _ x _) = varsBoundIn x- varsBoundIn (LetPatBind _ p _) = varsBoundIn p+ varsBoundIn (LetPatBind _ _ p _)= varsBoundIn p varsBoundIn LetApply{} = empty varsBoundIn LetOpen{} = empty @@ -1258,7 +1319,7 @@ reifyPat :: MonadReify m => I.DeBruijnPattern -> m A.Pattern reifyPat p = do- reportSDoc "reify.pat" 80 $ return $ "reifying pattern" <+> pretty p+ reportS "reify.pat" 80 $ "reifying pattern" <+> pretty p keepVars <- optKeepPatternVariables <$> pragmaOptions case p of -- Possibly expanded literal pattern (see #4215)@@ -1267,7 +1328,7 @@ I.Lit l -> addAsBindings asB $ return $ A.LitP empty l _ -> __IMPOSSIBLE__ I.VarP i x -> addAsBindings (patAsNames i) $ case patOrigin i of- o@PatODot -> reifyDotP o $ var $ dbPatVarIndex x+ o@PatODot -> reifyDotP keepVars o $ var $ dbPatVarIndex x PatOWild -> return $ A.WildP patNoRange PatOAbsurd -> return $ A.AbsurdP patNoRange _ -> reifyVarP x@@ -1278,12 +1339,12 @@ o@(PatOVar x) | I.Var i [] <- v -> do x' <- nameOfBV i if nameConcrete x == nameConcrete x' then- return $ A.VarP $ mkBindName x'+ return $! A.VarP $ mkBindName x' else- reifyDotP o v- o -> reifyDotP o v- I.LitP i l -> addAsBindings (patAsNames i) $ return $ A.LitP empty l- I.ProjP o d -> return $ A.ProjP patNoRange o $ unambiguous d+ reifyDotP keepVars o v+ o -> reifyDotP keepVars o v+ I.LitP i l -> addAsBindings (patAsNames (litPInfo i)) $ return $ A.LitP empty l+ I.ProjP o d -> return $! A.ProjP patNoRange o $ unambiguous d I.ConP c cpi ps | conPRecord cpi -> addAsBindings (patAsNames $ conPInfo cpi) $ case patOrigin (conPInfo cpi) of PatOWild -> return $ A.WildP patNoRange@@ -1297,7 +1358,7 @@ PatOVar x | keepVars -> return $ A.VarP $ mkBindName x _ -> A.DefP patNoRange (unambiguous f) <$> reifyPatterns ps I.IApplyP i _ _ x -> addAsBindings (patAsNames i) $ case patOrigin i of- o@PatODot -> reifyDotP o $ var $ dbPatVarIndex x+ o@PatODot -> reifyDotP keepVars o $ var $ dbPatVarIndex x PatOWild -> return $ A.WildP patNoRange PatOAbsurd -> return $ A.AbsurdP patNoRange _ -> reifyVarP x@@ -1310,16 +1371,15 @@ -- Andreas, 2017-09-03: TODO for #2580 -- Patterns @VarP "()"@ should have been replaced by @AbsurdP@, but the -- case splitter still produces them.- | prettyShow (nameConcrete n) == "()" -> return $ A.VarP (mkBindName n)+ | prettyShow (nameConcrete n) == "()" -> return $! A.VarP (mkBindName n) -- Andreas, 2017-09-03, issue #2729 -- Restore original pattern name. AbstractToConcrete picks unique names.- | otherwise -> return $ A.VarP $+ | otherwise -> return $! A.VarP $ mkBindName n { nameConcrete = C.simpleName y } - reifyDotP :: MonadReify m => PatOrigin -> Term -> m A.Pattern- reifyDotP o v = do- keepVars <- optKeepPatternVariables <$> pragmaOptions- if | PatOVar x <- o , keepVars -> return $ A.VarP $ mkBindName x+ reifyDotP :: MonadReify m => Bool -> PatOrigin -> Term -> m A.Pattern+ reifyDotP keepVars o v = do+ if | PatOVar x <- o , keepVars -> return $! A.VarP $ mkBindName x | PatOSplitArg x <- o , keepVars -> A.VarP . mkBindName <$> freshName noRange x | otherwise -> A.DotP patNoRange <$> reify v @@ -1337,6 +1397,30 @@ addAsBindings :: Functor m => [A.Name] -> m A.Pattern -> m A.Pattern addAsBindings xs p = foldr (fmap . AsP patNoRange . mkBindName) p xs +{-# SPECIALIZE reifyRecordFields :: SmallSet Origin -> RecordData -> (NamedArg A.Pattern -> A.Pattern) -> [NamedArg A.Pattern] -> TCM [FieldAssignment' A.Pattern] #-}+{-# SPECIALIZE reifyRecordFields :: SmallSet Origin -> RecordData -> (Arg Expr -> Expr) -> [Arg Expr] -> TCM [FieldAssignment' Expr] #-}+-- | Pair the fields of a record type with the arguments of its constructor,+-- producing the field assignments of a record pattern or record expression.+--+-- Andreas, 2025-09-29, issue #8787:+-- Invisible (hidden and instance) fields are dropped unless @--show-implicit@ is on.+-- This conforms the printing of records to the printing of applications+-- of a record constructor (see 'stripImplicits' and 'nelims').+reifyRecordFields :: (MonadReify m, LensOrigin a)+ => SmallSet Origin -- ^ Set of origins that make us keep an invisible field anyway.+ -> RecordData -- ^ Definition of the record type, supplying the field names.+ -> (a -> e) -- ^ How to extract the content of a constructor argument.+ -> [a] -- ^ The arguments of the record constructor.+ -> m [FieldAssignment' e]+reifyRecordFields keepOrigins def content args = do+ let fs = recordFieldNames def+ unless (length fs == length args) __IMPOSSIBLE__+ showImp <- showImplicitArguments+ let keep (f, a) = visible f || getOrigin a `SmallSet.member` keepOrigins+ return $! map' (\ (f, a) -> FieldAssignment (unDom f) (content a))+ $ applyUnless showImp (filter' keep)+ $ zip' fs args+ {-# SPECIALIZE tryRecPFromConP :: A.Pattern -> TCM A.Pattern #-} -- | If the record constructor is generated or the user wrote a record pattern, -- turn constructor pattern into record pattern.@@ -1346,37 +1430,44 @@ let fallback = return p case p of A.ConP ci c ps -> do- reportSLn "reify.pat" 60 $ "tryRecPFromConP " ++ prettyShow c+ reportS "reify.pat" 60 $ "tryRecPFromConP" <+> pretty c caseMaybeM (isRecordConstructor $ headAmbQ c) fallback $ \ (r, def) -> do -- If the record constructor is generated or the user wrote a record pattern, -- print record pattern. -- Otherwise, print constructor pattern.- if _recNamedCon def && conPatOrigin ci /= ConORec then fallback else do- let fs = recordFieldNames def- unless (length fs == length ps) __IMPOSSIBLE__- return $ A.RecP empty ci $ zipWith mkFA fs ps- where- mkFA ax nap = FieldAssignment (unDom ax) (namedArg nap)+ if _recNamedCon def && conPatOrigin ci /= ConORec then fallback else+ -- Andreas, 2025-09-29, issue #8787: Keep the invisible fields+ -- the user wrote, just like 'stripImplicits' does for constructor patterns.+ A.RecP empty ci <$> reifyRecordFields recordPatternKeeperOrigins def namedArg ps _ -> __IMPOSSIBLE__ +-- | 'Origin' values (e.g. 'UserWritten') that indicate an implicit record field+-- should be kept during printing of a record pattern.+recordPatternKeeperOrigins :: SmallSet Origin+recordPatternKeeperOrigins = SmallSet.fromList [ UserWritten, CaseSplit ]++-- | 'Origin' values (e.g. 'ConversionFail') that indicate an implicit record field+-- should be kept during printing of a record expression.+recordExpressionKeeperOrigins :: SmallSet Origin+recordExpressionKeeperOrigins = SmallSet.fromList [ ConversionFail ]+ {-# SPECIALIZE recOrCon :: QName -> ConOrigin -> [Arg Expr] -> TCM A.Expr #-} -- | If the record constructor is generated or the user wrote a record expression, -- turn constructor expression into record expression. -- Otherwise, keep constructor expression. recOrCon :: MonadReify m => QName -> ConOrigin -> [Arg Expr] -> m A.Expr recOrCon c co es = do- reportSLn "reify.expr" 60 $ "recOrCon " ++ prettyShow c+ reportS "reify.expr" 60 $ "recOrCon" <+> pretty c caseMaybeM (isRecordConstructor c) fallback $ \ (r, def) -> do -- If the record constructor is generated or the user wrote a record expression, -- print record expression. -- Otherwise, print constructor expression.- if _recNamedCon def && co /= ConORec then fallback else do- let fs = recordFieldNames def- unless (length fs == length es) __IMPOSSIBLE__- return $ A.Rec empty empty $ zipWith mkFA fs es+ if _recNamedCon def && co /= ConORec then fallback else+ -- Andreas, 2025-09-29, issue #8787: Keep the invisible fields+ -- the conversion checker insists on, just like 'nelims' does for applications.+ A.Rec empty empty . map' Left <$> reifyRecordFields recordExpressionKeeperOrigins def unArg es where fallback = apps (A.Con (unambiguous c)) es- mkFA ax = Left . FieldAssignment (unDom ax) . unArg instance Reify (QNamed I.Clause) where type ReifiesTo (QNamed I.Clause) = A.Clause@@ -1387,7 +1478,7 @@ type ReifiesTo NamedClause = A.Clause reify (NamedClause f toDrop cl) = addContext (clauseTel cl) $ do- reportSDoc "reify.clause" 60 $ return $ vcat+ reportS "reify.clause" 60 $ vcat [ "reifying NamedClause" , " f =" <+> pretty f , " toDrop =" <+> pshow toDrop@@ -1395,18 +1486,18 @@ ] let clBody = clauseBody cl- rhsVars = maybe [] freeVars clBody+ rhsVars = freeVarList clBody rhsBody <- traverse reify clBody rhsVarNames <- mapM nameOfBV' rhsVars let rhsUsedNames = maybe mempty allUsedNames rhsBody- rhsUsedVars = [i | (i, Just n) <- zip rhsVars rhsVarNames, n `Set.member` rhsUsedNames]+ rhsUsedVars = [i | (i, Just n) <- zip' rhsVars rhsVarNames, n `Set.member` rhsUsedNames] - reportSDoc "reify.clause" 60 $ return $ "RHS:" <+> pretty clBody- reportSDoc "reify.clause" 60 $ return $ "variables occurring on RHS:" <+> pretty rhsVars+ reportS "reify.clause" 60 $ "RHS:" <+> pretty clBody+ reportS "reify.clause" 60 $ "variables occurring on RHS:" <+> pretty rhsVars <+> "variable names:" <+> pretty rhsVarNames <+> parens (maybe "no clause body" (const "there was a clause body") clBody)- reportSDoc "reify.clause" 60 $ return $ "names occurring on RHS" <+> pretty (Set.toList rhsUsedNames)+ reportS "reify.clause" 60 $ "names occurring on RHS" <+> pretty (Set.toList rhsUsedNames) let ell = clauseEllipsis cl ps <- reifyPatterns $ namedClausePats cl@@ -1419,7 +1510,7 @@ nfv <- getDefModule f >>= \case Left _ -> return 0 Right m -> size <$> lookupSection m- return $ splitParams nfv lhs+ return $! splitParams nfv lhs lhs <- stripImps rhsUsedNames params lhs let rhs = caseMaybe rhsBody AbsurdRHS $ \ e -> RHS e Nothing result = A.Clause (spineToLhs lhs) [] rhs A.noWhereDecls (I.clauseCatchall cl)@@ -1436,13 +1527,13 @@ type ReifiesTo (QNamed System) = [A.Clause] reify (QNamed f (System tel sys)) = addContext tel $ do- reportS "reify.system" 40 $ show tel : map show sys+ reportS "reify.system" 40 $ show tel : map' show sys view <- intervalView' unview <- intervalUnview' sys <- flip filterM sys $ \ (phi,t) -> do forallM phi $ \ (u,b) -> do u <- reduce u- return $ case (view u, b) of+ return $! case (view u, b) of (IZero, True) -> False (IOne, False) -> False _ -> True@@ -1454,11 +1545,11 @@ d True = unview IOne d False = unview IZero reify (phi, d b)- pure $ ps ++ [defaultNamedArg ep]+ pure $ ps ++! [defaultNamedArg ep] lhs <- SpineLHS empty f <$> stripImplicits mempty [] ps rhs <- reify u <&> (`RHS` Nothing)- return $ A.Clause (spineToLhs lhs) [] rhs A.noWhereDecls empty+ return $! A.Clause (spineToLhs lhs) [] rhs A.noWhereDecls empty {-# SPECIALIZE reify :: QNamed System -> TCM (ReifiesTo (QNamed System)) #-} instance Reify I.Type where@@ -1474,44 +1565,44 @@ reify s = do s <- instantiateFull s- SortKit{..} <- infallibleSortKit+ SortKit{ nameOfUniv } <- infallibleSortKit case s of- I.Univ u (I.ClosedLevel 0) -> return $ A.Def' (nameOfUniv USmall u) A.NoSuffix- I.Univ u (I.ClosedLevel n) -> return $ A.Def' (nameOfUniv USmall u) (A.Suffix n)+ I.Univ u (I.ClosedLevel 0) -> return $! A.Def' (nameOfUniv USmall u) A.NoSuffix+ I.Univ u (I.ClosedLevel n) -> return $! A.Def' (nameOfUniv USmall u) (A.Suffix n) I.Univ u a -> do a <- reify a- return $ A.App defaultAppInfo_ (A.Def $ nameOfUniv USmall u) (defaultNamedArg a)- I.Inf u 0 -> return $ A.Def' (nameOfUniv ULarge u) A.NoSuffix- I.Inf u n -> return $ A.Def' (nameOfUniv ULarge u) (A.Suffix n)+ return $! A.App defaultAppInfo_ (A.Def $ nameOfUniv USmall u) (defaultNamedArg a)+ I.Inf u 0 -> return $! A.Def' (nameOfUniv ULarge u) A.NoSuffix+ I.Inf u n -> return $! A.Def' (nameOfUniv ULarge u) (A.Suffix n) I.SizeUniv -> do sizeU <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSizeUniv- return $ A.Def sizeU+ return $! A.Def sizeU I.LockUniv -> do lockU <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinLockUniv- return $ A.Def lockU+ return $! A.Def lockU I.LevelUniv -> do levelU <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinLevelUniv- return $ A.Def levelU+ return $! A.Def levelU I.IntervalUniv -> do intervalU <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinIntervalUniv- return $ A.Def intervalU- I.PiSort a s1 s2 -> do+ return $! A.Def intervalU+ I.PiSort c a s1 s2 -> do pis <- freshName_ ("piSort" :: String) -- TODO: hack (e1,e2) <- reify (s1, I.Lam defaultArgInfo $ fmap Sort s2) let app x y = A.App defaultAppInfo_ x (defaultNamedArg y)- return $ A.Var pis `app` e1 `app` e2+ return $! A.Var pis `app` e1 `app` e2 I.FunSort s1 s2 -> do funs <- freshName_ ("funSort" :: String) -- TODO: hack (e1,e2) <- reify (s1 , s2) let app x y = A.App defaultAppInfo_ x (defaultNamedArg y)- return $ A.Var funs `app` e1 `app` e2+ return $! A.Var funs `app` e1 `app` e2 I.UnivSort s -> do univs <- freshName_ ("univSort" :: String) -- TODO: hack e <- reify s- return $ A.App defaultAppInfo_ (A.Var univs) $ defaultNamedArg e+ return $! A.App defaultAppInfo_ (A.Var univs) $ defaultNamedArg e I.MetaS x es -> reify $ I.MetaV x es I.DefS d es -> reify $ I.Def d es- I.DummyS s -> return $ A.Lit empty $ LitString $ T.pack s+ I.DummyS s -> return $! A.Lit empty $ LitString $ T.pack s {-# SPECIALIZE reify :: Sort -> TCM (ReifiesTo Sort) #-} instance Reify Level where@@ -1523,7 +1614,7 @@ -- While type checking the level builtins, they are not -- available for debug printing. Thus, print some garbage instead. name <- freshName_ (".#Lacking_Level_Builtins#" :: String)- return $ A.Var name+ return $! A.Var name {-# SPECIALIZE reify :: Level -> TCM (ReifiesTo Level) #-} instance (Free i, Reify i) => Reify (Abs i) where@@ -1534,7 +1625,7 @@ -- If the bound variable is free in the body, then the name "_" is -- replaced by "z".- s <- return $ if isUnderscore s && 0 `freeIn` v then "z" else s+ s <- return $! if isUnderscore s && 0 `freeIn` v then "z" else s x <- C.setNotInScope <$> freshName_ s e <- addContext x -- type doesn't matter@@ -1553,16 +1644,20 @@ name = domName arg tac <- TacticAttribute <$> do traverse (Ranged noRange <.> reify) $ domTactic arg let xs = singleton $ Arg info $ Named name $ A.mkBinder_ x- return $ TBind r (TypedBindingInfo tac (domIsFinite arg)) xs e : bs+ return $! TBind r (TypedBindingInfo tac (domIsFinite arg)) xs e : bs {-# SPECIALIZE reify :: I.Telescope -> TCM (ReifiesTo I.Telescope) #-} instance Reify i => Reify (Dom i) where type ReifiesTo (Dom i) = Arg (ReifiesTo i) - reify (Dom{domInfo = info, unDom = i}) = Arg info <$> reify i+ reify d = Arg (d ^. dInfo) <$> reify (unDom d) {-# INLINE reify #-} +instance Reify Context where+ type ReifiesTo Context = [A.TypedBinding] + reify = reify . contextToTel+ instance Reify ContextEntry where type ReifiesTo ContextEntry = A.TypedBinding @@ -1572,7 +1667,7 @@ name = domName a xs = singleton $ Arg info $ Named name $ A.mkBinder_ y tac <- TacticAttribute <$> do traverse (Ranged noRange <.> reify) $ domTactic a- return $ TBind r (TypedBindingInfo tac (domIsFinite a)) xs t+ return $! TBind r (TypedBindingInfo tac (domIsFinite a)) xs t instance Reify i => Reify (I.Elim' i) where type ReifiesTo (I.Elim' i) = I.Elim' (ReifiesTo i)
src/full/Agda/Syntax/Translation/ReflectedToAbstract.hs view
@@ -2,16 +2,15 @@ module Agda.Syntax.Translation.ReflectedToAbstract where -import Control.Arrow ( (***) ) import Control.Monad ( foldM ) import Control.Monad.Except ( MonadError ) import Control.Monad.Reader ( MonadReader(..), asks, reader, runReaderT ) import Data.Maybe import Data.Set (Set)-import qualified Data.Set as Set+import Data.Set qualified as Set import Data.Text (Text)-import qualified Data.Text as Text+import Data.Text qualified as Text import Agda.Syntax.Literal import Agda.Syntax.Position@@ -21,11 +20,10 @@ ( Name, QName, QNamed(QNamed) , isNoName, nameConcrete, nextName, qualify, unambiguous )-import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Abstract qualified as A import Agda.Syntax.Abstract.Pattern import Agda.Syntax.Reflected as R-import Agda.Syntax.Internal (Dom,Dom'(..))-+import Agda.Syntax.Internal (Dom,Dom'(..), pattern Dom, dIsFinite, dInfo) import Agda.Interaction.Options (optUseUnicode, UnicodeOrAscii(..)) import Agda.TypeChecking.Monad as M hiding (MetaInfo) import Agda.Syntax.Scope.Monad (getCurrentModule)@@ -35,12 +33,13 @@ import Agda.Utils.Monad import Agda.Utils.List import Agda.Utils.List1 (List1, pattern (:|))-import qualified Agda.Utils.List1 as List1+import Agda.Utils.List1 qualified as List1 import Agda.Utils.Null import Agda.Syntax.Common.Pretty import Agda.Utils.Functor import Agda.Utils.Singleton import Agda.Utils.Size+import Agda.Utils.Tuple ( (***) ) type Vars = [(Name,R.Type)] @@ -75,7 +74,7 @@ notTaken xs x = isNoName x || nameConcrete x `notElem` xs withNames :: MonadReflectedToAbstract m => [String] -> ([Name] -> m a) -> m a-withNames ss = withVars $ zip ss $ repeat R.Unknown+withNames = withVars . map (,R.Unknown) withVars :: MonadReflectedToAbstract m => [(String, R.Type)] -> ([Name] -> m a) -> m a withVars ss f = case ss of@@ -103,9 +102,7 @@ (ToAbstract r , MonadFresh NameId m , MonadError TCErr m- , MonadTCEnv m , ReadTCState m- , HasOptions m , HasBuiltins m , HasConstInfo m ) => r -> m (AbsOfRef r)@@ -116,15 +113,13 @@ (ToAbstract r , MonadFresh NameId m , MonadError TCErr m- , MonadTCEnv m , ReadTCState m- , HasOptions m , HasBuiltins m , HasConstInfo m ) => r -> m (AbsOfRef r) toAbstractWithoutImplicit x = do xs <- killRange <$> getContextNames'- let ctx = zip xs $ repeat R.Unknown+ let ctx = map (,R.Unknown) xs runReaderT (toAbstract x) ctx instance ToAbstract r => ToAbstract (Named name r) where@@ -140,13 +135,13 @@ -- 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, domIsFinite = isfin, unDom = x, domTactic = tac}, name) = do- dom <- toAbstract x+ toAbstract (d, name) = do+ dom <- toAbstract (unDom d) -- TODO(Amy): Anyone know why this discards the tactic? It was like -- that when I got here! return $ A.TBind noRange- (A.TypedBindingInfo empty isfin)- (singleton $ unnamedArg i $ A.mkBinder_ name)+ (A.TypedBindingInfo empty (d ^. dIsFinite))+ (singleton $ unnamedArg (d ^. dInfo) $ A.mkBinder_ name) dom instance ToAbstract (A.Expr, Elim) where@@ -298,12 +293,8 @@ checkClauseTelescopeBindings :: MonadReflectedToAbstract m => [(Text, Arg R.Type)] -> [Arg R.Pattern] -> m () checkClauseTelescopeBindings tel pats = case reverse [ x | ((x, _), i) <- zip (reverse tel) [0..], not $ Set.member i bs ] of- [] -> return ()- xs -> genericDocError $ vcat- [ fsep (pwords "Missing bindings for telescope" ++ [ pluralS xs "variable" ])- <?> (fsep (punctuate ", " $ map (text . Text.unpack) xs) <> ".")- , "All variables in the clause telescope must be bound in the left-hand side."- ]+ [] -> return ()+ x:xs -> typeError $ MissingBindingsForTelescopeVariables (x :| xs) where bs = boundVars pats
src/full/Agda/Syntax/Treeless.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-} {-# LANGUAGE PatternSynonyms #-} @@ -13,7 +14,6 @@ , module Agda.Syntax.Treeless ) where -import Control.Arrow (first, second) import Control.DeepSeq import Data.Word@@ -21,10 +21,13 @@ import GHC.Generics (Generic) import Agda.Syntax.Position+import Agda.Syntax.Internal (TermSize(..)) import Agda.Syntax.Literal import Agda.Syntax.Common import Agda.Syntax.Abstract.Name +import Agda.Utils.Tuple (first, second)+ data Compiled = Compiled { cTreeless :: TTerm , cArgUsage :: Maybe [ArgUsage]@@ -38,12 +41,38 @@ | ArgUnused deriving (Show, Eq, Ord, Generic) +-- | Strictness.+data Strictness+ = NonStrict+ | Strict+ deriving (Show, Eq, Ord, Generic)+ -- | The treeless compiler can behave differently depending on the target -- language evaluation strategy. For instance, more aggressive erasure for -- lazy targets.-data EvaluationStrategy = LazyEvaluation | EagerEvaluation- deriving (Eq, Show)+data EvaluationStrategy+ = LazyEvaluation !Strictness+ -- ^ Lazy evaluation. If the argument is 'Strict', then+ -- applications of inductive (or non-recursive) constructors are+ -- strict.+ | EagerEvaluation+ -- ^ Strict evaluation.+ deriving (Show, Eq, Ord, Generic) +-- | The default strictness.++defaultStrictness :: EvaluationStrategy -> Strictness+defaultStrictness EagerEvaluation = Strict+defaultStrictness (LazyEvaluation _) = NonStrict++-- | The default strictness for constructors of the given kind.++defaultConstructorStrictness ::+ EvaluationStrategy -> Induction -> Strictness+defaultConstructorStrictness _ CoInductive = NonStrict+defaultConstructorStrictness EagerEvaluation Inductive = Strict+defaultConstructorStrictness (LazyEvaluation s) Inductive = s+ type Args = [TTerm] -- this currently assumes that TApp is translated in a lazy/cbn fashion.@@ -57,11 +86,12 @@ | TLam TTerm | TLit Literal | TCon QName- | TLet TTerm TTerm- -- ^ introduces a new (non-recursive) local binding. The bound term- -- MUST only be evaluated if it is used inside the body.- -- Sharing may happen, but is optional.- -- It is also perfectly valid to just inline the bound term in the body.+ | TLet Strictness TTerm TTerm+ -- ^ Introduces a new (non-recursive) local binding. It can+ -- be strict or non-strict. Non-strict bindings should not+ -- be made more strict, this could lead to crashes. Sharing+ -- may happen, but is optional. It is also perfectly valid+ -- to just inline the bound term in the body. | TCase Int CaseInfo TTerm [TAlt] -- ^ Case scrutinee (always variable), case type, default value, alternatives -- First, all TACon alternatives are tried; then all TAGuard alternatives@@ -135,9 +165,9 @@ TApp a bs -> second (++ bs) $ coerceAppView a t -> ((False, t), []) -tLetView :: TTerm -> ([TTerm], TTerm)-tLetView (TLet e b) = first (e :) $ tLetView b-tLetView e = ([], e)+tLetView :: TTerm -> ([(Strictness, TTerm)], TTerm)+tLetView (TLet s e b) = first ((s, e) :) $ tLetView b+tLetView e = ([], e) tLamView :: TTerm -> (Int, TTerm) tLamView = go 0@@ -148,8 +178,8 @@ mkTLam n b = foldr ($) b $ replicate n TLam -- | Introduces a new binding-mkLet :: TTerm -> TTerm -> TTerm-mkLet x body = TLet x body+mkLet :: Strictness -> TTerm -> TTerm -> TTerm+mkLet = TLet tInt :: Integer -> TTerm tInt = TLit . LitNat@@ -208,6 +238,9 @@ data CaseInfo = CaseInfo { caseLazy :: Bool+ , caseInduction :: !Induction+ -- ^ Is the matched type inductive (or non-recursive), or is it+ -- coinductive? , caseErased :: Erased -- ^ Is this a match on an erased argument? , caseType :: CaseType }@@ -248,7 +281,7 @@ instance Unreachable TTerm where isUnreachable (TError TUnreachable{}) = True- isUnreachable (TLet _ b) = isUnreachable b+ isUnreachable (TLet _ _ b) = isUnreachable b isUnreachable _ = False instance KillRange Compiled where@@ -279,13 +312,41 @@ ([], args) -> args (_ , []) -> [] (ArgUsed : used, a : args) -> a : filterUsed used args- (ArgUnused : used, a : args) -> filterUsed used args+ (ArgUnused : used, _ : args) -> filterUsed used args +-- TermSize instances+------------------------------------------------------------------------++instance TermSize TTerm where+ tsize = \case+ TVar _ -> 1+ TPrim _ -> 1+ TDef _ -> 1+ TLit _ -> 1+ TCon _ -> 1+ TUnit -> 1+ TSort -> 1+ TErased -> 1+ TError _ -> 1+ TApp t ts -> tsize t + tsize ts+ TLam t -> 1 + tsize t+ TLet _ t1 t2 -> 1 + tsize t1 + tsize t2+ TCase _ _ t bs -> 1 + tsize t + tsize bs+ TCoerce t -> 1 + tsize t++instance TermSize TAlt where+ tsize = \case+ TACon _ _ t -> tsize t+ TAGuard t1 t2 -> tsize t1 + tsize t2+ TALit _ t -> tsize t+ -- NFData instances --------------------------------------------------------------------------- instance NFData Compiled instance NFData ArgUsage+instance NFData Strictness+instance NFData EvaluationStrategy instance NFData TTerm instance NFData TPrim instance NFData CaseType
src/full/Agda/Termination/CallGraph.hs view
@@ -11,38 +11,44 @@ module Agda.Termination.CallGraph ( -- * Calls Node- , Call, mkCall, mkCall', source, target, callMatrixSet+ , Call, source, target, callMatrixSet+ , mkCall, mkCall' -- exported for the sake of testing, otherwise we use 'insert' , (>*<) -- * Call graphs , CallGraph(..)+ , loops , targetNodes , fromList , toList , union , insert , complete, completionStep+ -- , strengthenLoopDiagonals -- bad heuristics, see https://github.com/agda/agda/pull/8184#issuecomment-3487147737 -- , prettyBehaviour ) where import Prelude hiding (null) -import qualified Data.List as List+import Data.List qualified as List import Data.Set (Set) -import Agda.Termination.CallMatrix (CallMatrix, CallMatrixAug(..), CMSet(..), CallComb(..))-import qualified Agda.Termination.CallMatrix as CMSet+import Agda.Syntax.Common.Pretty++import Agda.Termination.CallMatrix (CallMatrix, CallMatrixAug(..), CMSet(..), CallComb(..)) -- , mapCMSet, mapCallMatrixAug, mapCallMatrix)+import Agda.Termination.CallMatrix qualified as CMSet import Agda.Termination.CutOff+-- import Agda.Termination.Order ( makeIncreaseInfinite )+-- import Agda.Termination.SparseMatrix ( mapDiagonalNonZeros ) import Agda.Utils.Favorites (Favorites)-import qualified Agda.Utils.Favorites as Fav+import Agda.Utils.Favorites qualified as Fav import Agda.Utils.Graph.AdjacencyMap.Unidirectional (Edge(..),Graph(..))-import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as Graph+import Agda.Utils.Graph.AdjacencyMap.Unidirectional qualified as Graph import Agda.Utils.Function import Agda.Utils.Null import Agda.Utils.PartialOrd-import Agda.Syntax.Common.Pretty import Agda.Utils.Singleton import Agda.Utils.Tuple @@ -69,6 +75,7 @@ mkCall :: Node -> Node -> CallMatrix -> cinfo -> Call cinfo mkCall s t m cinfo = Edge s t $ singleton $ CallMatrixAug m cinfo +-- @mkCall'@ is only used in our Internal tests. -- | Make a call with empty @cinfo@. mkCall' :: Monoid cinfo => Node -> Node -> CallMatrix -> Call cinfo mkCall' s t m = mkCall s t m mempty@@ -84,7 +91,14 @@ newtype CallGraph cinfo = CallGraph { theCallGraph :: Graph Node (CMSet cinfo) } deriving (Show) +mapCallGraph :: (Graph Node (CMSet cinfo) -> Graph Node (CMSet cinfo)) -> CallGraph cinfo -> CallGraph cinfo+mapCallGraph f (CallGraph g) = CallGraph (f g) +-- | Returns all nodes with self-loops.++loops :: CallGraph cinfo -> [(Node, CMSet cinfo)]+loops = Graph.loops . theCallGraph+ -- | Returns all the nodes with incoming edges. Somewhat expensive. @O(e)@. targetNodes :: CallGraph cinfo -> Set Node@@ -156,8 +170,8 @@ new' = (,mempty) <$> new old' = (mempty,) <$> old comb (new1,old1) (new2,old2) -- TODO: ensure old1 is null- = mapFst (new2 `mappend`) $ combineNewOld new1 old2- -- -- | old1 == mempty = mapFst (new2 `mappend`) $ combineNewOld new1 old2+ = first (new2 `mappend`) $ combineNewOld new1 old2+ -- -- | old1 == mempty = first (new2 `mappend`) $ combineNewOld new1 old2 -- -- | otherwise = __IMPOSSIBLE__ -- Filter unlabelled edges from the resulting new graph.@@ -170,18 +184,37 @@ -- GHC supports implicit-parameter constraints in instance declarations -- only from 7.4. To maintain compatibility with 7.2, we skip this instance:+-- Andreas, 2025-10-29, not allowed in GHC 9.12:+-- https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/implicit_parameters.html#implicit-parameter-type-constraints -- KEEP: -- instance (Monoid cinfo, ?cutoff :: CutOff) => CombineNewOld (CallGraph cinfo) where--- combineNewOld (CallGraph new) (CallGraph old) = CallGraph -*- CallGraph $ combineNewOld comb old+-- combineNewOld (CallGraph new) (CallGraph old) = CallGraph *** CallGraph $ combineNewOld comb old -- -- combined calls: -- where comb = Graph.composeWith (>*<) CMSet.union new old -- Non-overloaded version:-combineNewOldCallGraph :: (Monoid cinfo, ?cutoff :: CutOff) => CombineNewOldT (CallGraph cinfo)-combineNewOldCallGraph (CallGraph new) (CallGraph old) = CallGraph -*- CallGraph $ combineNewOld comb old+combineNewOldCallGraph :: forall cinfo. (Monoid cinfo, ?cutoff :: CutOff) => CombineNewOldT (CallGraph cinfo)+combineNewOldCallGraph (CallGraph new) (CallGraph old) = CallGraph *** CallGraph $ combineNewOld comb old -- combined calls:- where comb = Graph.composeWith (>*<) CMSet.union new old+ where+ comb :: Graph Node (CMSet cinfo)+ comb = -- strengthenLoopDiagonals' $ -- bad heuristics, see https://github.com/agda/agda/pull/8184#issuecomment-3487147737+ Graph.composeWith (>*<) CMSet.union new old +-- Andreas, 2025-11-04+-- bad heuristics, see https://github.com/agda/agda/pull/8184#issuecomment-3487147737+-- -- | Any increase in the diagonal of a loop can be strengthened to infinite increase+-- -- since we can iterate loops indefinitely.+-- strengthenLoopDiagonals' :: Graph Node (CMSet cinfo) -> Graph Node (CMSet cinfo)+-- strengthenLoopDiagonals' =+-- Graph.mapLoops $ mapCMSet $ fmap $ mapCallMatrixAug $ mapCallMatrix $+-- mapDiagonalNonZeros makeIncreaseInfinite++-- -- | Any increase in the diagonal of a loop can be strengthened to infinite increase+-- -- since we can iterate loops indefinitely.+-- strengthenLoopDiagonals :: CallGraph cinfo -> CallGraph cinfo+-- strengthenLoopDiagonals = mapCallGraph $ strengthenLoopDiagonals'+ -- | Call graph comparison. -- A graph @cs'@ is ``worse'' than @cs@ if it has a new edge (call) -- or a call got worse, which means that one of its elements@@ -196,11 +229,15 @@ -- complete if it contains all indirect calls; if @f -> g@ and @g -> -- h@ are present in the graph, then @f -> h@ should also be present. -complete :: (?cutoff :: CutOff) => Monoid cinfo => CallGraph cinfo -> CallGraph cinfo-complete cs = repeatWhile (mapFst (not . null) . completionStep cs) cs+complete :: (Monoid cinfo, ?cutoff :: CutOff) => CallGraph cinfo -> CallGraph cinfo+complete cs = repeatWhile (first (not . null) . completionStep cs) cs -completionStep :: (?cutoff :: CutOff) => Monoid cinfo =>- CallGraph cinfo -> CallGraph cinfo -> (CallGraph cinfo, CallGraph cinfo)+completionStep :: (Monoid cinfo, ?cutoff :: CutOff)+ => CallGraph cinfo+ -- ^ The original call graph.+ -> CallGraph cinfo+ -- ^ The current completion.+ -> (CallGraph cinfo, CallGraph cinfo) completionStep gOrig gThis = combineNewOldCallGraph gOrig gThis ------------------------------------------------------------------------
src/full/Agda/Termination/CallMatrix.hs view
@@ -100,6 +100,8 @@ instance HasZero a => Diagonal (CallMatrix' a) a where diagonal = diagonal . mat +mapCallMatrix :: (Matrix ArgumentIndex a -> Matrix ArgumentIndex a) -> CallMatrix' a -> CallMatrix' a+mapCallMatrix f (CallMatrix m) = CallMatrix (f m) -- | Call matrix multiplication and call combination. @@ -163,6 +165,9 @@ noAug :: Monoid cinfo => CallMatrix -> CallMatrixAug cinfo noAug m = CallMatrixAug m mempty +mapCallMatrixAug :: (CallMatrix -> CallMatrix) -> CallMatrixAug cinfo -> CallMatrixAug cinfo+mapCallMatrixAug f (CallMatrixAug m i) = CallMatrixAug (f m) i+ ------------------------------------------------------------------------ -- * Sets of incomparable call matrices augmented with path information. ------------------------------------------------------------------------@@ -171,6 +176,10 @@ -- Use overloaded 'null', 'empty', 'singleton', 'mappend'. newtype CMSet cinfo = CMSet { cmSet :: Favorites (CallMatrixAug cinfo) } deriving ( Show, Semigroup, Monoid, Null, Singleton (CallMatrixAug cinfo) )++mapCMSet :: (Favorites (CallMatrixAug cinfo) -> Favorites (CallMatrixAug cinfo))+ -> CMSet cinfo -> CMSet cinfo+mapCMSet f (CMSet s) = CMSet (f s) -- | Call matrix set product is the Cartesian product.
src/full/Agda/Termination/CutOff.hs view
@@ -12,13 +12,31 @@ import Control.DeepSeq +import Agda.Utils.Impossible (__IMPOSSIBLE__)+ -- | Cut off structural order comparison at some depth in termination checker? data CutOff = CutOff !Int -- ^ @c >= 0@ means: record decrease up to including @c+1@. | DontCutOff- deriving (Eq , Ord)+ deriving (Eq, Ord) +-- | Numeric literals and addition for 'CutOff'.++instance Num CutOff where+ fromInteger n+ | n >= 0 = CutOff (fromInteger n)+ | otherwise = __IMPOSSIBLE__++ DontCutOff + _ = DontCutOff+ _ + DontCutOff = DontCutOff+ CutOff m + CutOff n = CutOff (m + n)++ _ * _ = __IMPOSSIBLE__+ abs _ = __IMPOSSIBLE__+ signum _ = __IMPOSSIBLE__+ negate _ = __IMPOSSIBLE__+ instance Show CutOff where show (CutOff k) = show k show DontCutOff = "∞"@@ -30,4 +48,4 @@ -- | The default termination depth. defaultCutOff :: CutOff-defaultCutOff = CutOff 0 -- minimum value+defaultCutOff = CutOff 2 -- termination-depth=3
src/full/Agda/Termination/Monad.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-} -- | The monad for the termination checker. --@@ -7,30 +8,34 @@ module Agda.Termination.Monad where -import Prelude hiding (null)--import Control.Applicative hiding (empty)+import Prelude hiding (null, zip, zipWith) import Control.Monad.IO.Class ( MonadIO(..) ) import Control.Monad.Except ( MonadError(..) )-import Control.Monad.Reader ( MonadReader(..), ReaderT(..) ) -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 Data.IntMap.Strict ( IntMap )+import Data.IntMap.Strict qualified as IntMap+import Data.Map.Strict ( Map )+import Data.Map.Strict qualified as Map+import Data.Set ( Set )+import Data.Set qualified as Set -import Agda.Interaction.Options (optTerminationDepth)+import Agda.Interaction.Options ( optTerminationDepth ) import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty ( Pretty, prettyShow )+import Agda.Syntax.Common.Pretty qualified as P import Agda.Syntax.Internal-import Agda.Syntax.Internal.Pattern-import Agda.Syntax.Literal+import Agda.Syntax.Internal.Pattern ( PatternLike(foldrPattern) )+import Agda.Syntax.Literal ( Literal(LitString) ) -import Agda.Termination.CutOff-import Agda.Termination.Order (Order,le,unknown)-import Agda.Termination.RecCheck (MutualNames, anyDefs)+import Agda.Termination.CallMatrix ( CallMatrix, CallMatrix'(CallMatrix), CallMatrixAug(CallMatrixAug), CMSet )+import Agda.Termination.CallMatrix qualified as CallMatrix+import Agda.Termination.CallGraph ( CallGraph, callMatrixSet )+import Agda.Termination.CallGraph qualified as CallGraph+import Agda.Termination.CutOff ( CutOff, defaultCutOff )+import Agda.Termination.Order ( Order, le, unknown )+import Agda.Termination.RecCheck ( MutualNames, anyDefs ) import Agda.TypeChecking.Monad import Agda.TypeChecking.Monad.Benchmark@@ -40,18 +45,22 @@ import Agda.TypeChecking.Substitute import Agda.Utils.Benchmark as B+import Agda.Utils.BinTree ( BinTree )+import Agda.Utils.BinTree qualified as BinTree import Agda.Utils.Function import Agda.Utils.Functor-import Agda.Utils.Lens-import Agda.Utils.List ( hasElem )+import Agda.Utils.List+import Agda.Utils.ListInf ( ListInf )+import Agda.Utils.ListInf qualified as ListInf import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Monoid import Agda.Utils.Null-import Agda.Syntax.Common.Pretty (Pretty, prettyShow)-import qualified Agda.Syntax.Common.Pretty as P-import Agda.Utils.VarSet (VarSet)-import qualified Agda.Utils.VarSet as VarSet+import Agda.Utils.Singleton+import Agda.Utils.VarSet ( VarSet )+import Agda.Utils.VarSet qualified as VarSet+import Agda.Utils.Zip () -- for zip, zipWith instance+import Agda.Utils.StrictReader import Agda.Utils.Impossible @@ -76,13 +85,11 @@ -- First part: options, configuration. - { terUseDotPatterns :: Bool- -- ^ Are we mining dot patterns to find evindence of structal descent?- , terSizeSuc :: Maybe QName+ { terSizeSuc :: !(Maybe QName) -- ^ The name of size successor, if any.- , terSharp :: Maybe QName+ , terSharp :: !(Maybe QName) -- ^ The name of the delay constructor (sharp), if any.- , terCutOff :: CutOff+ , terCutOff :: !CutOff -- ^ Depth at which to cut off the structural order. -- Second part: accumulated info during descent into decls./term.@@ -96,16 +103,16 @@ , terUserNames :: Set QName -- ^ The list of name actually appearing in the file (abstract syntax). -- Excludes the internally generated functions.- , terHaveInlinedWith :: Bool+ , terHaveInlinedWith :: !Bool -- ^ Does the actual clause result from with-inlining? -- (If yes, it may be ill-typed.)- , terTarget :: Target+ , terTarget :: !Target -- ^ Target type of the function we are currently termination checking. -- Only the constructors of 'Target' are considered guarding.- , terMaskArgs :: [Bool]+ , terMaskArgs :: !(ListInf Bool) -- ^ Only consider the 'notMasked' 'False' arguments for establishing termination. -- See issue #1023.- , terMaskResult :: Bool+ , terMaskResult :: !Bool -- ^ Only consider guardedness if 'False' (not masked). , _terSizeDepth :: Int -- lazy by intention! -- ^ How many @SIZELT@ relations do we have in the context@@ -120,14 +127,23 @@ , terGuarded :: !Guarded -- ^ The current guardedness status. Changes as we go deeper into the term. -- Updated during call graph extraction, hence strict.- , terUseSizeLt :: Bool+ , terUseSizeLt :: !Bool -- ^ When extracting usable size variables during construction of the call -- matrix, can we take the variable for use with SIZELT constraints from the context? -- Yes, if we are under an inductive constructor. -- No, if we are under a record constructor. -- (See issue #1015).- , terUsableVars :: VarSet+ , terUsableVars :: !VarSet -- ^ Pattern variables that can be compared to argument variables using SIZELT.+ , terProjectedNameToNode :: !(Map (QName, [QName]) CallGraph.Node)+ -- ^ Map from (name, [projection]) to call-graph node.+ -- (See issue #8596 for why projected names merit distinct nodes).+ , terNodeToName :: !(IntMap QName)+ -- ^ Map from call-graph node back to function names.+ , terNameToProjections :: !(Map QName [[QName]])+ -- ^ Map from function names to the list of all available projection paths.+ , terProjectedNameToMaskArgs :: !(Map (QName, [QName]) (ListInf Bool))+ -- ^ Precomputed argument mask per @(name, [projection])@ pair, if @--without-K@. } -- | An empty termination environment.@@ -142,8 +158,7 @@ defaultTerEnv :: TerEnv defaultTerEnv = TerEnv- { terUseDotPatterns = False -- must be False initially!- , terSizeSuc = Nothing+ { terSizeSuc = Nothing , terSharp = Nothing , terCutOff = defaultCutOff , terUserNames = __IMPOSSIBLE__ -- needs to be set!@@ -151,14 +166,18 @@ , terCurrent = __IMPOSSIBLE__ -- needs to be set! , terHaveInlinedWith = False , terTarget = TargetOther- , terMaskArgs = repeat False -- use all arguments (mask none)+ , terMaskArgs = ListInf.repeat False -- use all arguments (mask none) , terMaskResult = False -- use result (do not mask) , _terSizeDepth = __IMPOSSIBLE__ -- needs to be set! , terPatterns = __IMPOSSIBLE__ -- needs to be set! , terPatternsRaise = 0 , terGuarded = le -- not initially guarded , terUseSizeLt = False -- initially, not under data constructor- , terUsableVars = VarSet.empty+ , terUsableVars = empty+ , terProjectedNameToNode = Map.empty+ , terNodeToName = IntMap.empty+ , terNameToProjections = Map.empty+ , terProjectedNameToMaskArgs = Map.empty } -- | Termination monad service class.@@ -181,6 +200,7 @@ , HasOptions , HasBuiltins , MonadDebug+ , MonadFileId , HasConstInfo , MonadIO , MonadTCEnv@@ -243,19 +263,13 @@ instance Semigroup m => Semigroup (TerM m) where (<>) = liftA2 (<>) -instance (Semigroup m, Monoid m) => Monoid (TerM m) where+instance (Monoid m) => Monoid (TerM m) where mempty = pure mempty mappend = (<>) mconcat = mconcat <.> sequence -- * Modifiers and accessors for the termination environment in the monad. -terGetUseDotPatterns :: TerM Bool-terGetUseDotPatterns = terAsks terUseDotPatterns--terSetUseDotPatterns :: Bool -> TerM a -> TerM a-terSetUseDotPatterns b = terLocal $ \ e -> e { terUseDotPatterns = b }- terGetSizeSuc :: TerM (Maybe QName) terGetSizeSuc = terAsks terSizeSuc @@ -289,10 +303,10 @@ terSetHaveInlinedWith :: TerM a -> TerM a terSetHaveInlinedWith = terLocal $ \ e -> e { terHaveInlinedWith = True } -terGetMaskArgs :: TerM [Bool]+terGetMaskArgs :: TerM (ListInf Bool) terGetMaskArgs = terAsks terMaskArgs -terSetMaskArgs :: [Bool] -> TerM a -> TerM a+terSetMaskArgs :: ListInf Bool -> TerM a -> TerM a terSetMaskArgs b = terLocal $ \ e -> e { terMaskArgs = b } terGetMaskResult :: TerM Bool@@ -305,7 +319,7 @@ terGetPatterns = do n <- terAsks terPatternsRaise mps <- terAsks terPatterns- return $ if n == 0 then mps else map (fmap (raise n)) mps+ return $ if n == 0 then mps else map' (fmap (raise n)) mps terSetPatterns :: MaskedDeBruijnPatterns -> TerM a -> TerM a terSetPatterns ps = terLocal $ \ e -> e { terPatterns = ps }@@ -341,6 +355,30 @@ terSetUsableVars :: VarSet -> TerM a -> TerM a terSetUsableVars = terModifyUsableVars . const +terGetProjectedNameToNode :: TerM (Map (QName, [QName]) CallGraph.Node)+terGetProjectedNameToNode = terAsks terProjectedNameToNode++terSetProjectedNameToNode :: Map (QName, [QName]) CallGraph.Node -> TerM a -> TerM a+terSetProjectedNameToNode fwd = terLocal $ \ e -> e { terProjectedNameToNode = fwd }++terGetNodeToName :: TerM (IntMap QName)+terGetNodeToName = terAsks terNodeToName++terSetNodeToName :: IntMap QName -> TerM a -> TerM a+terSetNodeToName bwd = terLocal $ \ e -> e { terNodeToName = bwd }++terGetNameToProjections :: TerM (Map QName [[QName]])+terGetNameToProjections = terAsks terNameToProjections++terSetNameToProjections :: Map QName [[QName]] -> TerM a -> TerM a+terSetNameToProjections modes = terLocal $ \ e -> e { terNameToProjections = modes }++terGetProjectedNameToMaskArgs :: TerM (Map (QName, [QName]) (ListInf Bool))+terGetProjectedNameToMaskArgs = terAsks terProjectedNameToMaskArgs++terSetProjectedNameToMaskArgs :: Map (QName, [QName]) (ListInf Bool) -> TerM a -> TerM a+terSetProjectedNameToMaskArgs m = terLocal $ \ e -> e { terProjectedNameToMaskArgs = m }+ -- | Lens for 'terUseSizeLt'. terGetUseSizeLt :: TerM Bool@@ -356,10 +394,10 @@ withUsableVars :: UsableSizeVars a => a -> TerM b -> TerM b withUsableVars pats m = do vars <- usableSizeVars pats- reportSLn "term.size" 70 $ "usableSizeVars = " ++ show vars+ reportSLn "term.size" 70 $ "usableSizeVars = " ++! show vars reportSDoc "term.size" 20 $ if null vars then "no usuable size vars" else "the size variables amoung these variables are usable: " <+>- sep (map (prettyTCM . var) $ VarSet.toList vars)+ sep (map' (prettyTCM . var) $ VarSet.toAscList vars) terSetUsableVars vars $ m -- | Set 'terUseSizeLt' when going under constructor @c@.@@ -375,8 +413,8 @@ projUseSizeLt :: QName -> TerM a -> TerM a projUseSizeLt q m = do co <- isCoinductiveProjection False q- reportSLn "term.size" 20 $ applyUnless co ("not " ++) $- "using SIZELT vars after projection " ++ prettyShow q+ reportSLn "term.size" 20 $ applyUnless co ("not " ++!) $+ "using SIZELT vars after projection " ++! prettyShow q terSetUseSizeLt co m -- | For termination checking purposes flat should not be considered a@@ -404,6 +442,12 @@ -> isInductiveRecord (unArg t) _ -> return False +-- | Is the given elimination anything but a coinductive projection?+elimNotCoinductive :: MonadTCM tcm => Elim' t -> tcm Bool+elimNotCoinductive e = case isProjElim e of+ Nothing -> return True+ Just (_o, x) -> isProjectionButNotCoinductive x+ -- | Check whether a projection belongs to a coinductive record -- and is actually recursive. -- E.g.@@ -414,7 +458,7 @@ -- @ isCoinductiveProjection :: MonadTCM tcm => Bool -> QName -> tcm Bool isCoinductiveProjection mustBeRecursive q = liftTCM $ do- reportSLn "term.guardedness" 40 $ "checking isCoinductiveProjection " ++ prettyShow q+ reportSLn "term.guardedness" 40 $ "checking isCoinductiveProjection " ++! prettyShow q flat <- fmap nameOfFlat <$> coinductionKit -- yes for ♭ if Just q == flat then return True else do@@ -424,17 +468,17 @@ caseMaybeM (isRecord r) __IMPOSSIBLE__ $ \ rdef -> do -- no for inductive or non-recursive record if _recInduction rdef /= Just CoInductive then return False else do- reportSLn "term.guardedness" 40 $ prettyShow q ++ " is coinductive; record type is " ++ prettyShow r+ reportSLn "term.guardedness" 40 $ prettyShow q ++! " is coinductive; record type is " ++! prettyShow r if not mustBeRecursive then return True else do- reportSLn "term.guardedness" 40 $ prettyShow q ++ " must be recursive"+ reportSLn "term.guardedness" 40 $ prettyShow q ++! " must be recursive" if notSafeRecRecursive rdef then return False else do- reportSLn "term.guardedness" 40 $ prettyShow q ++ " has been declared recursive, doing actual check now..."+ reportSLn "term.guardedness" 40 $ prettyShow q ++! " has been declared recursive, doing actual check now..." -- TODO: the following test for recursiveness of a projection should be cached. -- E.g., it could be stored in the @Projection@ component. -- Now check if type of field mentions mutually recursive symbol. -- Get the type of the field by dropping record parameters and record argument. let TelV tel core = telView' (defType pdef)- (pars, tel') = splitAt n $ telToList tel+ (pars, tel') = splitAt' n $ telToList tel mut = fromMaybe __IMPOSSIBLE__ $ _recMutual rdef -- Check if any recursive symbols appear in the record type. -- Q (2014-07-01): Should we normalize the type?@@ -442,19 +486,19 @@ -- See issue #1899. reportSDoc "term.guardedness" 40 $ inTopContext $ sep [ "looking for recursive occurrences of"- , sep (map prettyTCM mut)+ , sep (map' prettyTCM mut) , "in" , addContext pars $ prettyTCM (telFromList tel') , "and" , addContext tel $ prettyTCM core ] when (null mut) __IMPOSSIBLE__- names <- anyDefs (mut `hasElem`) (map (snd . unDom) tel', core)+ names <- anyDefs (Set.fromList mut) (map' (snd . unDom) tel', core) reportSDoc "term.guardedness" 40 $- "found" <+> if null names then "none" else sep (map prettyTCM $ Set.toList names)+ "found" <+> if null names then "none" else sep (map' prettyTCM $ Set.toList names) return $ not $ null names _ -> do- reportSLn "term.guardedness" 40 $ prettyShow q ++ " is not a proper projection"+ reportSLn "term.guardedness" 40 $ prettyShow q ++! " is not a proper projection" return False where -- Andreas, 2018-02-24, issue #2975, example:@@ -477,6 +521,7 @@ -- @_recMutual@ should be something (@Just (_:_)@) to be safe -- * De Bruijn pattern stuff+--------------------------------------------------------------------------- -- | How long is the path to the deepest atomic pattern? patternDepth :: forall a. Pattern' a -> Int@@ -503,7 +548,7 @@ instance UsableSizeVars DeBruijnPattern where usableSizeVars = foldrPattern $ \case- VarP _ x -> const $ ifM terGetUseSizeLt (return $ VarSet.singleton $ dbPatVarIndex x) $+ VarP _ x -> const $ ifM terGetUseSizeLt (return $ singleton $ dbPatVarIndex x) $ {-else-} return mempty ConP c _ _ -> conUseSizeLt $ conName c LitP{} -> none@@ -522,7 +567,7 @@ instance UsableSizeVars (Masked DeBruijnPattern) where usableSizeVars (Masked m p) = (`foldrPattern` p) $ \case- VarP _ x -> const $ ifM terGetUseSizeLt (return $ VarSet.singleton $ dbPatVarIndex x) $+ VarP _ x -> const $ ifM terGetUseSizeLt (return $ singleton $ dbPatVarIndex x) $ {-else-} return mempty ConP c _ _ -> if m then none else conUseSizeLt $ conName c LitP{} -> none@@ -539,9 +584,12 @@ (Masked _ (ProjP _ q) : ps) -> projUseSizeLt q $ usableSizeVars ps (p : ps) -> mappend <$> usableSizeVars p <*> usableSizeVars ps --- * Masked patterns (which are not eligible for structural descent, only for size descent)--- See issue #1023.+-- * Masked patterns+--------------------------------------------------------------------------- +-- Masked patterns are not eligible for structural descent, only for size descent.+-- See issue #1023.+ type MaskedDeBruijnPatterns = [Masked DeBruijnPattern] data Masked a = Masked@@ -562,42 +610,43 @@ instance PrettyTCM a => PrettyTCM (Masked a) where prettyTCM (Masked m a) = applyWhen m (parens . parens) $ prettyTCM a --- * Call pathes+-- * Call paths+--------------------------------------------------------------------------- -- | 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'.--- Internally, due to lazyness, it is anyway a binary tree of--- 'mappend' nodes and singleton leafs.--- 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.+-- The call information is stored as free monoid over 'CallInfo',+-- giving us constant-time concatenation.+-- Once the information is complete, it can be converted to a non-empty list.+-- (This should only be done once, as this operation is linear-time.) -newtype CallPath = CallPath (DList CallInfo)- deriving (Show, Semigroup, Monoid)+data CallPath = CallPath+ { callPathStart :: QName+ , callPathSteps :: BinTree CallInfo+ }+ deriving (Show) -- | The calls making up the call path. callInfos :: CallPath -> [CallInfo]-callInfos (CallPath cs) = DL.toList cs+callInfos (CallPath _ cs) = BinTree.toList cs +instance Semigroup CallPath where+ CallPath start steps <> CallPath _ steps' = CallPath start (steps <> steps')++instance Monoid CallPath where+ mempty = CallPath empty mempty+ -- | Only show intermediate nodes. (Drop last 'CallInfo'). instance Pretty CallPath where- pretty cis0 = if null cis then empty else- P.hsep (map (\ ci -> arrow P.<+> P.pretty ci) cis) P.<+> arrow- where- cis = init (callInfos cis0)- arrow = "-->"+ pretty cis0 = case callInfos cis0 of+ [] -> empty+ ci1:cis1 -> case init1 ci1 cis1 of+ [] -> empty+ cis2 -> P.hsep (map' (("-->" P.<+>) . P.pretty) cis2) P.<+> "-->" -- * Size depth estimation+--------------------------------------------------------------------------- -- | A very crude way of estimating the @SIZELT@ chains -- @i > j > k@ in context. Returns 3 in this case.@@ -622,3 +671,35 @@ MetaV{} -> return 1 _ -> return 0 terLocal (set terSizeDepth n) cont++-- * PrettyTCM+---------------------------------------------------------------------------+--+-- This mostly duplicates the 'Pretty' instances,+-- but we use 'PrettyTCM' for the 'QName' in the 'CallPath'.++-- This conflicts with an existing instance in TypeChecking.Pretty+-- -- | We only print the name of the callee, omitting the actual call term.+-- instance PrettyTCM CallInfo where+-- prettyTCM (CallInfo target _term) = prettyTCM target++-- | Show all nodes.+instance PrettyTCM CallPath where+ prettyTCM cp = hsep $+ prettyTCM (callPathStart cp) :+ map' (\ (CallInfo g _) -> "-->" <+> prettyTCM g) (callInfos cp)++instance PrettyTCM CallMatrix where+ prettyTCM (CallMatrix m) = pretty m++instance PrettyTCM cinfo => PrettyTCM (CallMatrixAug cinfo) where+ prettyTCM (CallMatrixAug m cinfo) = prettyTCM cinfo $$ (nest 4 $ prettyTCM m)++instance PrettyTCM cinfo => PrettyTCM (CMSet cinfo) where+ prettyTCM = vcat . punctuate "\n" . map' prettyTCM . CallMatrix.toList++instance PrettyTCM cinfo => PrettyTCM (CallGraph.Call cinfo) where+ prettyTCM = prettyTCM . callMatrixSet++instance PrettyTCM cinfo => PrettyTCM (CallGraph cinfo) where+ prettyTCM = vcat . map' prettyTCM . CallGraph.toList
src/full/Agda/Termination/Order.hs view
@@ -10,6 +10,7 @@ ( -- * Structural orderings Order(..), decr , increase, decrease, setUsability+ , makeIncreaseInfinite , (.*.) , supremum, infimum , orderSemiring@@ -154,6 +155,13 @@ Decr _ k -> Decr u k Unknown -> o Mat{} -> o++-- | Turn any increase into infinite increase ('Unknown').++makeIncreaseInfinite :: Order -> Order+makeIncreaseInfinite = \case+ Decr u k | k < 0 -> Unknown+ o -> o -- | Smart constructor for @Decr k :: Order@ which cuts off too big values. --
src/full/Agda/Termination/RecCheck.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wunused-imports #-}+-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-all -dno-suppress-type-signatures -ddump-to-file -dno-typeable-binds #-} {- | Checking for recursion: @@ -36,8 +37,11 @@ import Agda.Syntax.Common.Pretty (prettyShow) import Agda.TypeChecking.Monad+import Agda.TypeChecking.CompiledClause +import Agda.Utils.List import Agda.Utils.Impossible+import Agda.Utils.StrictFlipEndo -- | The mutual block we are checking. --@@ -59,10 +63,10 @@ recursive names = do let names' = toList names -- For each function, get names per clause and total.- (perClauses, nss) <- unzip <$> mapM (recDef (`Set.member` names)) names'+ (perClauses, nss) <- unzip <$> mapM (recDef 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)@@ -79,7 +83,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?@@ -100,7 +104,8 @@ markNonRecursive q = modifySignature $ updateDefinition q $ updateTheDef $ \case def@Function{} -> def { funTerminates = Just True- , funClauses = map (\ cl -> cl { clauseRecursive = Just False }) $ funClauses def+ , funClauses = map' (\ cl -> cl { clauseRecursive = NotRecursive }) $ funClauses def+ , funCompiled = fmap (mapDone \ done -> done{ ccClauseRecursive = NotRecursive }) $ funCompiled def } def@Record{} -> def { recTerminates = Just True@@ -113,13 +118,14 @@ -> QName -> TCM () markRecursive f q = modifySignature $ updateDefinition q $ updateTheDef $ \case def@Function{} -> def- { funClauses = zipWith (\ i cl -> cl { clauseRecursive = Just (f i) }) [0..] $ funClauses def+ { funClauses = zipWith' (\ i cl -> cl { clauseRecursive = decideRecursive (f i) }) [0..] $ funClauses def+ , funCompiled = fmap (mapDone \ done@CCDone{ ccClauseNumber = i } -> done{ ccClauseRecursive = decideRecursive (f i) }) $ funCompiled def } def -> def -- | @recDef names name@ returns all definitions from @names@ -- that are used in the type and body of @name@.-recDef :: (QName -> Bool) -> QName -> TCM (NamesPerClause, Set QName)+recDef :: Set QName -> QName -> TCM (NamesPerClause, Set QName) recDef include name = do -- Retrieve definition def <- getConstInfo name@@ -136,8 +142,8 @@ (i,) <$> anyDefs include cl return (IntMap.fromList perClause, mconcat $ map snd perClause) - Datatype{ dataClause = Just cl } -> do- ns <- anyDefs include cl+ Datatype{ dataClause = Just v } -> do+ ns <- anyDefs include v return (IntMap.singleton 0 ns, ns) Record{ recClause, recTel } -> do@@ -155,17 +161,19 @@ ] return (perClause, ns1 `mappend` ns2) +{-# INLINE anyDefs #-} -- | @anysDef names a@ returns all definitions from @names@ -- that are used in @a@.-anyDefs :: GetDefs a => (QName -> Bool) -> a -> TCM (Set QName)+anyDefs :: GetDefs a => Set QName -> a -> TCM (Set QName) anyDefs include a = do -- Prepare function to lookup metas outside of TCM 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+ emb d = Endo \s -> if Set.member d include then Set.insert d s+ else s -- get all the Defs that are in names- return $ getDefs' lookup emb a+ return $! getDefs lookup emb a `appEndo` mempty where -- TODO: Is it bad to ignore the lambdas? inst (InstV i) = instBody i
src/full/Agda/Termination/SparseMatrix.hs view
@@ -37,6 +37,7 @@ , add , intersectWith , interAssocWith+ , mapNonZeros, mapDiagonalNonZeros , mul , transpose , Diagonal(..)@@ -70,6 +71,7 @@ import Agda.Utils.Tuple import Agda.Utils.Impossible+import Agda.Utils.Function (applyWhen) ------------------------------------------------------------------------ -- * Basic data types@@ -206,7 +208,7 @@ toLists :: (Integral i, HasZero b) => Matrix i b -> [[b]] toLists m@(Matrix size@(Size nrows ncols) _) = blowUpSparseVec emptyRow nrows $- map (mapSnd (blowUpSparseVec zeroElement ncols)) $ toSparseRows m+ map (second (blowUpSparseVec zeroElement ncols)) $ toSparseRows m where emptyRow = List.genericReplicate ncols zeroElement @@ -240,6 +242,13 @@ blowUpSparseVec zeroElement (min r c) $ mapMaybe (\ (MIx i j, b) -> if i == j then Just (i, b) else Nothing) m +-- | Apply the given function to the non-zero diagonal elements of a matrix.+--+-- @O(n)@ where @n@ is the number of non-zero elements in the matrix.++mapDiagonalNonZeros :: (Integral i, HasZero a) => (a -> a) -> Matrix i a -> Matrix i a+mapDiagonalNonZeros f = mapNonZeros \ r c -> applyWhen (r == c) f+ -- | Transposable things. class Transpose a where@@ -263,8 +272,19 @@ transpose (Matrix size m) = Matrix (transpose size) $ List.sortBy (compare `on` fst) $- map (mapFst transpose) m+ map (first transpose) m +-- | Apply the given function to all non-zero elements.+--+-- @O(n)@ where @n@ is the number of non-zero elements in the matrix.++mapNonZeros :: forall i a b. HasZero b => (i -> i -> a -> b) -> Matrix i a -> Matrix i b+mapNonZeros f (Matrix size m) = Matrix size $ mapMaybe f' m+ where+ f' :: (MIx i, a) -> Maybe (MIx i, b)+ f' (i@(MIx r c), a) = if b == zeroElement then Nothing else Just (i, b)+ where+ b = f r c a -- | General pointwise combination function for association lists. -- @O(n1 + n2)@ where @ni@ is the number of non-zero element in matrix @i@.
src/full/Agda/Termination/TermCheck.hs view
@@ -15,13 +15,14 @@ , Result ) where -import Prelude hiding ( null )+import Prelude hiding ( null, zip, zipWith ) import Control.Applicative ( liftA2 ) import Control.Monad ( (<=<), filterM, forM, forM_, zipWithM )- import Data.Foldable (toList)+import qualified Data.IntMap.Strict as IntMap import qualified Data.List as List+import qualified Data.Map.Strict as Map import Data.Monoid hiding ((<>)) import Data.Set (Set) import qualified Data.Set as Set@@ -38,12 +39,11 @@ import Agda.Termination.CutOff import Agda.Termination.Monad import Agda.Termination.CallGraph hiding (toList)-import qualified Agda.Termination.CallGraph as CallGraph+import Agda.Termination.CallGraph qualified as CallGraph import Agda.Termination.CallMatrix hiding (toList) import Agda.Termination.Order as Order-import qualified Agda.Termination.SparseMatrix as Matrix-import Agda.Termination.Termination (Terminates(..), GuardednessHelps(..), endos, idempotent)-import qualified Agda.Termination.Termination as Term+import Agda.Termination.SparseMatrix qualified as Matrix+import Agda.Termination.Termination (Terminates(..), GuardednessHelps(..), idempotentEndos, terminatesFilter, terminationCounterexample) import Agda.Termination.RecCheck import Agda.TypeChecking.Datatypes@@ -52,7 +52,7 @@ import Agda.TypeChecking.Pretty import Agda.TypeChecking.Forcing import Agda.TypeChecking.Records -- (isRecordConstructor, isInductiveRecord)-import Agda.TypeChecking.Reduce (reduce, normalise, instantiate, instantiateFull, appDefE')+import Agda.TypeChecking.Reduce (reduce, normalise, instantiate, instantiateFull, appDefE0) import Agda.TypeChecking.SizedTypes import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope@@ -66,14 +66,18 @@ import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.List+import Agda.Utils.ListInf ( pattern (:<) )+import Agda.Utils.ListInf qualified as ListInf import Agda.Utils.Maybe import Agda.Utils.Monad -- (mapM', forM', ifM, or2M, and2M) import Agda.Utils.Null import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Utils.Singleton import Agda.Utils.Size+-- import Agda.Utils.SmallSet (SmallSet) import qualified Agda.Utils.SmallSet as SmallSet import qualified Agda.Utils.VarSet as VarSet+import Agda.Utils.Zip import Agda.Utils.Impossible @@ -102,8 +106,8 @@ A.Axiom {} -> return mempty A.Field {} -> return mempty A.Primitive {} -> return mempty- A.Mutual i ds -> termMutual $ getNames ds- A.Section _ _ _ _ ds -> termDecls ds+ A.Mutual _ ds -> termMutual $ getNames ds+ A.Section _ _ _ _ ds -> foldMap termDecl' ds -- section structure can be ignored as we are termination checking -- definitions lifted to the top-level A.Apply {} -> return mempty@@ -114,10 +118,10 @@ A.UnfoldingDecl{} -> return mempty A.Generalize {} -> return mempty -- open, pattern synonym and generalize defs are just artifacts from the concrete syntax- A.ScopedDecl scope ds -> {- withScope_ scope $ -} termDecls ds+ A.ScopedDecl scope ds -> {- withScope_ scope $ -} foldMap termDecl' ds -- scope is irrelevant as we are termination checking Syntax.Internal A.RecSig{} -> return mempty- A.RecDef _ x _ _ _ _ ds -> termMutual [x] <> termDecls ds+ A.RecDef _ x _ _ _ _ _ _ ds -> termMutual [x] <> foldMap termDecl' ds -- Andreas, 2022-10-23, issue #5823 -- Also check record types for termination. -- They are unfolded during construction of unique inhabitants of eta-records.@@ -129,13 +133,12 @@ A.UnquoteDef{} -> __IMPOSSIBLE__ A.UnquoteData{} -> __IMPOSSIBLE__ where- termDecls ds = concat <$> mapM termDecl' ds- -- The mutual names mentioned in the abstract syntax -- for symbols that need to be termination-checked.- getNames = concatMap getName+ getNames :: Foldable t => t A.Declaration -> [QName]+ getNames = foldMap getName getName (A.FunDef i x cs) = [x]- getName (A.RecDef _ x _ _ _ _ ds) = x : 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@@ -157,7 +160,7 @@ -- Get set of mutually defined names from the TCM. -- This includes local and auxiliary functions introduced -- during type-checking.- mid <- fromMaybe __IMPOSSIBLE__ <$> asksTC envMutualBlock+ mid <- fromMaybe __IMPOSSIBLE__ <$> viewTC eMutualBlock mutualBlock <- lookupMutualBlock mid let allNames = Set.filter (not . isAbsurdLambdaName) $ mutualNames mutualBlock@@ -176,12 +179,12 @@ -- NO_TERMINATION_CHECK if (Info.mutualTerminationCheck i `elem` [ NoTerminationCheck, Terminating ]) then do reportSLn "term.warn.yes" 10 $ "Skipping termination check for " ++ prettyShow names- forM_ allNames $ \ q -> setTerminates q True -- considered terminating!+ forM_ allNames $ \ q -> setTerminates q $ Just True -- considered terminating! return mempty -- NON_TERMINATING else if (Info.mutualTerminationCheck i == NonTerminating) then do reportSLn "term.warn.yes" 10 $ "Considering as non-terminating: " ++ prettyShow names- forM_ allNames $ \ q -> setTerminates q False+ forM_ allNames $ \ q -> setTerminates q $ Just False return mempty else do sccs <- do@@ -202,17 +205,27 @@ concat <$> do forM sccs $ \ allNames -> do + -- Andreas, 2025-05-31, AIM XL, re issue #7906:+ -- Clear previous information about termination to avoid loops in the termination checker.+ forM_ allNames $ \ q -> setTerminates q Nothing+ -- Set the mutual names in the termination environment. let namesSCC = Set.filter (`Set.member` allNames) names let setNames e = e { terMutual = allNames , terUserNames = namesSCC }- runTerm cont = runTerDefault $ do+ -- Pre-compute the copattern projection lists and assign node ids, per issue #8596.+ (projectedNameToNode, nodeToName, nameToProjections, projectedNameToMaskArgs) <- buildNodeAndProjectionMaps allNames+ let runTerm cont = runTerDefault $ do cutoff <- terGetCutOff reportSLn "term.top" 10 $ "Termination checking " ++ prettyShow namesSCC ++ " with cutoff=" ++ show cutoff ++ "..."- terLocal setNames cont+ terSetProjectedNameToNode projectedNameToNode $+ terSetNodeToName nodeToName $+ terSetNameToProjections nameToProjections $+ terSetProjectedNameToMaskArgs projectedNameToMaskArgs $+ terLocal setNames cont -- New check currently only makes a difference for copatterns and record types. -- Since it is slow, only invoke it if@@ -223,44 +236,46 @@ -- Else: Old check, all at once. (runTerm $ termMutual') --- | Run the termination checker possibly twice and take the best result.--- Run it first without extracting descent information from dot patterns.--- If this proves termination, we are done.--- If this did not manage to prove termination, try with dot patterns.--- If this did not manage to prove termination either, return the offending paths.--- Otherwise, if the first run proved termination subject to (deactivated) guardedness,--- return this result.--- Otherwise, return the second result.-withOrWithoutDotPatterns ::- (Node -> Bool)+-- | Run the termination checker.+runTerminationCheck ::+ Maybe QName -> TerM Calls -> TerM (Terminates CallPath)-withOrWithoutDotPatterns filt collect = do- useGuardedness <- liftTCM guardednessOption- cutoff <- terGetCutOff- let ?cutoff = cutoff- -- Run the continuation @k@ with the result of @m@ unless @m@ already certifies termination.- let unlessTerminates m k = m >>= \case- Terminates- -> return Terminates- TerminatesNot GuardednessHelpsYes _ | useGuardedness- -> return Terminates- r -> k r+runTerminationCheck mname collect = do+ -- Use full precision when extracting calls+ let ?cutoff = DontCutOff+ calls <- collect - -- First try to termination check ignoring the dot patterns- calls1 <- terSetUseDotPatterns False collect- reportCalls "no " calls1- unlessTerminates (billToTerGraph $ Term.terminatesFilter filt calls1) \ r1 -> do- -- Try again, but include the dot patterns this time.- calls2 <- terSetUseDotPatterns True collect- reportCalls "" calls2- unlessTerminates (billToTerGraph $ Term.terminatesFilter filt calls2) \ r2 -> do- case r1 of- TerminatesNot GuardednessHelpsNot _ -> return r2- -- We might terminate with guardedness and dot patterns (r2).- _ -> return r1- -- Since r2 did not certify termination, the simpler r1 is preferable.+ nodeToName <- terGetNodeToName+ let filt :: Node -> Bool+ filt = case mname of+ Nothing -> const True+ Just f -> \ n -> IntMap.lookup n nodeToName == Just f + useGuardedness <- liftTCM guardednessOption+ maxcutoff <- terGetCutOff+ -- Iteratively increase cutoff up to its maximal value.+ let+ loop :: CutOff+ -> Maybe (GuardednessHelps, CallPath)+ -> TerM (Terminates CallPath)+ loop cutoff currentResult = do+ let ?cutoff = cutoff+ reportCalls cutoff filt calls+ r <- billToTerGraph $ terminatesFilter useGuardedness filt calls+ case r of+ Terminates -> return Terminates+ TerminatesNot gh cinfo -> do+ let result = bestResult currentResult (gh, cinfo)+ if cutoff >= maxcutoff then return $ uncurry TerminatesNot result+ else loop (cutoff + 1) (Just result)+ loop 0 Nothing+ where+ bestResult :: Maybe (GuardednessHelps, CallPath) -> (GuardednessHelps, CallPath) -> (GuardednessHelps, CallPath)+ bestResult Nothing r = r+ bestResult (Just (GuardednessHelpsNot, _)) r@(GuardednessHelpsYes, _) = r+ bestResult (Just r0) _ = r0+ -- | @termMutual'@ checks all names of the current mutual block, -- henceforth called @allNames@, for termination. --@@ -275,7 +290,7 @@ let collect :: TerM Calls collect = forM' allNames termDef - r <- withOrWithoutDotPatterns (const True) collect+ r <- runTerminationCheck Nothing collect -- @names@ is taken from the 'Abstract' syntax, so it contains only -- the names the user has declared. This is for error reporting.@@ -283,13 +298,13 @@ case r of TerminatesNot guardednessHelps calls -> do- mapM_ (`setTerminates` False) allNames+ mapM_ (`setTerminates` Just False) allNames return $ singleton $ terminationError names calls guardednessHelps Terminates -> do liftTCM $ reportSLn "term.warn.yes" 2 $ prettyShow (names) ++ " does termination check"- mapM_ (`setTerminates` True) allNames+ mapM_ (`setTerminates` Just True) allNames return mempty -- | Smart constructor for 'TerminationError'.@@ -298,7 +313,7 @@ terminationError names calls guardednessHelps = TerminationError names' calls' guardednessHelps where calls' = callInfos calls- mentioned = map callInfoTarget calls'+ mentioned = map' callInfoTarget calls' names' = filter (hasElem mentioned) $ toList names billToTerGraph :: a -> TerM a@@ -308,16 +323,17 @@ -- -- Replays the call graph completion for debugging. -reportCalls :: String -> Calls -> TerM ()-reportCalls no calls = do- cutoff <- terGetCutOff+reportCalls :: CutOff -> (Node -> Bool) -> Calls -> TerM ()+reportCalls cutoff filt calls = do+ useGuardedness <- liftTCM guardednessOption let ?cutoff = cutoff -- We work in TCM exclusively. liftTCM $ do reportS "term.lex" 20- [ "Calls (" ++ no ++ "dot patterns): " ++ prettyShow calls+ [ "Termination depth: " ++ show cutoff+ , "Calls: " ++ prettyShow calls ] -- Print the whole completion phase.@@ -333,27 +349,30 @@ k' = r - k let report s cs = reportSDoc "term.matrices" 40 $ vcat [ text $ header s- , nest 2 $ pretty cs+ , nest 2 $ prettyTCM cs ] cs0 = calls step cs = do let (new, cs') = completionStep cs0 cs report " New call matrices " new- return $ if null new then Left () else Right cs'- report " Initial call matrices " cs0+ case terminationCounterexample useGuardedness filt new of+ Terminates | not (null new) -> return $ Right cs'+ _ -> return $ Left ()+ -- return $ if null new then Left () else Right cs'+ report (" Initial call matrices (cutoff: " ++ show cutoff ++ ") ") cs0 trampolineM step cs0 -- Print the result of completion. let calls' = CallGraph.complete calls- idems = filter idempotent $ endos $ CallGraph.toList calls'+ idems = idempotentEndos calls' -- TODO -- reportSDoc "term.behaviours" 20 $ vcat -- [ text $ "Recursion behaviours (" ++ no ++ "dot patterns):" -- , nest 2 $ return $ Term.prettyBehaviour calls' -- ] reportSDoc "term.matrices" 30 $ vcat- [ text $ "Idempotent call matrices (" ++ no ++ "dot patterns):\n"- , nest 2 $ vcat $ punctuate "\n" $ map pretty idems+ [ text $ "Idempotent call matrices:\n"+ , nest 2 $ vcat $ punctuate "\n" $ map' prettyTCM idems ] -- reportSDoc "term.matrices" 30 $ vcat -- [ text $ "Other call matrices (" ++ no ++ "dot patterns):"@@ -367,12 +386,6 @@ termFunction :: QName -> TerM Result 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__ $ 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.@@ -390,23 +403,30 @@ -- involve @name@, -- taking the target of @name@ into account for computing guardedness. - let collect = (`trampolineM` (Set.singleton index, mempty, mempty)) $ \ (todo, done, calls) -> do+ let+ collect :: TerM Calls+ collect = -- strengthenLoopDiagonals <$> do -- bad heuristics, see https://github.com/agda/agda/pull/8184#issuecomment-3487147737+ (`trampolineM` (Set.singleton name, mempty, mempty)) $ \ (todo, done, calls) -> do if null todo then return $ Left calls else do- -- Extract calls originating from indices in @todo@.- new <- forM' todo $ \ i ->- termDef $- if i < 0 || i >= Set.size allNames- then __IMPOSSIBLE__- else Set.elemAt i allNames+ -- Extract calls originating from functions in @todo@.+ new <- forM' todo termDef+ -- call-graph nodes correspond to @(name, [projection])@ pairs, so we+ -- need to do a step of processing to translate node numbers into the+ -- corresponding function name (see #8596).+ nodeToName <- terGetNodeToName+ let newNames = Set.fromList+ [ q | n <- Set.toList (CallGraph.targetNodes new)+ , Just q <- [IntMap.lookup n nodeToName]+ ] -- Mark those functions as processed and add the calls to the result. let done' = done `mappend` todo calls' = new `mappend` calls -- Compute the new todo list:- todo' = CallGraph.targetNodes new Set.\\ done'+ todo' = newNames Set.\\ done' -- Jump the trampoline. return $ Right (todo', done', calls') - r <- withOrWithoutDotPatterns (== index) collect+ r <- runTerminationCheck (Just name) collect names <- terGetUserNames case r of@@ -414,7 +434,7 @@ TerminatesNot guardednessHelps callpaths -> do let calls = callInfos callpaths -- Mark as non-terminating.- setTerminates name False+ setTerminates name $ Just False -- Functions must be terminating, records types need not... case theDef def of@@ -423,7 +443,7 @@ 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)+ map' (nest 2 . prettyTCM) (List.sortOn getRange calls) mempty -- Functions must terminate, so we report the error.@@ -434,7 +454,7 @@ Terminates -> do reportSLn "term.warn.yes" 2 $ prettyShow name ++ " does termination check"- setTerminates name True+ setTerminates name $ Just True return mempty where reportTarget :: MonadDebug m => Target -> m ()@@ -463,7 +483,8 @@ -- Only the latter depends on the choice whether we -- consider dot patterns or not. termDef :: QName -> TerM Calls-termDef name = terSetCurrent name $ inConcreteOrAbstractMode name $ \ def -> do+termDef name = terSetCurrent name $ inConcreteOrAbstractMode name \ def -> do+ -- strengthenLoopDiagonals <$> do -- bad heuristics, see https://github.com/agda/agda/pull/8184#issuecomment-3487147737 -- 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 }@@ -491,7 +512,7 @@ -- which are not of data or record type. withoutKEnabled <- liftTCM withoutKOption- applyWhen withoutKEnabled (setMasks t) $ do+ applyWhen withoutKEnabled (setResultMask t) $ do -- If the result should be disregarded, set all calls to unguarded. applyWhenM terGetMaskResult terUnguarded $ do@@ -515,7 +536,7 @@ termRecTel :: Nat -> Telescope -> TerM Calls termRecTel npars tel = do -- Set up the record parameters like function parameters.- let (pars, fields) = splitAt npars $ telToList tel+ let (pars, fields) = splitAt' npars $ telToList tel addContext pars $ do ps <- mkPats npars terSetPatterns ps $ terSetSizeDepth pars $ do@@ -523,7 +544,7 @@ extract $ telFromList fields where -- create n variable patterns- mkPats n = map mkPat <$> getContextVars+ mkPats n = map' mkPat <$> getContextVars mkPat (i, x) = notMasked $ VarP defaultPatternInfo $ DBPatVar (prettyShow x) i -- | Collect calls in type signature @f : (x1:A1)...(xn:An) -> B@.@@ -552,25 +573,42 @@ extract dom `mappend` underAbstractionAbs dom absB (loop $! n + 1) -- create n variable patterns- mkPats n = map mkPat <$> getContextVars+ mkPats n = map' mkPat <$> getContextVars mkPat (i, x) = notMasked $ VarP defaultPatternInfo $ DBPatVar (prettyShow x) i --- | Mask arguments and result for termination checking--- according to type of function.--- Only arguments of types ending in data/record or Size are counted in.-setMasks :: Type -> TerM a -> TerM a-setMasks t cont = do- (ds, d) <- liftTCM $ do+-- | Mask the result for termination checking according to type of function.+-- (Masking for arguments is handled per-clause in 'termClause'.)++setResultMask :: Type -> TerM a -> TerM a+setResultMask t cont = do+ d <- liftTCM $ do TelV tel core <- telViewPath t- -- Check argument types- ds <- checkArgumentTypes tel- -- Check result types 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+ return d+ terSetMaskResult d cont +-- | Precompute the argument masks for a @(name, [projection])@ pair. Strips+-- and classifies the leading Π-arguments (which occupy the argument-pattern+-- slots reached before the next projection), then follows the next projection+-- in @path@ into its field type and recurses.++argumentMasksForPath :: Type -> [QName] -> TCM (ListInf.ListInf Bool)+argumentMasksForPath t path = do+ TelV tel core <- telViewPath t+ ds <- checkArgumentTypes tel+ case path of+ [] -> return (ListInf.pad ds True)+ (d : path') -> addContext tel $ reduce core >>= getDefType d >>= \case+ Just projTy -> reduce projTy >>= \case+ El _ (Pi dom b) -> underAbstraction dom b $ \ft -> do+ -- Projection patterns occupy one slot in the clause pattern list, but+ -- should always be considered unmasked. Hence the @False@:+ rest <- argumentMasksForPath ft path'+ return $ ListInf.append ds (False :< rest)+ _ -> return (ListInf.pad ds True)+ Nothing -> return (ListInf.pad ds True) where checkArgumentTypes :: Telescope -> TCM [Bool] checkArgumentTypes EmptyTel = return []@@ -593,15 +631,6 @@ TargetRecord -> False TargetOther -> 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- termToPattern =<< do liftTCM $ stripAllProjections =<< normalise t- -- | Convert a term (from a dot pattern) to a pattern for the purposes of the termination checker. -- -- @SIZESUC@ is treated as a constructor.@@ -609,51 +638,77 @@ class TermToPattern a b where termToPattern :: a -> TerM b - default termToPattern :: (TermToPattern a' b', Traversable f, a ~ f a', b ~ f b') => a -> TerM b- termToPattern = traverse termToPattern--instance TermToPattern a b => TermToPattern [a] [b] where-instance TermToPattern a b => TermToPattern (Arg a) (Arg b) where-instance TermToPattern a b => TermToPattern (Named c a) (Named c b) where+-- UNUSED default instances (Andreas, 2026-08-29):+ -- default termToPattern :: (TermToPattern a' b', Traversable f, a ~ f a', b ~ f b') => a -> TerM b+ -- termToPattern = traverse termToPattern --- OVERLAPPING--- instance TermToPattern a b => TermToPattern a (Named c b) where--- termToPattern t = unnamed <$> termToPattern t+-- instance TermToPattern a b => TermToPattern [a] [b] where+-- instance TermToPattern a b => TermToPattern (Arg a) (Arg b) where+-- instance TermToPattern a b => TermToPattern (Named c a) (Named c b) where instance TermToPattern Term DeBruijnPattern where- termToPattern t = liftTCM (constructorForm t) >>= \case- -- Constructors.- Con c _ args -> ifNotConsOfHIT c $- ConP c noConPatternInfo . map (fmap unnamed) <$> termToPattern (fromMaybe __IMPOSSIBLE__ $ allApplyElims args)- Def s [Apply arg] -> do- suc <- terGetSizeSuc- if Just s == suc then ConP (ConHead s IsData Inductive []) noConPatternInfo . map (fmap unnamed) <$> termToPattern [arg]- 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 -> fallback- where- -- 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.- --- -- Szumi, 2025-03-11:- -- Instead of completely turning off dot-pattern termination for cubical,- -- it should be enough to only ignore constructors of HITs in dot patterns.- -- This way, the issues #5953 and #4725 are also avoided.- ifNotConsOfHIT c = ifM (consOfHIT (conName c)) fallback- fallback = return $ dotP t+ termToPattern t = do+ t <- constructorForm =<< reduce t+ let+ -- 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.+ --+ -- Szumi, 2025-03-11:+ -- Instead of completely turning off dot-pattern termination for cubical,+ -- it should be enough to only ignore constructors of HITs in dot patterns.+ -- This way, the issues #5953 and #4725 are also avoided.+ ifNotConsOfHIT :: ConHead -> TerM DeBruijnPattern -> TerM DeBruijnPattern+ ifNotConsOfHIT c = ifM (consOfHIT (conName c)) fallback+ -- Andreas, 2025-11-20, issue #8212+ -- Reduce constructor to their original form+ -- as this also happens in the call arguments.+ fallback :: TerM DeBruijnPattern+ fallback = dotP <$> do reduceCon t+ case t of+ -- Constructors.+ Con c _ args -> ifNotConsOfHIT c $+ ConP c noConPatternInfo . map' (fmap unnamed) <$> mapM argToPattern (mustAllApplyElims args)+ Def s [Apply arg] -> do+ suc <- terGetSizeSuc+ if Just s == suc then ConP (ConHead s IsData Inductive NotHIT []) noConPatternInfo . singleton . fmap unnamed <$> argToPattern arg+ else fallback+ -- Leaves.+ -- Any (not coinductively) projected variable becomes a variable pattern.+ Var i es -> case mapM isProjElim es of+ Just oxs -> foldMap (All <.> isProjectionButNotCoinductive . snd) oxs >>= \case+ All True -> varP . (`DBPatVar` i) . prettyShow <$> nameOfBV i+ _ -> fallback+ _ -> fallback+ Lit l -> return $ litP l+ Dummy s _ -> __IMPOSSIBLE_VERBOSE__ (show s)+ Def{} -> fallback+ Lam{} -> fallback+ Pi{} -> fallback+ Sort{} -> fallback+ Level{} -> fallback+ MetaV{} -> fallback+ -- Andreas, 2026-08-27, going under DontCare causes issue #8699.+ -- See test/Fail/Issue8699Prop.+ DontCare{} -> fallback +-- | Convert an argument into a pattern, but don't descent into irrelevant (sub)terms.+-- (See issue #8699).+argToPattern :: Arg Term -> TerM (Arg DeBruijnPattern)+argToPattern arg+ -- Andreas, 2026-08-29: irrelevant parts of dot patterns do not provide evidence for termination+ -- since their specific form is not forced (by matches on other patterns) but arbitrary.+ | isIrrelevant arg = return $ fmap dotP arg+ | otherwise = traverse termToPattern arg++ -- | Masks all non-data/record type patterns if --without-K. -- See issue #1023. maskNonDataArgs :: [DeBruijnPattern] -> TerM [Masked DeBruijnPattern]@@ -678,31 +733,41 @@ -- | Extract recursive calls from one clause. termClause :: Clause -> TerM Calls termClause clause = do- Clause{ clauseTel = tel, namedClausePats = ps, clauseBody = body } <- etaExpandClause clause+ Clause{ clauseTel = tel, namedClausePats = ps, clauseBody = body } <- snd <$> etaExpandClause clause liftTCM $ reportSDoc "term.check.clause" 25 $ vcat [ "termClause" , nest 2 $ "tel =" <+> prettyTCM tel , nest 2 $ "ps =" <+> do addContext tel $ prettyTCMPatternList ps ]- forM' body $ \ v -> addContext tel $ do+ maskArgs <- do+ f <- terGetCurrent+ path <- liftTCM $ mapM getOriginalProjection $+ mapMaybe (fmap (headAmbQ . snd) . isProjP . namedArg) ps+ modeMasks <- terGetProjectedNameToMaskArgs+ case Map.lookup (f, path) modeMasks of+ Just m -> return m+ Nothing -> terGetMaskArgs -- --with-K: map is empty; fallback is "mask nothing"+ terSetMaskArgs maskArgs $ forM' body $ \ v -> addContext tel $ do -- TODO: combine the following two traversals, avoid full normalisation. -- Parse dot patterns as patterns as far as possible. ps <- postTraversePatternM parseDotP ps -- Blank out coconstructors. ps <- preTraversePatternM stripCoCon ps -- Mask non-data arguments.- mdbpats <- maskNonDataArgs $ map namedArg ps+ mdbpats <- maskNonDataArgs $ map' namedArg ps terSetPatterns mdbpats $ do terSetSizeDepth tel $ do reportBody v extract v where+ parseDotP :: DeBruijnPattern -> TerM DeBruijnPattern parseDotP = \case- DotP o t -> termToDBP t+ DotP o t -> termToPattern t p -> return p+ stripCoCon :: DeBruijnPattern -> TerM DeBruijnPattern stripCoCon = \case- ConP (ConHead c _ CoInductive _) _ _ -> return unusedVar+ ConP (ConHead c _ CoInductive _ _) _ _ -> return unusedVar p -> return p reportBody :: Term -> TerM () reportBody v = verboseS "term.check.clause" 6 $ do@@ -711,7 +776,7 @@ liftTCM $ reportSDoc "term.check.clause" 6 $ do sep [ text ("termination checking clause of") <+> prettyTCM f- , nest 2 $ "lhs:" <+> sep (map prettyTCM pats)+ , nest 2 $ "lhs:" <+> sep (map' prettyTCM pats) , nest 2 $ "rhs:" <+> prettyTCM v ] @@ -763,7 +828,9 @@ LevelUniv -> return empty IntervalUniv -> return empty Univ _ t -> terUnguarded $ extract t -- no guarded levels- PiSort a s1 s2 -> extract (a, s1, s2)+ -- We ignore calls in the blocked dependency check (these will vanish+ -- after the 'PiSort' reduces)+ PiSort _c a s1 s2 -> extract (a, s1, s2) FunSort s1 s2 -> extract (s1, s2) UnivSort s -> extract s MetaS x es -> return empty@@ -820,10 +887,10 @@ -- If the function is a projection but not for a coinductive record, -- then preserve guardedness for its principal argument. isProj <- isProjectionButNotCoinductive g- let unguards = repeat Order.unknown- let guards = applyWhen isProj (guarded :) unguards+ let unguards = ListInf.repeat Order.unknown+ let guards = applyWhen isProj (guarded :<) unguards -- Collect calls in the arguments of this call.- let args = map unArg $ argsFromElims es0+ let args = map' unArg $ argsFromElims es0 calls <- forM' (zip guards args) $ \ (guard, a) -> do terSetGuarded guard $ extract a @@ -841,7 +908,7 @@ Nothing -> return calls -- call is to one of the mutally recursive functions/record- Just gInd -> do+ Just{} -> do cutoff <- terGetCutOff let ?cutoff = cutoff @@ -926,35 +993,117 @@ -- Andreas, 2017-01-05, issue #2376 -- Remove arguments inserted by etaExpandClause. - let src = fromMaybe __IMPOSSIBLE__ $ Set.lookupIndex f names- tgt = gInd- cm = makeCM ncols nrows matrix'- info = CallPath $ singleton $+ -- Issue #8596: stratify the call-graph nodes by copattern projection+ -- list. The source node is the caller's (name, [projection]) tuple;+ -- the target fans out to every real callee mode this call can reach+ -- (those whose projection path is prefix-comparable to the call's).+ srcNode <- projNode f =<< clauseProjPath+ tgtNodes <- callTargetNodes g es0+ let cm = makeCM ncols nrows matrix'+ info = CallPath { callPathStart = f, callPathSteps = singleton $ CallInfo { callInfoTarget = g , callInfoCall = doc- }+ }} verboseS "term.kept.call" 5 $ do pats <- terGetPatterns reportSDoc "term.kept.call" 5 $ vcat- [ "kept call from" <+> text (prettyShow f) <+> hsep (map prettyTCM pats)+ [ "kept call from" <+> text (prettyShow f) <+> hsep (map' prettyTCM pats) , nest 2 $ "to" <+> text (prettyShow g) <+>- hsep (map (parens . prettyTCM) args)+ hsep (map' (parens . prettyTCM) args) , nest 2 $ "call matrix (with guardedness): " , nest 2 $ pretty cm ]- return $ CallGraph.insert src tgt cm info calls+ return $ List.foldl' (\ cs t -> CallGraph.insert srcNode t cm info cs) calls tgtNodes - where- -- We have to reduce constructors in case they're reexported.- -- Andreas, Issue 1530: constructors have to be reduced deep inside terms,- -- thus, we need to use traverseTermM.- reduceCon :: Term -> TCM Term- reduceCon = traverseTermM $ \case- Con c ci vs -> (`applyE` vs) <$> reduce (Con c ci []) -- make sure we don't reduce the arguments- t -> return t+-- | The canonical leading copattern projection path of the clause currently+-- being checked.+clauseProjPath :: TerM [QName]+clauseProjPath = do+ pats <- terGetPatterns+ mapM getOriginalProjection $+ mapMaybe (fmap (headAmbQ . snd) . isProjP . getMasked) pats +-- | Look up the call-graph node for a @(function, projection path)@ pair.+-- The pair must have been registered by 'buildNodeAndProjectionMaps'.+projNode :: QName -> [QName] -> TerM Node+projNode f path = fromMaybe __IMPOSSIBLE__ . Map.lookup (f, path) <$> terGetProjectedNameToNode +-- | Pre-compute the copattern-mode node maps for a mutual SCC.+--+-- For each function in the SCC we collect the canonical leading copattern+-- projection path of every clause, deduplicate, and assign a fresh 'Node'+-- integer to each @(function, [projection])@ pair. The resulting maps+-- are stored in 'TerEnv' before call extraction begins. The reverse map+-- is split into an @IntMap QName@ and a @Map QName [[QName]]@ because+-- 'termFunction' walks per-function, and thus only needs the names.+buildNodeAndProjectionMaps+ :: Set QName+ -> TCM ( Map.Map (QName, [QName]) Node+ , IntMap.IntMap QName+ , Map.Map QName [[QName]]+ , Map.Map (QName, [QName]) (ListInf.ListInf Bool)+ )+buildNodeAndProjectionMaps allNames = do+ withoutK <- withoutKOption+ pairs <- forM (Set.toList allNames) $ \ g -> do+ def <- ignoreAbstractMode (getConstInfo g)+ ms <- forM (defClauses def) $ \ cl ->+ mapM getOriginalProjection $+ mapMaybe (fmap (headAmbQ . snd) . isProjP . namedArg) $ namedClausePats cl+ return (g, defType def, List.nub ms)+ let projectionsOf (g, _, ps) = if null ps then [(g, [])] else map (g,) ps+ allProjectionLists = concatMap projectionsOf pairs+ projectedNameToNode = Map.fromList $ zip allProjectionLists [0..]+ nodeToName = IntMap.fromList $ zip [0..] $ map fst allProjectionLists+ nameToProjections = Map.fromList [ (g, if null ms then [[]] else ms) | (g, _, ms) <- pairs ]+ projectedNameToMaskArgs <- if withoutK+ then do+ let typeOf = Map.fromList [ (g, t) | (g, t, _) <- pairs ]+ Map.fromList <$> forM allProjectionLists (\ (g, path) ->+ -- Andreas, 2026-08-21, issue #8674:+ -- Compute the masks in the abstract/opaque mode of @g@,+ -- otherwise abstract data types are invisible here (they look like axioms)+ -- and their arguments get masked, destroying structural descent.+ ((g, path),) <$> inConcreteOrAbstractMode g \ _def ->+ argumentMasksForPath (typeOf Map.! g) path)+ else return Map.empty+ return (projectedNameToNode, nodeToName, nameToProjections, projectedNameToMaskArgs)++-- | Two projection paths are comparable if one is a prefix of the other.+comparableProjPath :: [QName] -> [QName] -> Bool+comparableProjPath xs ys = xs `List.isPrefixOf` ys || ys `List.isPrefixOf` xs++-- | The callee nodes that a recursive call should connect to. It is not as easy+-- as just looking up the node corresponding to a name, because in the case of+-- definitions by copatterns, a call to @x .foo@ also counts as routing through+-- @x .foo .bar@, for the purpose of termination checking. So the call must be+-- "fanned out" to every callee with a comparable projection list.+callTargetNodes :: QName -> Elims -> TerM [Node]+callTargetNodes g es = do+ givenProjList <- mapM getOriginalProjection [ d | Proj _ d <- es ]+ knownProjLists <- Map.findWithDefault [[]] g <$> terGetNameToProjections+ let comparable = filter (comparableProjPath givenProjList) knownProjLists+ leaves+ | null comparable = knownProjLists -- incomparable: conservatively connect to all+ | otherwise = comparable+ unless (leaves == [givenProjList]) $+ reportSLn "term.copattern.modes" 30 $ unwords+ [ "call to", prettyShow g+ , "at projection path", show (map prettyShow givenProjList)+ , "connects to modes", show (map (map prettyShow) leaves)+ ]+ mapM (projNode g) leaves++-- We have to reduce constructors in case they're reexported.+-- Andreas, Issue 1530: constructors have to be reduced deep inside terms,+-- thus, we need to use traverseTermM.+reduceCon :: MonadTCM tcm => Term -> tcm Term+reduceCon = liftTCM . traverseTermM \case+ Con c ci vs -> (`applyE` vs) <$> reduce (Con c ci []) -- make sure we don't reduce the arguments+ t -> return t++ -- | Try to get rid of a function call targeting the current SCC -- using a non-recursive clause. --@@ -974,18 +1123,18 @@ ifM (notElem g <$> terGetMutual) fallback {-else-} $ do reportSLn "term.reduce" 40 $ "This call is in the current SCC!" - -- Then, collect its clauses.- cls <- defClauses <$> getConstInfo g- reportSLn "term.reduce" 40 $ unwords [ "Function has", show (length cls), "clauses"]- reportSDoc "term.reduce" 80 $ vcat $ map (prettyTCM . NamedClause g True) cls- reportSLn "term.reduce" 80 . ("allowed reductions = " ++) . show . SmallSet.elems- =<< asksTC envAllowedReductions+ def <- getConstInfo g+ -- -- Then, collect its clauses.+ -- cls <- defClauses <$> getConstInfo g+ -- reportSLn "term.reduce" 40 $ unwords [ "Function has", show (length cls), "clauses"]+ -- reportSDoc "term.reduce" 80 $ vcat $ map (prettyTCM . NamedClause g True) cls+ -- reportSLn "term.reduce" 80 . ("allowed reductions = " ++) . show . SmallSet.elems+ -- =<< asksTC envAllowedReductions -- Finally, try to reduce with the non-recursive clauses (and no rewrite rules). r <- liftTCM $ modifyAllowedReductions (SmallSet.delete UnconfirmedReductions) $- localTC (\e -> e { envTermCheckReducing = True }) $- runReduceM $ appDefE' g v0 cls [] (map notReduced es)+ runReduceM $ appDefE0 g def v0 [] (map' notReduced es) case r of NoReduction{} -> fallback YesReduction _ v -> do@@ -1008,11 +1157,12 @@ -- Constructed value. Con ConHead{conName = c, conDataRecord = dataOrRec} _ es -> do- let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ let args = mustAllApplyElims es -- A constructor preserves the guardedness of all its arguments. -- 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+ let noIApply = all isProperApplyElim es+ let argsg = map' (,noIApply) args -- If we encounter a coinductive record constructor -- in a type mutual with the current target@@ -1205,7 +1355,7 @@ def <- theDef <$> getConstInfo r case def of Record{ recFields = fs } -> do- fs <- return $ map unDom fs+ fs <- return $ map' unDom fs case (List.find (d ==) fs, List.find (d' ==) fs) of (Just i, Just i') -- earlier field is smaller@@ -1227,7 +1377,7 @@ addGuardedness :: Order -> (Int, Int, [[Order]]) -> (Int, Int, [[Order]]) addGuardedness o (nrows, ncols, m) = (nrows + 1, ncols + 1,- (o : replicate ncols Order.unknown) : map (Order.unknown :) m)+ (o : replicate ncols Order.unknown) : map' (Order.unknown :) m) -- | Compose something with the upper-left corner of a call matrix composeGuardedness :: (?cutoff :: CutOff) => Order -> [[Order]] -> [[Order]]@@ -1241,97 +1391,46 @@ offsetFromConstructor c = ifM (isEtaOrCoinductiveRecordConstructor c) (return 0) (return 1) ---UNUSED Liang-Ting 2019-07-16----- | Compute the proper subpatterns of a 'DeBruijnPattern'.---subPatterns :: DeBruijnPattern -> [DeBruijnPattern]---subPatterns = foldPattern $ \case--- ConP _ _ ps -> map namedArg ps--- DefP _ _ ps -> map namedArg ps -- TODO check semantics--- VarP _ _ -> mempty--- LitP _ -> mempty--- DotP _ _ -> mempty--- ProjP _ _ -> mempty--- IApplyP{} -> mempty-- compareTerm :: Term -> Masked DeBruijnPattern -> TerM Order compareTerm t p = do -- reportSDoc "term.compare" 25 $ -- " comparing term " <+> prettyTCM t <+> -- " to pattern " <+> prettyTCM p- t <- liftTCM $ stripAllProjections t- o <- compareTerm' t p+ o <- compareTerm' t =<< traverse reduceConPattern p liftTCM $ reportSDoc "term.compare" 25 $ " comparing term " <+> prettyTCM t <+> " to pattern " <+> prettyTCM p <+> text (" results in " ++ prettyShow o) return o ---- | Remove all non-coinductive projections from an algebraic term--- (not going under binders).--- Also, remove 'DontCare's.----class StripAllProjections a where- stripAllProjections :: a -> TCM a--instance StripAllProjections a => StripAllProjections (Arg a) where- stripAllProjections = traverse stripAllProjections--instance StripAllProjections Elims where- stripAllProjections es =- case es of- [] -> return []- (Apply a : es) -> do- (:) <$> (Apply <$> stripAllProjections a) <*> stripAllProjections es- (IApply x y a : es) -> do- -- TODO Andrea: are we doind extra work?- (:) <$> (IApply <$> stripAllProjections x- <*> stripAllProjections y- <*> stripAllProjections a)- <*> stripAllProjections es- (Proj o p : es) -> do- isP <- isProjectionButNotCoinductive p- applyUnless isP (Proj o p :) <$> stripAllProjections es--instance StripAllProjections Args where- stripAllProjections = mapM stripAllProjections--instance StripAllProjections Term where- stripAllProjections t = do- case t of- Var i es -> Var i <$> stripAllProjections es- Con c ci ts -> do- -- Andreas, 2019-02-23, re #2613. This is apparently not necessary:- -- c <- fromRightM (\ err -> return c) $ getConForm (conName c)- Con c ci <$> stripAllProjections ts- Def d es -> Def d <$> stripAllProjections es- DontCare t -> stripAllProjections t- _ -> return t- -- | Normalize outermost constructor name in a pattern. -reduceConPattern :: DeBruijnPattern -> TCM DeBruijnPattern+{-# SPECIALIZE reduceConPattern :: DeBruijnPattern -> TerM DeBruijnPattern #-}+reduceConPattern :: MonadTCM tcm => DeBruijnPattern -> tcm DeBruijnPattern reduceConPattern = \case- ConP c i ps -> fromRightM (\ err -> return c) (getConForm (conName c)) <&> \ c' ->+ ConP c i ps -> fromRightM (\ err -> return c) (liftTCM $ getConForm $ conName c) <&> \ c' -> ConP c' i ps p -> return p -- | @compareTerm' t dbpat@+--+-- Precondition: 'reduceConPattern' has been applied to the pattern. compareTerm' :: Term -> Masked DeBruijnPattern -> TerM Order compareTerm' v mp@(Masked m p) = do suc <- terGetSizeSuc cutoff <- terGetCutOff let ?cutoff = cutoff- v <- liftTCM (instantiate v)- p <- liftTCM $ reduceConPattern p+ -- v <- liftTCM (instantiate v) -- call extraction already instantiates metas in call arguments+ let fallback = return $ subTerm v p case (v, p) of -- Andreas, 2013-11-20 do not drop projections, -- in any case not coinductive ones!:- (Var i es, _) | Just{} <- allApplyElims es ->- compareVar i mp+ -- Andreas, 2025-11-05 we may drop all eliminations that are not coinductive projections.+ (Var i es, _) -> foldMap (All <.> elimNotCoinductive) es >>= \case+ All True -> compareVar i mp+ _ -> fallback (DontCare t, _) -> compareTerm' t mp@@ -1350,7 +1449,7 @@ -- Successor on both sides cancel each other. -- We ignore the mask for sizes. (Def s [Apply t], ConP s' _ [p]) | s == conName s' && Just s == suc ->- compareTerm' (unArg t) (notMasked $ namedArg p)+ compareTerm' (unArg t) . notMasked =<< reduceConPattern (namedArg p) -- Register also size increase. (Def s [Apply t], p) | Just s == suc ->@@ -1378,7 +1477,7 @@ decr True <$> offsetFromConstructor (conName c) (Con c _ es, ConP c' _ ps) | conName c == conName c'->- let ts = fromMaybe __IMPOSSIBLE__ $ allApplyElims es in+ let ts = mustAllApplyElims es in compareConArgs ts ps (Con _ _ [], _) -> return Order.le@@ -1386,21 +1485,21 @@ -- new case for counting constructors / projections -- register also increase (Con c _ es, _) -> do- let ts = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ let ts = mustAllApplyElims es increase <$> offsetFromConstructor (conName c) <*> (infimum <$> mapM (\ t -> compareTerm' (unArg t) mp) ts) - (t, p) -> return $ subTerm t p+ _ -> fallback -- | @subTerm@ computes a size difference (Order) subTerm :: (?cutoff :: CutOff) => Term -> DeBruijnPattern -> Order subTerm t p = if equal t p then Order.le else properSubTerm t p where equal (Con c _ es) (ConP c' _ ps) =- let ts = fromMaybe __IMPOSSIBLE__ $ allApplyElims es in+ let ts = mustAllApplyElims es in and $ (conName c == conName c') : (length ts == length ps)- : zipWith (\ t p -> equal (unArg t) (namedArg p)) ts ps+ : zipWith' (\ t p -> equal (unArg t) (namedArg p)) ts ps equal (Var i []) (VarP _ x) = i == dbPatVarIndex x equal (Lit l) (LitP _ l') = l == l' -- Terms.@@ -1411,7 +1510,7 @@ equal _ _ = False properSubTerm t (ConP _ _ ps) =- setUsability True $ decrease 1 $ supremum $ map (subTerm t . namedArg) ps+ setUsability True $ decrease 1 $ supremum $ map' (subTerm t . namedArg) ps properSubTerm _ _ = Order.unknown isSubTerm :: (?cutoff :: CutOff) => Term -> DeBruijnPattern -> Bool@@ -1432,7 +1531,7 @@ LT -> return Order.unknown EQ -> List.foldl' (Order..*.) Order.le <$>- zipWithM compareTerm' (map unArg ts) (map (notMasked . namedArg) ps)+ 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) {- version which does an "order matrix"@@ -1446,7 +1545,7 @@ -} {- version which takes height -- if null ts then Order.Le--- else Order.infimum (zipWith compareTerm' (map unArg ts) ps)+-- else Order.infimum (zipWith compareTerm' (map' unArg ts) ps) -} compareVar :: Nat -> Masked DeBruijnPattern -> TerM Order
src/full/Agda/Termination/Termination.hs view
@@ -14,11 +14,11 @@ , GuardednessHelps(..) , terminates , terminatesFilter- , endos- , idempotent+ , terminationCounterexample+ , idempotentEndos ) where -import Prelude hiding ((&&), null)+import Prelude hiding ((&&), not, null) import Control.DeepSeq (NFData) import GHC.Generics (Generic)@@ -61,35 +61,61 @@ -- -- This criterion is strictly more liberal than searching for a -- lexicographic order (and easier to implement, but harder to justify).-+--+-- 'terminates' does not use guardedness, 'terminatesFilter' is more general. terminates :: (Monoid cinfo, ?cutoff :: CutOff) => CallGraph cinfo -> Terminates cinfo-terminates = terminatesFilter $ const True+terminates = terminatesFilter False $ const True -terminatesFilter ::- (Monoid cinfo, ?cutoff :: CutOff)- => (Node -> Bool) -- ^ Only consider calls whose source and target satisfy this predicate.+-- | While no counterexample to termination is found,+-- complete the given call graph step-by-step.+terminatesFilter :: forall cinfo. (Monoid cinfo, ?cutoff :: CutOff)+ => Bool -- ^ Use guardedness?+ -> (Node -> Bool) -- ^ Only consider calls whose source and target satisfy this predicate. -> CallGraph cinfo -- ^ Callgraph augmented with @cinfo@. -> Terminates cinfo -- ^ A bad call path of type @cinfo@, if termination could not be proven.-terminatesFilter f cs+terminatesFilter useGuardedness f cs0 = loop (cs0, cs0)+ where+ loop :: (CallGraph cinfo, CallGraph cinfo) -> Terminates cinfo+ loop (new, cs)+ -- If we have no new calls, the call graph is complete,+ -- and we have not found a counterexample.+ | null new = Terminates+ -- Otherwise the new calls might contain a counterexample.+ | otherwise = case terminationCounterexample useGuardedness f new of+ -- If we have a counterexample already, we can stop the search for one.+ result@TerminatesNot{} -> result+ -- Otherwise, we continue to complete the call-graph one step and look again.+ Terminates -> loop $ completionStep cs0 cs++-- | Does the given callgraph contain a counterexample to termination?+terminationCounterexample :: (?cutoff :: CutOff)+ => Bool -- ^ Use guardedness?+ -> (Node -> Bool) -- ^ Only consider calls whose source and target satisfy this predicate.+ -> CallGraph cinfo -- ^ Callgraph augmented with @cinfo@.+ -> Terminates cinfo -- ^ A bad call path of type @cinfo@, if termination could not be proven.+terminationCounterexample useGuardedness f cs | cm:_ <- bad = TerminatesNot GuardednessHelpsNot $ augCallInfo cm- | cm:_ <- needGuardedness = TerminatesNot GuardednessHelpsYes $ augCallInfo cm+ | cm:_ <- needGuardedness+ , not useGuardedness = TerminatesNot GuardednessHelpsYes $ augCallInfo cm | otherwise = Terminates where- f' = f . source && f . target -- Every idempotent call must have decrease in the diagonal.- idems = filter idempotent $ endos $ filter f' $ toList $ complete cs+ (_good, needGuardedness, bad) = partitionEithers3 $ map hasDecr idems+ idems = idempotentEndosFilter f cs hasDecr cm = case diagonal cm of g : xs | any isDecr xs -> In1 () -- Evidence found without guardedness. | isDecr g -> In2 cm -- Evidence found in guardedness. | otherwise -> In3 cm -- No evidence found. [] -> In3 cm -- No information means no evidence for termination.- (good, needGuardedness, bad) = partitionEithers3 $ map hasDecr idems -endos :: [Call cinfo] -> [CallMatrixAug cinfo]-endos cs = [ m | c <- cs, source c == target c- , m <- CMSet.toList $ callMatrixSet c- ]+-- | Get all idempotent call-matrixes of loops in the call graph that match the given node-filter.+idempotentEndosFilter :: (?cutoff :: CutOff) => (Node -> Bool) -> CallGraph cinfo -> [CallMatrixAug cinfo]+idempotentEndosFilter f = filter idempotent . concatMap (CMSet.toList . snd) . filter (f . fst) . loops++-- | Get all idempotent call-matrixes of loops in the call graph.+idempotentEndos :: (?cutoff :: CutOff) => CallGraph cinfo -> [CallMatrixAug cinfo]+idempotentEndos = idempotentEndosFilter $ const True -- | A call @c@ is idempotent if it is an endo (@'source' == 'target'@) -- of order 1.
src/full/Agda/TypeChecking/Abstract.hs view
@@ -24,17 +24,18 @@ import Agda.TypeChecking.Conversion import Agda.TypeChecking.Constraints import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Primitive ( getRefl ) import Agda.TypeChecking.Sort import Agda.TypeChecking.Telescope import Agda.TypeChecking.Warnings ( warning ) import Agda.Utils.Functor-import Agda.Utils.List ( splitExactlyAt, dropEnd )+import Agda.Utils.List import Agda.Utils.Null import Agda.Utils.Impossible --- | @abstractType r a v b[v] = b@ where @a : v@.+-- | @abstractType r a v b[v] = b@ where @v : a@. abstractType :: Range -- ^ Range of the @rewrite@ expression, if any, otherwise empty. -> Type -- ^ Type of the term to abstract.@@ -68,15 +69,16 @@ -- | @piAbstract (v, a) b[v] = (w : a) -> b[w]@ -- -- For the inspect idiom, it does something special:--- @piAbstract (v, a) b[v] = (w : a) {w' : Eq a w v} -> b[w]+-- @piAbstract (v, a) b[v, refl v] = (w : a) (w' : Eq a w v) -> b[w, w']+-- (Not all @refl v@ subterms are abstracted: see caveat below.) -- -- For @rewrite@, it does something special:--- @piAbstract (prf, Eq a v v') b[v,prf] = (w : a) (w' : Eq a w v') -> b[w,w']@+-- @piAbstract (prf, Eq a v v') b[v,prf] = (w : a) (w' : Eq a w v') -> b[w, w']@ piAbstract :: Arg (Term, EqualityView) -> Type -> TCM Type piAbstract (Arg info (v, OtherType a)) b = piAbstractTerm info v a b piAbstract (Arg info (v, IdiomType a)) b = do- b <- raise 1 <$> abstractType empty a v b+ refl <- getRefl eq <- addContext ("w" :: String, defaultDom a) $ do -- manufacture the type @w ≡ v@ eqName <- primEqualityName@@ -84,14 +86,13 @@ -- E.g. @eqTy = eqTel → Set a@ where @eqTel = {a : Level} {A : Set a} (x y : A)@. TelV eqTel _ <- telView eqTy tel <- newTelMeta (telFromList $ dropEnd 3 $ telToList eqTel)- let eq = Def eqName $ map Apply- $ map (setHiding Hidden) tel+ let !eq = Def eqName $! map' Apply $! map' (setHiding Hidden) tel -- we write `v ≡ w` because this equality is typically used to -- get `v` to unfold to whatever pattern was used to refine `w` -- in a with-clause. -- If we were to write `w ≡ v`, we would often need to take the -- symmetric of the proof we get to make use of `rewrite`.- ++ [ setHiding Hidden $ defaultArg $ raise 1 $ unEl a+ ++! [ setHiding Hidden $ defaultArg $ raise 1 $ unEl a , defaultArg (raise 1 v) , defaultArg (var 0) ]@@ -101,6 +102,13 @@ sort <- newSortMeta return $ El sort eq + -- ncf, 2026-01-12: we abstract over v as w first, then over @refl w@+ -- at type @v ≡ w@ so that we only replace those @refl v@ subterms of+ -- the original term that become ill-typed after abstracting v.+ b <- abstractType empty a v b+ b <- addContext ("w" :: String, defaultDom a) $+ abstractType empty eq (refl (defaultArg (var 0))) b+ pure $ mkPi (setHiding (getHiding info) $ defaultDom ("w", a)) $ mkPi (setHiding NotHidden $ defaultDom ("eq", eq)) $ b@@ -141,7 +149,7 @@ isPrefixOf us vs = do (vs1, vs2) <- splitExactlyAt (length us) vs guard $ equalSy us vs1- return $ map Apply vs2+ return $! map' Apply vs2 instance IsPrefixOf Term where isPrefixOf u v =@@ -152,7 +160,11 @@ (MetaV x us, MetaV y vs) | x == y -> us `isPrefixOf` vs (u, v) -> guard (equalSy u v) >> return [] --- Type-based abstraction. Needed if u is a constructor application (#745).+-- Type-based abstraction. Needed if @u@ is a constructor application (#745, fix of #5833).+-- Note that @a@ is the type of the new variable, not necessarily the+-- type of @u@: this allows the inspect idiom to abstract over ill-typed+-- subterms of the form @refl w : w ≡ v@ created by abstracting over @v@+-- (see 'piAbstract'). abstractTerm :: Type -> Term -> Type -> Term -> TCM Term abstractTerm a u@Con{} b v = do reportSDoc "tc.abstract" 50 $@@ -169,7 +181,7 @@ hole <- qualify <$> currentModule <*> freshName_ ("hole" :: String) noMutualBlock $ addConstant' hole defaultArgInfo a defaultAxiom - args <- map Apply <$> getContextArgs+ args <- map' Apply <$> getContextArgs let n = length args let abstr b v = do@@ -181,7 +193,7 @@ s <- getTC do noConstraints $ equalType a' b putTC s- return $ Def hole (raise (m - n) args ++ es)+ return $! Def hole $! raise (m - n) args ++! es `catchError` \ _ -> do reportSDoc "tc.abstract.ill-typed" 50 $ sep [ "Skipping ill-typed abstraction"@@ -193,7 +205,7 @@ -- abstracting the second component). In this case we skip abstraction -- altogether and let the type check of the final with-function type produce -- the error message.- res <- catchError_ (checkInternal' (defaultAction { preAction = abstr }) v CmpLeq b) $ \ err -> do+ res <- catchError_ (withFrozenMetas $ checkInternal' (defaultAction { preAction = abstr }) v CmpLeq b) $ \ err -> do reportSDoc "tc.abstract.ill-typed" 40 $ "Skipping typed abstraction over ill-typed term" <?> (prettyTCM v <?> (":" <+> prettyTCM b)) return v@@ -213,20 +225,20 @@ instance AbsTerm Term where absTerm j u v- | Just es <- u `isPrefixOf` v = Var j $ absT es+ | Just es <- u `isPrefixOf` v = Var j $! absT es | otherwise = case v of -- Andreas, 2013-10-20: the original impl. works only at base types -- v | u == v -> Var j [] -- incomplete see succeed/WithOfFunctionType- Var i vs -> Var (if i < j then i else i + 1) $ absT vs+ Var i vs -> (Var $! if i < j then i else i + 1) $! absT vs Lam h b -> Lam h $ absT b- Def c vs -> Def c $ absT vs- Con c ci vs -> Con c ci $ absT vs+ Def c vs -> Def c $! absT vs+ Con c ci vs -> Con c ci $! absT vs Pi a b -> uncurry Pi $ absT (a, b) Lit l -> Lit l Level l -> Level $ absT l Sort s -> Sort $ absT s- MetaV m vs -> MetaV m $ absT vs+ MetaV m vs -> MetaV m $! absT vs DontCare mv -> DontCare $ absT mv Dummy s es -> Dummy s $ absT es where@@ -244,13 +256,14 @@ LockUniv -> LockUniv LevelUniv -> LevelUniv IntervalUniv -> IntervalUniv- PiSort a s1 s2 -> PiSort (absS a) (absS s1) (absS s2)+ PiSort c a s1 s2 -> PiSort c (absS a) (absS s1) (absS s2) FunSort s1 s2 -> FunSort (absS s1) (absS s2) UnivSort s -> UnivSort $ absS s- MetaS x es -> MetaS x $ absS es- DefS d es -> DefS d $ absS es+ MetaS x es -> MetaS x $! absS es+ DefS d es -> DefS d $! absS es s@DummyS{} -> s where+ {-# INLINE absS #-} absS :: AbsTerm b => b -> b absS x = absTerm j u x @@ -270,7 +283,7 @@ absTerm j = fmap . absTerm j instance AbsTerm a => AbsTerm [a] where- absTerm j = fmap . absTerm j+ absTerm j u as = map' (absTerm j u) as instance AbsTerm a => AbsTerm (Maybe a) where absTerm j = fmap . absTerm j@@ -297,7 +310,9 @@ equalSy :: a -> a -> Bool instance EqualSy a => EqualSy [a] where- equalSy us vs = and $ (length us == length vs) : zipWith equalSy us vs+ equalSy [] [] = True+ equalSy (x:xs) (y:ys) = equalSy x y && equalSy xs ys+ equalSy _ _ = False instance EqualSy Term where equalSy = curry $ \case@@ -328,7 +343,8 @@ (Inf u m , Inf u' n ) -> u == u' && m == n (SizeUniv , SizeUniv ) -> True (LevelUniv , LevelUniv ) -> True- (PiSort a b c, PiSort a' b' c') -> equalSy a a' && equalSy b b' && equalSy c c'+ (PiSort a b c d, PiSort a' b' c' d') ->+ equalSy a a' && equalSy b b' && equalSy c c' && equalSy d d' (FunSort a b, FunSort a' b') -> equalSy a a' && equalSy b b' (UnivSort a, UnivSort a' ) -> equalSy a a' (MetaS x es, MetaS x' es') -> x == x' && equalSy es es'@@ -337,6 +353,12 @@ (_ , DummyS{} ) -> __IMPOSSIBLE__ _ -> False +instance EqualSy a => EqualSy (BlockedDepCheck a) where+ equalSy = curry \case+ (CodomainSortOld s, CodomainSortOld s') -> equalSy s s'+ (CodomainSortSame, CodomainSortSame) -> True+ _ -> False+ -- | Ignores sorts. instance EqualSy Type where equalSy = equalSy `on` unEl@@ -354,7 +376,8 @@ -- | Ignores 'absName'. instance (Subst a, EqualSy a) => EqualSy (Abs a) where equalSy = curry $ \case- (NoAbs _x b, NoAbs _x' b') -> equalSy b b' -- no need to raise if both are NoAbs+ (NoAbs _x b, NoAbs _x' b') -> equalSy b b'+ (Abs _ b , Abs _ b' ) -> equalSy b b' (a , a' ) -> equalSy (absBody a) (absBody a') -- | Ignore origin and free variables.@@ -362,9 +385,9 @@ equalSy (ArgInfo h m _o _fv a) (ArgInfo h' m' _o' _fv' a') = h == h' && m == m' && a == a' --- | Ignore the tactic.+-- | Ignore the tactic and rewrite. instance EqualSy a => EqualSy (Dom a) where- equalSy d@(Dom ai x f _tac a) d'@(Dom ai' x' f' _tac' a') = and+ equalSy d@(Dom ai x f _tac _rew a) d'@(Dom ai' x' f' _tac' _rew' a') = and [ x == x' , f == f' , equalSy ai ai'
src/full/Agda/TypeChecking/CheckInternal.hs view
@@ -9,8 +9,7 @@ -- have to be reduced since they break bidirectionality. module Agda.TypeChecking.CheckInternal- ( MonadCheckInternal- , checkType, infer, inferSpine+ ( checkType, infer, inferSpine , CheckInternal(..) , Action(..), defaultAction, eraseUnusedAction ) where@@ -26,7 +25,7 @@ import Agda.TypeChecking.Level import Agda.TypeChecking.Monad import Agda.TypeChecking.Pretty-import Agda.TypeChecking.ProjectionLike (elimView, ProjEliminator(..))+import Agda.TypeChecking.ProjectionLike (elimView, LoneProjectionLikeToLambda(..)) import Agda.TypeChecking.Records (shouldBeProjectible) import Agda.TypeChecking.Substitute import Agda.TypeChecking.Sort@@ -36,46 +35,44 @@ import Agda.Utils.Functor (($>)) import Agda.Utils.Maybe import Agda.Utils.Size+import Agda.Utils.Tuple (fst3, snd3) import Agda.Utils.Impossible import Agda.Interaction.Options+import Agda.TypeChecking.Reduce (instantiate) -- * Bidirectional rechecker -type MonadCheckInternal m = MonadConversion m--{-# SPECIALIZE checkType :: Type -> TCM () #-} -- | Entry point for e.g. checking WithFunctionType.-checkType :: (MonadCheckInternal m) => Type -> m ()+checkType :: Type -> TCM () checkType t = catchConstraint (CheckType t) $ inferInternal t -- | 'checkInternal' traverses the whole 'Term', and we can use this -- traversal to modify the term.-data Action m = Action- { preAction :: Type -> Term -> m Term+data Action = Action+ { preAction :: Type -> Term -> TCM Term -- ^ Called on each subterm before the checker runs.- , postAction :: Type -> Term -> m Term+ , postAction :: Type -> Term -> TCM Term -- ^ Called on each subterm after the type checking. , modalityAction :: Modality -> Modality -> Modality -- ^ Called for each @ArgInfo@. -- The first 'Modality' is from the type, -- the second from the term.- , elimViewAction :: Term -> m Term+ , elimViewAction :: Term -> TCM Term -- ^ Called for bringing projection-like funs in post-fix form } -- | The default action is to not change the 'Term' at all.-defaultAction :: PureTCM m => Action m---(MonadReduce m, MonadTCEnv m, HasConstInfo m) => Action m+defaultAction :: Action defaultAction = Action { preAction = \ _ -> return , postAction = \ _ -> return , modalityAction = \ _ -> id- , elimViewAction = elimView EvenLone+ , elimViewAction = elimView LoneProjectionLikeToLambda } -eraseUnusedAction :: Action TCM+eraseUnusedAction :: Action eraseUnusedAction = defaultAction { postAction = eraseUnused } where eraseUnused :: Type -> Term -> TCM Term@@ -92,32 +89,40 @@ eraseIfNonvariant (_ : pols) (e : es) = e : eraseIfNonvariant pols es class CheckInternal a where- checkInternal' :: (MonadCheckInternal m) => Action m -> a -> Comparison -> TypeOf a -> m a+ checkInternal' :: Action -> a -> Comparison -> TypeOf a -> TCM a - checkInternal :: (MonadCheckInternal m) => a -> Comparison -> TypeOf a -> m ()+ checkInternal :: a -> Comparison -> TypeOf a -> TCM () checkInternal v cmp t = void $ checkInternal' defaultAction v cmp t - inferInternal' :: (MonadCheckInternal m, TypeOf a ~ ()) => Action m -> a -> m a+ inferInternal' :: (TypeOf a ~ ()) => Action -> a -> TCM a inferInternal' act v = checkInternal' act v CmpEq () - inferInternal :: (MonadCheckInternal m, TypeOf a ~ ()) => a -> m ()+ inferInternal :: (TypeOf a ~ ()) => a -> TCM () inferInternal v = checkInternal v CmpEq () -{-# SPECIALIZE checkInternal' :: Action TCM -> Term -> Comparison -> TypeOf Term -> TCM Term #-}-{-# SPECIALIZE checkInternal' :: Action TCM -> Type -> Comparison -> TypeOf Type -> TCM Type #-}-{-# SPECIALIZE checkInternal' :: Action TCM -> Elims -> Comparison -> TypeOf Type -> TCM Elims #-}-{-# SPECIALIZE checkInternal :: Term -> Comparison -> TypeOf Term -> TCM () #-}-{-# SPECIALIZE checkInternal :: Type -> Comparison -> TypeOf Type -> TCM () #-} instance CheckInternal Type where checkInternal' action (El s t) cmp _ = do+ reportSDoc "tc.check.internal" 20 $ sep+ [ "checking internal type "+ , nest 2 $ sep [ prettyTCM t <+> ":"+ , nest 2 $ prettyTCM s ]+ ] t' <- checkInternal' action t cmp (sort s)- s' <- sortOf t'- compareSort cmp s' s+ -- Nathaniel, 2026-10-25: We used to reinfer the sort and check against it+ -- here, but @checkInternal'@ for @Term@ should already check the sort, so+ -- this was redundant+ --+ -- s' <- sortOf t'+ -- reportSDoc "tc.check.internal" 30 $+ -- "checking if sort" <+> prettyTCM s' <+>+ -- "of" <+> prettyTCM t' <+>+ -- "fits in given sort" <+> prettyTCM s+ -- compareSort cmp s' s return (El s t') instance CheckInternal Term where- checkInternal' :: (MonadCheckInternal m) => Action m -> Term -> Comparison -> Type -> m Term+ checkInternal' :: Action -> Term -> Comparison -> Type -> TCM Term checkInternal' action v cmp t = verboseBracket "tc.check.internal" 20 "" $ do -- Debug print@@ -149,15 +154,17 @@ -- (commented below) -- but this will break stuff that is allowed right now + reportSDoc "tc.check.internal" 30 $ fsep+ [ "variable" , prettyTCM (var i) , "has type" , prettyTCM (unDom d)+ , "and modality", pretty (getModality d)+ ]+ unless (usableCohesion d) $ typeError $ VariableIsOfUnusableCohesion n (getCohesion d) unless (usablePolarity d) $ typeError $ VariableIsOfUnusablePolarity n (getModalPolarity d) - reportSDoc "tc.check.internal" 30 $ fsep- [ "variable" , prettyTCM (var i) , "has type" , prettyTCM (unDom d)- , "and modality", pretty (getModality d) ] checkSpine action (unDom d) (Var i) es cmp t Def f es -> do -- f is not projection(-like)! -- There is no "implicitely applied module telescope" at this stage, so no@@ -207,13 +214,29 @@ 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 -- Issue #6205: do not use v' since it might not be valid syntax- compareSort cmp s' s+ reportSDoc "tc.check.internal" 30 $+ "checking if sort" <+> prettyTCM s' <+>+ "of pi type" <+> prettyTCM v <+>+ "fits in given sort" <+> prettyTCM s+ -- Pi types do not contain enough information to reconstruct their+ -- sort uniquely. Specifically, the pi might have originally been+ -- level-dependent and so ended up in Setω, but now that level+ -- dependency has vanished (in an ideal world we would track the+ -- fact the pi is level dependent in the pi type itself, but+ -- we do not live in an ideal world).+ -- Therefore, the double checker needs to check pi sorts in a relaxed.+ -- way. For simplicity, we over-approximate this by using 'CmpLeq'.+ compareSort CmpLeq s' s return v' Sort s -> do reportSDoc "tc.check.internal" 30 $ "checking sort" <+> prettyTCM s s <- inferInternal' action s s' <- inferUnivSort s s'' <- shouldBeSort t+ reportSDoc "tc.check.internal" 30 $+ "checking if sort" <+> prettyTCM s' <+>+ "of universe type" <+> prettyTCM v <+>+ "fits in" <+> prettyTCM t compareSort cmp s' s'' return $ Sort s Level l -> do@@ -231,19 +254,19 @@ -- The @expected@ 'ArgInfo' comes from the type. -- The @actual@ 'ArgInfo' comes from the term and can be updated -- by an action.-checkArgInfo :: (MonadCheckInternal m) => Action m -> ArgInfo -> ArgInfo -> m ArgInfo+checkArgInfo :: Action -> ArgInfo -> ArgInfo -> TCM ArgInfo checkArgInfo action ai ai' = do checkHiding (getHiding ai) (getHiding ai') mod <- checkModality action (getModality ai) (getModality ai') return $ setModality mod ai -checkHiding :: (MonadCheckInternal m) => Hiding -> Hiding -> m ()+checkHiding :: Hiding -> Hiding -> TCM () checkHiding h h' = unless (sameHiding h h') $ typeError $ HidingMismatch h h' -- | @checkRelevance action term type@. -- -- The @term@ 'Relevance' can be updated by the @action@.-checkModality :: (MonadCheckInternal m) => Action m -> Modality -> Modality -> m Modality+checkModality :: Action -> Modality -> Modality -> TCM Modality checkModality action mod mod' = do let (r,r') = (getRelevance mod, getRelevance mod') (q,q') = (getQuantity mod, getQuantity mod')@@ -253,22 +276,21 @@ | otherwise -> __IMPOSSIBLE__ -- add more cases when adding new modalities return $ modalityAction action mod' mod -- Argument order for actions: @type@ @term@ -{-# SPECIALIZE infer :: Term -> TCM Type #-} -- | Infer type of a neutral term.-infer :: (MonadCheckInternal m) => Term -> m Type+infer :: Term -> TCM Type infer u = do reportSDoc "tc.check.internal" 20 $ "CheckInternal.infer" <+> prettyTCM u case u of Var i es -> do a <- typeOfBV i- fst <$> inferSpine defaultAction a (Var i) es+ fst3 <$> inferSpine defaultAction a (Var i) es Def f es -> do whenJustM (isRelevantProjection f) $ \_ -> nonInferable a <- defType <$> getConstInfo f- fst <$> inferSpine defaultAction a (Def f) es+ fst3 <$> inferSpine defaultAction a (Def f) es MetaV x es -> do -- we assume meta instantiations to be well-typed a <- metaType x- fst <$> inferSpine defaultAction a (MetaV x) es+ fst3 <$> inferSpine defaultAction a (MetaV x) es _ -> nonInferable where nonInferable :: MonadDebug m => m a@@ -278,17 +300,24 @@ ] instance CheckInternal Elims where- checkInternal' action es cmp (t , hd) = snd <$> inferSpine action t hd es+ checkInternal' action es cmp (t , hd) = snd3 <$> inferSpine action t hd es -{-# SPECIALIZE inferSpine :: Action TCM -> Type -> (Elims -> Term) -> Elims -> TCM (Type, Elims) #-} -- | @inferSpine action t hd es@ checks that spine @es@ eliminates -- value @hd []@ of type @t@ and returns the remaining type--- (target of elimination) and the transformed eliminations.-inferSpine :: (MonadCheckInternal m) => Action m -> Type -> (Elims -> Term) -> Elims -> m (Type, Elims)-inferSpine action t hd es = loop t hd id es+-- (target of elimination), the transformed eliminations, and the+-- transformed term.+--+-- The transformed term is /not/ simply @hd@ applied to the transformed+-- eliminations: 'elimViewAction' brings prefix applications of+-- projection-like functions into post-fix form, and that has to be undone+-- when rebuilding the term, or we hand back a term in a representation+-- the conversion checker cannot relate to the original one+-- (issues #8336 and #8771).+inferSpine :: Action -> Type -> (Elims -> Term) -> Elims -> TCM (Type, Elims, Term)+inferSpine action t hd es = loop t hd id hd es where- loop t hd acc = \case- [] -> return (t , acc [])+ loop t hd accEs accTm = \case+ [] -> return (t , accEs [] , accTm []) (e : es) -> do let self = hd [] reportSDoc "tc.check.internal" 30 $ sep@@ -306,28 +335,34 @@ x' <- checkInternal' action x CmpLeq (b `absApp` izero) y' <- checkInternal' action y CmpLeq (b `absApp` ione) let e' = IApply x' y' r'- loop (b `absApp` r) (hd . (e:)) (acc . (e':)) es+ loop (b `absApp` r) (hd . (e:)) (accEs . (e':)) (accTm . (e':)) es Apply (Arg ai v) -> do (a, b) <- shouldBePi t ai <- checkArgInfo action ai $ domInfo a- v' <- applyModalityToContext (getModality a) $ checkInternal' action v CmpLeq $ unDom a+ v' <- applyDomToContext a $ checkInternal' action v CmpLeq $ unDom a let e' = Apply (Arg ai v')- loop (b `absApp` v) (hd . (e:)) (acc . (e':)) es+ loop (b `absApp` v) (hd . (e:)) (accEs . (e':)) (accTm . (e':)) es -- case: projection or projection-like Proj o f -> do t' <- shouldBeProjectible self t o f- loop t' (hd . (e:)) (acc . (e:)) es+ -- Jesper, issue #8336: turn projection-like functions back into Defs.+ -- Andreas, issue #8771: this has to happen for the transformed term+ -- as well, not just for @hd@, or the two get out of sync.+ proj <- fromMaybe __IMPOSSIBLE__ <$> isProjection f+ let applyProj :: (Elims -> Term) -> (Elims -> Term)+ applyProj h+ | isProperProjection_ proj = h . (e:)+ | otherwise = Def f . (Apply (projFromType proj $> h []) :)+ loop t' (applyProj hd) (accEs . (e:)) (applyProj accTm) es -{-# SPECIALIZE checkSpine :: Action TCM -> Type -> (Elims -> Term) -> Elims -> Comparison -> Type -> TCM Term #-}-checkSpine- :: (MonadCheckInternal m)- => Action m+checkSpine ::+ Action -> Type -- ^ Type of the head @self@. -> (Elims -> Term) -- ^ The head @hd@. -> Elims -- ^ The eliminations @es@. -> Comparison -- ^ Check (@CmpLeq@) or infer (@CmpEq@) the final type. -> Type -- ^ Expected type of the application @self es@.- -> m Term -- ^ The application after modification by the @Action@.+ -> TCM Term -- ^ The application after modification by the @Action@. checkSpine action a hd es cmp t = do reportSDoc "tc.check.internal" 20 $ sep [ "checking spine "@@ -335,9 +370,21 @@ , nest 2 $ prettyTCM a ]) , nest 4 $ prettyTCM es <+> ":" , nest 2 $ prettyTCM t ] ]- (t' , es') <- inferSpine action a hd es- coerceSize (compareType cmp) (hd es) t' t- return $ hd es'+ (t' , _es' , v') <- inferSpine action a hd es+ reportSDoc "tc.check.internal" 30 $ sep+ [ "checking if "+ , prettyTCM t'+ , "is a subtype of"+ , prettyTCM t+ ]+ reportSDoc "tc.check.internal" 70 $ sep+ [ "checking if (raw)"+ , pretty =<< instantiate t'+ , "is a subtype of (raw)"+ , pretty =<< instantiate t+ ]+ coerceSize cmp (hd es) t' t+ return v' instance CheckInternal Sort where checkInternal' action s cmp _ = case s of@@ -347,13 +394,13 @@ LockUniv -> return LockUniv LevelUniv -> return LevelUniv IntervalUniv -> return IntervalUniv- PiSort dom s1 s2 -> do+ PiSort c dom s1 s2 -> do let a = unDom dom s1' <- inferInternal' action s1 a' <- checkInternal' action a CmpLeq $ sort s1' let dom' = dom $> a' s2' <- mapAbstraction (El s1' <$> dom') (inferInternal' action) s2- return $ PiSort dom' s1' s2'+ return $ PiSort c dom' s1' s2' FunSort s1 s2 -> do s1' <- inferInternal' action s1 s2' <- inferInternal' action s2
src/full/Agda/TypeChecking/CheckInternal.hs-boot view
@@ -1,43 +1,28 @@+ {-# OPTIONS_GHC -Wunused-imports #-} {-# LANGUAGE KindSignatures #-} module Agda.TypeChecking.CheckInternal where -import Control.Monad.Except--import qualified Data.Kind as Hs- import Agda.Syntax.Internal import Agda.TypeChecking.Monad-import Agda.TypeChecking.Warnings -type MonadCheckInternal m =- ( PureTCM m- , MonadConstraint m- , MonadMetaSolver m- , MonadError TCErr m- , MonadWarning m- , MonadStatistics m- , MonadFresh ProblemId m- , MonadFresh Int m- )--data Action (m :: Hs.Type -> Hs.Type)+data Action -defaultAction :: PureTCM m => Action m-eraseUnusedAction :: Action TCM+defaultAction :: Action+eraseUnusedAction :: Action class CheckInternal a where- checkInternal' :: (MonadCheckInternal m) => Action m -> a -> Comparison -> TypeOf a -> m a+ checkInternal' :: Action -> a -> Comparison -> TypeOf a -> TCM a - checkInternal :: (MonadCheckInternal m) => a -> Comparison -> TypeOf a -> m ()+ checkInternal :: a -> Comparison -> TypeOf a -> TCM () checkInternal v cmp t = void $ checkInternal' defaultAction v cmp t - inferInternal' :: (MonadCheckInternal m, TypeOf a ~ ()) => Action m -> a -> m a+ inferInternal' :: (TypeOf a ~ ()) => Action -> a -> TCM a inferInternal' act v = checkInternal' act v CmpEq () - inferInternal :: (MonadCheckInternal m, TypeOf a ~ ()) => a -> m ()+ inferInternal :: (TypeOf a ~ ()) => a -> TCM () inferInternal v = checkInternal v CmpEq () instance CheckInternal Term@@ -46,5 +31,5 @@ instance CheckInternal Level instance CheckInternal Elims -checkType :: (MonadCheckInternal m) => Type -> m ()-infer :: (MonadCheckInternal m) => Term -> m Type+checkType :: Type -> TCM ()+infer :: Term -> TCM Type
src/full/Agda/TypeChecking/CompiledClause.hs view
@@ -14,7 +14,7 @@ import qualified Data.Map as Map import Data.Map (Map)-import Data.Semigroup hiding (Arg(..))+import Data.Semigroup (Any(..)) import GHC.Generics (Generic) @@ -29,53 +29,72 @@ import Agda.Utils.Impossible +-- | The number of a 'Clause' (starting with 0) in the clause list of a 'FunctionData'.+type ClauseNumber = Int+ data WithArity c = WithArity { arity :: Int, content :: c } deriving (Functor, Foldable, Traversable, Show, Generic) -- | Branches in a case tree. data Case c = Branches- { projPatterns :: Bool+ { projPatterns :: !Bool -- ^ We are constructing a record here (copatterns). -- 'conBranches' lists projections.- , conBranches :: Map QName (WithArity c)+ , conBranches :: !(Map QName (WithArity c)) -- ^ Map from constructor (or projection) names to their arity -- and the case subtree. (Projections have arity 0.)- , etaBranch :: Maybe (ConHead, WithArity c)+ , etaBranch :: !(Maybe (ConHead, WithArity c)) -- ^ Eta-expand with the given (eta record) constructor. If this is -- present, there should not be any conBranches or litBranches.- , litBranches :: Map Literal c+ , litBranches :: !(Map Literal c) -- ^ Map from literal to case subtree.- , catchallBranch :: Maybe c+ , catchallBranch :: !(Maybe c) -- ^ (Possibly additional) catch-all clause.- , fallThrough :: Maybe Bool+ , fallThrough :: !(Maybe Bool) -- ^ (if True) In case of non-canonical argument use catchallBranch.- , lazyMatch :: Bool+ , lazyMatch :: !Bool -- ^ Lazy pattern match. Requires single (non-copattern) branch with no lit -- branches and no catch-all. } deriving (Functor, Foldable, Traversable, Show, Generic) +type CompiledClauses = CompiledClauses' Term+ -- | Case tree with bodies. data CompiledClauses' a- = Case (Arg Int) (Case (CompiledClauses' a))+ = Case !(Arg Int) !(Case (CompiledClauses' a)) -- ^ @Case n bs@ stands for a match on the @n@-th argument -- (counting from zero) with @bs@ as the case branches. -- If the @n@-th argument is a projection, we have only 'conBranches' -- with arity 0.- | Done [Arg ArgName] a- -- ^ @Done xs b@ stands for the body @b@ where the @xs@ contains hiding- -- and name suggestions for the free variables. This is needed to build- -- lambdas on the right hand side for partial applications which can- -- still reduce.- | Fail [Arg ArgName]+ | Done_ !(CCDone a)+ | 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 (Functor, Traversable, Foldable, Show, Generic) -type CompiledClauses = CompiledClauses' Term+{-# COMPLETE Case, Done, Fail #-} +-- | Data stored in 'Done' nodes of the case tree.+-- @CCDone no mr xs b@ stands for the body @b@ where the @xs@ contains hiding+-- and name suggestions for the free variables. This is needed to build+-- lambdas on the right hand side for partial applications which can+-- still reduce.+-- The @no@ is the number of the original 'Clause' this case tree leaf comes from.+-- @mr@ tells whether this body contains calls to the mutually recursive functions.+data CCDone a = CCDone+ { ccClauseNumber :: !ClauseNumber+ , ccClauseRecursive :: !ClauseRecursive+ , ccBoundVars :: ![Arg ArgName]+ , ccBody :: a+ }+ deriving (Functor, Traversable, Foldable, Show, Generic)++pattern Done :: ClauseNumber -> ClauseRecursive -> [Arg ArgName] -> a -> CompiledClauses' a+pattern Done no mr xs b = Done_ (CCDone no mr xs b)+ litCase :: Literal -> c -> Case c litCase l x = Branches False Map.empty Nothing (Map.singleton l x) Nothing (Just False) False @@ -120,12 +139,30 @@ Done{} -> mempty Case _ br -> Any (projPatterns br) <> foldMap loop br +---------------------------------------------------------------------------+-- * Traversing the 'Done' leaves++class MapDone f where+ mapDone :: (CCDone a -> CCDone b) -> f a -> f b++-- instance MapDone CCDone where+-- mapDone = id++instance MapDone CompiledClauses' where+ mapDone f = \case+ Case n bs -> Case n $ fmap (mapDone f) bs+ Done_ done -> Done_ $ f done+ Fail xs -> Fail xs++---------------------------------------------------------------------------+-- Collection instances+ instance Semigroup c => Semigroup (WithArity c) where WithArity n1 c1 <> WithArity n2 c2 | n1 == n2 = WithArity n1 (c1 <> c2) | otherwise = __IMPOSSIBLE__ -- arity must match! -instance (Semigroup c, Monoid c) => Monoid (WithArity c) where+instance (Monoid c) => Monoid (WithArity c) where mempty = WithArity __IMPOSSIBLE__ mempty mappend = (<>) @@ -147,7 +184,7 @@ unionEta b Nothing = b unionEta Just{} Just{} = __IMPOSSIBLE__ -instance (Semigroup m, Monoid m) => Monoid (Case m) where+instance (Monoid m) => Monoid (Case m) where mempty = empty mappend = (<>) @@ -155,7 +192,8 @@ empty = Branches False Map.empty Nothing Map.empty Nothing Nothing True null (Branches _cop cs eta ls mcatch _b _lazy) = null cs && null eta && null ls && null mcatch --- * Pretty instances.+---------------------------------------------------------------------------+-- Pretty instances instance Pretty a => Pretty (WithArity a) where pretty = pretty . content@@ -174,9 +212,9 @@ prettyMap_ :: (Pretty k, Pretty v) => Map k v -> [Doc] prettyMap_ = map prettyAssign . Map.toList -instance Pretty CompiledClauses where- pretty (Done hs t) = ("done" <> pretty hs) <?> pretty t- pretty Fail{} = "fail"+instance Pretty a => Pretty (CompiledClauses' a) where+ pretty (Done_ done) = pretty done+ pretty Fail{} = "fail" pretty (Case n bs) | projPatterns bs = sep [ "record" , nest 2 $ pretty bs@@ -184,8 +222,12 @@ pretty (Case n bs) = text ("case " ++ prettyShow n ++ " of") <?> pretty bs --- * KillRange instances.+instance Pretty a => Pretty (CCDone a) where+ pretty (CCDone no mr xs t) = ("done" <+> (pretty no <> pretty mr <> ":") <+> pretty xs) <?> prettyPrec 10 t +---------------------------------------------------------------------------+-- KillRange instances+ instance KillRange c => KillRange (WithArity c) where killRange = fmap killRange @@ -198,11 +240,12 @@ b lazy instance KillRange CompiledClauses where- killRange (Case i br) = killRangeN Case i br- killRange (Done xs v) = killRangeN Done xs v- killRange (Fail xs) = killRangeN Fail xs+ killRange (Case i br) = killRangeN Case i br+ killRange (Done no mr xs v) = killRangeN Done no mr xs v+ killRange (Fail xs) = killRangeN Fail xs --- * TermLike instances+---------------------------------------------------------------------------+-- TermLike instances instance TermLike a => TermLike (WithArity a) where traverseTermM = traverse . traverseTermM@@ -216,8 +259,14 @@ traverseTermM = traverse . traverseTermM foldTerm = foldMap . foldTerm +instance TermLike a => TermLike (CCDone a) where+ traverseTermM = traverse . traverseTermM+ foldTerm = foldMap . foldTerm++--------------------------------------------------------------------------- -- NFData instances instance NFData c => NFData (WithArity c) instance NFData a => NFData (Case a) instance NFData a => NFData (CompiledClauses' a)+instance NFData a => NFData (CCDone a)
src/full/Agda/TypeChecking/CompiledClause/Compile.hs view
@@ -42,7 +42,7 @@ -- Throw away the unreachable clauses (#2723). let notUnreachable = (Just True /=) . clauseUnreachable- cs <- map unBruijn <$> normaliseProjP (filter notUnreachable cs)+ cs <- map' unBruijn <$> normaliseProjP (filter (notUnreachable . snd) $ zip' [0..] cs) let translate | recpat == RunRecordPatternTranslation = runIdentityT . translateCompiledClauses q | otherwise = return@@ -66,7 +66,7 @@ -- Construct clauses with pattern variables bound in left-to-right order. -- Discard de Bruijn indices in patterns. case mt of- Nothing -> (Nothing,False,) . compile . map unBruijn <$> normaliseProjP cs+ Nothing -> (Nothing,False,) . compile . map' unBruijn . zip' [0..] <$> normaliseProjP cs Just (q, t) -> do splitTree <- coverageCheck q t cs @@ -78,13 +78,13 @@ -- The coverage checker might have added some clauses (#2288)! -- Throw away the unreachable clauses (#2723). let notUnreachable = (Just True /=) . clauseUnreachable- cs <- normaliseProjP =<< instantiateFull =<< filter notUnreachable . defClauses <$> getConstInfo q+ cs <- normaliseProjP =<< instantiateFull =<< filter (notUnreachable . snd) . zip' [0..] . defClauses <$> getConstInfo q - let cls = map unBruijn cs+ let cls = map' unBruijn cs reportSDoc "tc.cc" 30 $ sep $ do ("clauses patterns of " <+> prettyTCM q <+> " before compilation") : do- map (prettyTCM . map unArg . clPats) cls+ map' (prettyTCM . map' unArg . clPats) cls reportSDoc "tc.cc" 50 $ "clauses of " <+> prettyTCM q <+> " before compilation" <?> pretty cs @@ -105,21 +105,27 @@ -- | Stripped-down version of 'Agda.Syntax.Internal.Clause' -- used in clause compiler. data Cl = Cl- { clPats :: [Arg Pattern]+ { clNumber :: ClauseNumber+ -- ^ Which original 'Clause' did this clause come from?+ , clRecursive :: ClauseRecursive+ -- ^ Does the clause body contain calls to the mutually recursive functions?+ , clPats :: ![Arg Pattern] -- ^ Pattern variables are considered in left-to-right order. , clBody :: Maybe Term } deriving (Show) instance P.Pretty Cl where- pretty (Cl ps b) = P.prettyList ps P.<+> "->" P.<+> maybe "_|_" P.pretty b+ pretty (Cl no mr ps b) = (P.pretty no <> ":") P.<+> P.prettyList ps P.<+> "->" P.<+> maybe "_|_" P.pretty b type Cls = [Cl] -- | Strip down a clause. Don't forget to apply the substitution to the dot -- patterns!-unBruijn :: Clause -> Cl-unBruijn c = Cl (applySubst sub $ (map . fmap) (fmap dbPatVarName . namedThing) $ namedClausePats c)- (applySubst sub $ clauseBody c)+unBruijn :: (ClauseNumber, Clause) -> Cl+unBruijn (no, c) = Cl no+ (clauseRecursive c)+ (applySubst sub $ (map' . fmap) (fmap dbPatVarName . namedThing) $ namedClausePats c)+ (applySubst sub $ clauseBody c) where sub = renamingR $ fromMaybe __IMPOSSIBLE__ (clausePerm c) @@ -158,18 +164,22 @@ compile :: Cls -> CompiledClauses compile [] = Fail []-compile cs = case nextSplit cs of- Just (isRecP, n) -> Case n $ compile <$> splitOn isRecP (unArg n) cs- Nothing -> case clBody c of- -- It's possible to get more than one clause here due to- -- catch-all expansion.- Just t -> Done (map (fmap name) $ clPats c) t- Nothing -> Fail (map (fmap name) $ clPats c)- where+compile (c:cs) = case nextSplit c cs of+ Just (isRecP, n) -> Case n $ compile <$> splitOn isRecP (unArg n) (c:cs)+ Nothing ->+ -- It's possible to get more than one clause here due to catch-all expansion.+ case body of+ Just t -> Done no mr xs t+ Nothing -> Fail xs+ where -- If there are more than one clauses, take the first one.- c = headWithDefault __IMPOSSIBLE__ cs+ Cl no mr ps body = c+ xs = map' (fmap name) ps name (VarP _ x) = x name (DotP _ _) = underscore+ name (ConP _ cpi _) | conPLazy cpi = underscore+ -- Issue #8626: forcing analysis can create lazy split, which appears+ -- as lazy `ConP` patterns instead of `DotP` patterns. name ConP{} = __IMPOSSIBLE__ name DefP{} = __IMPOSSIBLE__ name LitP{} = __IMPOSSIBLE__@@ -180,17 +190,16 @@ -- This the number of the first pattern that does a (non-lazy) match in the first clause. -- Or the first lazy match where all clauses agree on the constructor, if there are no -- non-lazy matches.-nextSplit :: Cls -> Maybe (Bool, Arg Int)-nextSplit [] = __IMPOSSIBLE__-nextSplit (Cl ps _ : cs) = findSplit nonLazy ps <|> findSplit allAgree ps+nextSplit :: Cl -> Cls -> Maybe (Bool, Arg Int)+nextSplit (Cl _ _ ps _) cs = findSplit nonLazy ps <|> findSplit allAgree ps where nonLazy _ (ConP _ cpi _) = not $ conPLazy cpi nonLazy _ _ = True findSplit okPat ps = listToMaybe (catMaybes $- zipWith (\ (Arg ai p) n -> (, Arg ai n) <$> properSplit p <* guard (okPat n p)) ps [0..])+ zipWith' (\ (Arg ai p) n -> (, Arg ai n) <$> properSplit p <* guard (okPat n p)) ps [0..]) - allAgree i (ConP c _ _) = all ((== Just (conName c)) . getCon . map unArg . drop i . clPats) cs+ allAgree i (ConP c _ _) = all ((== Just (conName c)) . getCon . map' unArg . drop i . clPats) cs allAgree _ _ = False getCon (ConP c _ _ : _) = Just $ conName c@@ -222,26 +231,26 @@ -- | @splitOn single n cs@ will force expansion of catch-alls -- if @single@. splitOn :: Bool -> Int -> Cls -> Case Cls-splitOn single n cs = mconcat $ map (fmap (:[]) . splitC n) $- -- (\ cs -> trace ("splitting on " ++ show n ++ " after expandCatchalls " ++ show single ++ ": " ++ prettyShow (P.prettyList cs)) cs) $+splitOn single n cs = mconcat $ map' (fmap (:[]) . splitC n) $+ -- (\ cs -> trace ("splitting on " ++! show n ++! " after expandCatchalls " ++! show single ++! ": " ++! prettyShow (P.prettyList cs)) cs) $ expandCatchalls single n cs splitC :: Int -> Cl -> Case Cl-splitC n (Cl ps b) = caseMaybe mp fallback $ \case- ProjP _ d -> projCase d $ Cl (ps0 ++ ps1) b+splitC n (Cl no mr ps b) = caseMaybe mp fallback $ \case+ ProjP _ d -> projCase d $ Cl no mr (ps0 ++! ps1) b IApplyP{} -> fallback ConP c i qs -> (conCase (conName c) (conPFallThrough i) $ WithArity (length qs) $- Cl (ps0 ++ map (fmap namedThing) qs ++ ps1) b) { lazyMatch = conPLazy i }+ Cl no mr (ps0 ++! map' (fmap namedThing) qs ++! ps1) b) { lazyMatch = conPLazy i } DefP o q qs -> (conCase q False $ WithArity (length qs) $- Cl (ps0 ++ map (fmap namedThing) qs ++ ps1) b) { lazyMatch = False }- LitP _ l -> litCase l $ Cl (ps0 ++ ps1) b+ Cl no mr (ps0 ++! map' (fmap namedThing) qs ++! ps1) b) { lazyMatch = False }+ LitP _ l -> litCase l $ Cl no mr (ps0 ++! ps1) b VarP{} -> fallback DotP{} -> fallback where (ps0, rest) = splitAt n ps mp = unArg <$> listToMaybe rest ps1 = drop 1 rest- fallback = catchall $ Cl ps b+ fallback = catchall $ Cl no mr ps b -- | Expand catch-alls that appear before actual matches. --@@ -323,7 +332,7 @@ -- would have no effect | all (isCatchallNth . clPats) cs -> cs - c@(Cl ps b):cs+ c@(Cl _ _ ps b) : cs -- If the head clause does not have a catch-all pattern for the -- nth argument, we can keep it at the head and do no expansion | not (isCatchallNth ps) -> c : expandCatchalls False n cs@@ -334,21 +343,21 @@ -- DefP clauses are always inserted by the system and should -- "defeat" user-written inexact patterns. | (defps@(_:_), rest) <- partition isDefPNth (c:cs)- -> defps ++ expandCatchalls False n rest+ -> defps ++! expandCatchalls False n rest -- If the head clause *does* have an irrefutable pattern for the -- nth argument, and there's nothing more important after, then we -- duplicate the subsequent overlapping clauses with c's RHS -- instead.- | otherwise -> map (expand c) expansions ++ c : expandCatchalls False n cs+ | otherwise -> map' (expand c) expansions ++! c : expandCatchalls False n cs _ -> __IMPOSSIBLE__ where -- In case there is only one branch in the split tree, we expand all -- catch-alls for this position -- The @expansions@ are collected from all the clauses @cs@ then. -- Note: @expansions@ could be empty, so we keep the orignal clause.- doExpand c@(Cl ps _)- | exCatchallNth ps = map (expand c) expansions ++ [c]+ doExpand c@(Cl _ _ ps _)+ | exCatchallNth ps = map' (expand c) expansions ++! [c] | otherwise = [c] -- True if nth pattern is variable or there are less than n patterns.@@ -383,47 +392,51 @@ expand cl (qs, q) = case unArg q of- ConP c mt qs' -> Cl (ps0 ++ [q $> ConP c mt conPArgs] ++ ps1)- (substBody n' m (Con c ci (map Apply conArgs)) b)+ ConP c mt qs' -> Cl no mr (ps0 ++! [q $> ConP c mt conPArgs] ++! ps1)+ (substBody n' m (Con c ci (map' Apply conArgs)) b) where ci = fromConPatternInfo mt m = length qs' -- replace all direct subpatterns of q by _ -- TODO Andrea: might need these to sometimes be IApply?- conPArgs = map (fmap ($> varP "_")) qs'- conArgs = zipWith (\ q' i -> q' $> var i) qs' $ downFrom m- LitP i l -> Cl (ps0 ++ [q $> LitP i l] ++ ps1) (substBody n' 0 (Lit l) b)- DefP o d qs' -> Cl (ps0 ++ [q $> DefP o d conPArgs] ++ ps1)- (substBody n' m (Def d (map Apply conArgs)) b)+ conPArgs = map' (fmap ($> varP "_")) qs'+ conArgs = zipWith' (\ q' i -> q' $> var i) qs' $ downFrom m+ LitP i l -> Cl no mr (ps0 ++! [q $> LitP i l] ++! ps1) (substBody n' 0 (Lit l) b)+ DefP o d qs' -> Cl no mr (ps0 ++! [q $> DefP o d conPArgs] ++! ps1)+ (substBody n' m (Def d (map' Apply conArgs)) b) where m = length qs' -- replace all direct subpatterns of q by _- conPArgs = map (fmap ($> varP "_")) qs'- conArgs = zipWith (\ q' i -> q' $> var i) qs' $ downFrom m+ conPArgs = map' (fmap ($> varP "_")) qs'+ conArgs = zipWith' (\ q' i -> q' $> var i) qs' $ downFrom m _ -> __IMPOSSIBLE__ where -- Andreas, 2016-09-19 issue #2168 -- Due to varying function arity, some clauses might be eta-contracted. -- Thus, we eta-expand them.- Cl ps b = ensureNPatterns (n + 1) (map getArgInfo $ qs ++ [q]) cl+ Cl no mr ps b = ensureNPatterns (n + 1) (map' getArgInfo $ qs ++! [q]) cl -- The following pattern match cannot fail (by construction of @ps@). (ps0, _:ps1) = splitAt n ps + -- Andreas, 2026-05-01, issue #7629.+ -- Catch-all expansion substitutes into clause bodies, so it must count+ -- every binder to the right of the expanded pattern, including IApply+ -- variables. n' = countPatternVars ps1 -- | Make sure (by eta-expansion) that clause has arity at least @n@ -- where @n@ is also the length of the provided list. ensureNPatterns :: Int -> [ArgInfo] -> Cl -> Cl-ensureNPatterns n ais0 cl@(Cl ps b)+ensureNPatterns n ais0 cl@(Cl no mr ps b) | m <= 0 = cl- | otherwise = Cl (ps ++ ps') (raise m b `apply` args)+ | otherwise = Cl no mr (ps ++! ps') (raise m b `apply` args) where k = length ps ais = drop k ais0 -- m = Number of arguments to add m = n - k ps' = for ais $ \ ai -> Arg ai $ varP "_"- args = zipWith (\ i ai -> Arg ai $ var i) (downFrom m) ais+ args = zipWith' (\ i ai -> Arg ai $ var i) (downFrom m) ais substBody :: Subst a => Int -> Int -> SubstArg a -> a -> a substBody n m v = applySubst $ liftS n $ v :# raiseS m
src/full/Agda/TypeChecking/CompiledClause/Match.hs view
@@ -4,29 +4,28 @@ import qualified Data.Map as Map -import Agda.Interaction.Options (optRewriting)- import Agda.Syntax.Internal import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty (prettyShow) import Agda.TypeChecking.CompiledClause-import Agda.TypeChecking.Monad hiding (constructorForm)+import Agda.TypeChecking.Monad import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Reduce.Monad as RedM import Agda.TypeChecking.Substitute +import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Monad-import Agda.Syntax.Common.Pretty (prettyShow)+import qualified Agda.Utils.SmallSet as SmallSet import Agda.Utils.Impossible matchCompiled :: CompiledClauses -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Args) Term) matchCompiled c args = do- r <- matchCompiledE c $ map (fmap Apply) args+ r <- matchCompiledE c $ map' (fmap Apply) args case r of YesReduction simpl v -> return $ YesReduction simpl v- NoReduction bes -> return $ NoReduction $ fmap (map (fromMaybe __IMPOSSIBLE__ . isApplyElim)) bes+ NoReduction bes -> return $ NoReduction $ fmap (map' mustApplyElim) bes -- | @matchCompiledE c es@ takes a function given by case tree @c@ and -- and a spine @es@ and tries to apply the function to @es@.@@ -62,9 +61,14 @@ match' :: Stack -> ReduceM (Reduced (Blocked Elims) Term) match' ((c, es, patch) : stack) = do- let no blocking es = return $ NoReduction $ blocking $ patch $ map ignoreReduced es- yes t = flip YesReduction t <$> asksTC envSimplification+ let no blocking es = return $! NoReduction $! blocking $! patch $! map'' ignoreReduced es+ yes t = flip YesReduction t <$!> viewTC eSimplification + -- TODO: make this local to Done+ allowedReductions <- viewTC eAllowedReductions+ fun <- fromMaybe __IMPOSSIBLE__ <$> viewTC eAppDef+ def <- getConstInfo fun+ do case c of@@ -73,39 +77,45 @@ Fail{} -> no (NotBlocked AbsurdMatch) es -- done matching- Done xs t+ Done _no mr xs t+ | couldBeRecursive mr+ , defTerminationUnconfirmed def+ , UnconfirmedReductions `SmallSet.notMember` allowedReductions -> do+ reportSLn "tc.reduce.recursive" 80 $ "Aborting reduction of " <> prettyShow fun+ no (NotBlocked ReallyNotBlocked) es -- if the function was partially applied, return a lambda | m < n -> yes $ applySubst (toSubst es) $ foldr lam t (drop m xs) -- otherwise, just apply instantiation to body -- apply the result to any extra arguments- | otherwise -> yes $ applySubst (toSubst es0) t `applyE` map ignoreReduced es1+ | otherwise -> yes $ applySubst (toSubst es0) t `applyE` map'' ignoreReduced es1 where n = length xs m = length es -- at least the first @n@ elims must be @Apply@s, so we can -- turn them into a subsitution- toSubst = parallelS . reverse . map (unArg . fromMaybe __IMPOSSIBLE__ . isApplyElim . ignoreReduced)- (es0, es1) = splitAt n es+ toSubst = parallelS . reverse . map'' (unArg . fromMaybe __IMPOSSIBLE__ . isApplyElim . ignoreReduced)+ (es0, es1) = splitAt' n es lam x t = Lam (argInfo x) (Abs (unArg x) t) -- splitting on an eta-record constructor Case (Arg _ n) Branches{etaBranch = Just (c, cc), catchallBranch = ca} ->- case splitAt n es of+ case splitAt' n es of (_, []) -> no (NotBlocked Underapplied) es (es0, MaybeRed _ e@(Apply (Arg _ v0)) : es1) ->- let projs = [ MaybeRed NotReduced $ Apply $ Arg ai $ relToDontCare ai $ v0 `applyE` [Proj ProjSystem f] | Arg ai f <- fs ]+ let projs = map'' (\(Arg ai f) -> MaybeRed NotReduced $ Apply $ Arg ai $ relToDontCare ai $ v0 `applyE` [Proj ProjSystem f])+ fs catchallFrame stack = maybe stack (\c -> (c, es, patch) : stack) ca in- match' $ (content cc, es0 ++ projs ++ es1, patchEta) : catchallFrame stack+ match' $ (content cc, es0 ++! projs ++! es1, patchEta) : catchallFrame stack where fs = conFields c- patchEta es = patch (es0 ++ [e] ++ es1)- where (es0, es') = splitAt n es- (_, es1) = splitAt (length fs) es'+ patchEta es = patch (es0 ++! e : es1)+ where (es0, es') = splitAt' n es+ (_, es1) = splitAt' (length fs) es' _ -> __IMPOSSIBLE__ -- splitting on the @n@th elimination Case (Arg _ n) bs -> do- case splitAt n es of+ case splitAt' n es of -- if the @n@th elimination is not supplied, no match (_, []) -> no (NotBlocked Underapplied) es -- if the @n@th elimination is @e0@@@ -113,18 +123,18 @@ -- get the reduced form of @e0@ eb :: Blocked Elim <- do case red of- Reduced b -> return $ e0 <$ b+ Reduced b -> return $! e0 <$ b NotReduced -> unfoldCorecursionE e0 let e = ignoreBlocking eb -- replace the @n@th argument by its reduced form- es' = es0 ++ [MaybeRed (Reduced $ () <$ eb) e] ++ es1+ es' = es0 ++! MaybeRed (Reduced $ () <$ eb) e : es1 -- if a catch-all clause exists, put it on the stack catchallFrame stack = maybe stack (\c -> (c, es', patch) : stack) (catchallBranch bs) -- If our argument is @Lit l@, we push @litFrame l@ onto the stack. litFrame l stack = case Map.lookup l (litBranches bs) of Nothing -> stack- Just cc -> (cc, es0 ++ es1, patchLit) : stack+ Just cc -> (cc, es0 ++! es1, patchLit) : stack -- If our argument (or its constructor form) is @Con c ci vs@ -- we push @conFrame c vs@ onto the stack. conFrame c ci vs stack = conFrame' (conName c) (Con c ci) vs stack@@ -132,24 +142,24 @@ case Map.lookup q (conBranches bs) of Nothing -> stack Just cc -> ( content cc- , es0 ++ map (MaybeRed NotReduced) vs ++ es1+ , es0 ++! map' (MaybeRed NotReduced) vs ++! es1 , patchCon f (length vs) ) : stack -- If our argument is @Proj p@, we push @projFrame p@ onto the stack. projFrame p stack = case Map.lookup p (conBranches bs) of Nothing -> stack- Just cc -> (content cc, es0 ++ es1, patchLit) : stack+ Just cc -> (content cc, es0 ++! es1, patchLit) : stack -- The new patch function restores the @n@th argument to @v@: -- In case we matched a literal, just put @v@ back.- patchLit es = patch (es0 ++ [e] ++ es1)- where (es0, es1) = splitAt n es+ patchLit es = patch (es0 ++! e : es1)+ where (es0, es1) = splitAt' n es -- In case we matched constructor @c@ with @m@ arguments, -- contract these @m@ arguments @vs@ to @Con c ci vs@.--- patchCon c ci m es = patch (es0 ++ [Con c ci vs <$ e] ++ es2)- patchCon f m es = patch (es0 ++ [f vs <$ e] ++ es2)- where (es0, rest) = splitAt n es- (es1, es2) = splitAt m rest+-- patchCon c ci m es = patch (es0 ++! [Con c ci vs <$ e] ++! es2)+ patchCon f m es = patch (es0 ++! (f vs <$ e) : es2)+ where (es0, rest) = splitAt' n es+ (es1, es2) = splitAt' m rest vs = es1 -- zo <- do -- mi <- getBuiltinName' builtinIZero@@ -196,13 +206,13 @@ -- If we reach the empty stack, then pattern matching was incomplete match' [] = {- new line here since __IMPOSSIBLE__ does not like the ' in match' -}- caseMaybeM (asksTC envAppDef) __IMPOSSIBLE__ $ \ f -> do+ caseMaybeM (viewTC eAppDef) __IMPOSSIBLE__ $ \ f -> do pds <- getPartialDefs if f `elem` pds then return (NoReduction $ NotBlocked (MissingClauses f) []) else do- ifM (optRewriting <$> pragmaOptions)+ ifM anyRewritingOption {-then-} (return (NoReduction $ NotBlocked ReallyNotBlocked [])) -- See #5396 {-else-} $ traceSLn "impossible" 10- ("Incomplete pattern matching when applying " ++ prettyShow f)+ ("Incomplete pattern matching when applying " ++! prettyShow f) __IMPOSSIBLE__
src/full/Agda/TypeChecking/Constraints.hs view
@@ -6,11 +6,8 @@ import Prelude hiding (null) -import Control.Monad.Except ( MonadError )- import qualified Data.List as List import qualified Data.Set as Set-import Data.Either import Agda.Syntax.Common import Agda.Syntax.Common.Pretty ( prettyShow )@@ -35,86 +32,103 @@ import {-# SOURCE #-} Agda.TypeChecking.Empty import {-# SOURCE #-} Agda.TypeChecking.Lock import {-# SOURCE #-} Agda.TypeChecking.CheckInternal ( checkType )+import {-# SOURCE #-} Agda.TypeChecking.Rewriting import Agda.Utils.CallStack ( withCurrentCallStack )+import Agda.Utils.List import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad-import Agda.Utils.Null ()-import qualified Agda.Utils.ProfileOptions as Profile+import Agda.Utils.Null (unlessNullM)+import qualified Agda.Interaction.Options.ProfileOptions as Profile import Agda.Utils.Singleton import Agda.Utils.Impossible+import Agda.Utils.Function (applyUnless) instance MonadConstraint TCM where- addConstraint = addConstraintTCM- addAwakeConstraint = addAwakeConstraint'- solveConstraint = solveConstraintTCM- solveSomeAwakeConstraints = solveSomeAwakeConstraintsTCM- wakeConstraints = wakeConstraintsTCM- stealConstraints = stealConstraintsTCM- modifyAwakeConstraints = modifyTC . mapAwakeConstraints- modifySleepingConstraints = modifyTC . mapSleepingConstraints+ addConstraint u c = ifImpureConv (addConstraintTCM u c) $ patternViolation u+ addAwakeConstraint u c = ifImpureConv (addAwakeConstraint' u c) $ patternViolation u + solveConstraint c = ifImpureConv (solveConstraintTCM c) $+ patternViolation alwaysUnblock -- TODO: does this happen?++ solveSomeAwakeConstraints s f = ifImpureConv (solveSomeAwakeConstraintsTCM s f) $ return ()++ {-# INLINE wakeConstraints #-}+ wakeConstraints w = ifImpureConv (wakeConstraintsTCM w) $ return ()++ {-# INLINE stealConstraints #-}+ stealConstraints w = ifImpureConv (stealConstraintsTCM w) $ return ()++ {-# INLINE modifyConstraints #-}+ modifyConstraints f g = ifImpureConv+ (modifyTC (mapAwakeConstraints f . mapSleepingConstraints g))+ (patternViolation alwaysUnblock) -- TODO: does this happen?++ addConstraintTCM :: Blocker -> Constraint -> TCM () addConstraintTCM unblock c = do- pids <- asksTC envActiveProblems- reportSDoc "tc.constr.add" 20 $ hsep- [ "adding constraint"- , prettyTCM . PConstr pids unblock =<< buildClosure c- , "unblocker: " , prettyTCM unblock- ]- -- Jesper, 2022-10-22: We should never block on a meta that is- -- already solved.- forM_ (allBlockingMetas unblock) $ \ m ->- whenM (isInstantiatedMeta m) $ do- reportSDoc "tc.constr.add" 5 $ "Attempted to block on solved meta" <+> prettyTCM m- __IMPOSSIBLE__- -- Need to reduce to reveal possibly blocking metas- c <- reduce =<< instantiateFull c- caseMaybeM (simpl c) {-no-} (addConstraint' unblock c) $ {-yes-} \ cs -> do- reportSDoc "tc.constr.add" 20 $ " simplified:" <+> prettyList (map prettyTCM cs)- mapM_ solveConstraint_ cs- -- The added constraint can cause instance constraints to be solved,- -- but only the constraints which aren’t blocked on an uninstantiated meta.- unless (isInstanceConstraint c) $- wakeConstraints' isWakeableInstanceConstraint- where- isWakeableInstanceConstraint :: ProblemConstraint -> WakeUp- isWakeableInstanceConstraint c =- case clValue $ theConstraint c of- FindInstance{}- | constraintUnblocker c == alwaysUnblock -> WakeUp- _ -> DontWakeUp Nothing+ pids <- viewTC eActiveProblems+ reportSDoc "tc.constr.add" 20 $ hsep+ [ "adding constraint"+ , prettyTCM . PConstr pids unblock =<< buildClosure c+ , "unblocker: " , prettyTCM unblock+ ]+ -- Jesper, 2022-10-22: We should never block on a meta that is+ -- already solved.+ forM_ (allBlockingMetas unblock) $ \ m ->+ whenM (isInstantiatedMeta m) $ do+ reportSDoc "tc.constr.add" 5 $ "Attempted to block on solved meta" <+> prettyTCM m+ __IMPOSSIBLE__+ -- Need to reduce to reveal possibly blocking metas+ c <- reduce =<< instantiateFull c+ caseMaybeM (simpl c) {-no-} (addConstraint' unblock c) $ {-yes-} \ cs -> do+ reportSDoc "tc.constr.add" 20 $ " simplified:" <+> prettyList (map prettyTCM cs)+ mapM_ solveConstraint_ cs+ -- The added constraint can cause instance constraints to be solved,+ -- but only the constraints which aren’t blocked on an uninstantiated meta.+ unless (isInstanceConstraint c) $+ wakeConstraints' isWakeableInstanceConstraint+ where+ isWakeableInstanceConstraint :: ProblemConstraint -> WakeUp+ isWakeableInstanceConstraint c =+ case clValue $ theConstraint c of+ FindInstance{}+ | constraintUnblocker c == alwaysUnblock -> WakeUp+ _ -> DontWakeUp Nothing - isLvl LevelCmp{} = True- isLvl _ = False+ isLvl LevelCmp{} = True+ isLvl _ = False - -- Try to simplify a level constraint- simpl :: Constraint -> TCM (Maybe [Constraint])- simpl c- | isLvl c = do- -- Get all level constraints.- lvlcs <- instantiateFull =<< do- List.filter (isLvl . clValue) . map theConstraint <$> getAllConstraints- List1.ifNull lvlcs (return Nothing) $ {-else-} \ lvlcs -> do- reportSDoc "tc.constr.lvl" 40 $ vcat- [ "simplifying level constraint" <+> prettyTCM c- , nest 2 $ hang "using" 2 $ prettyTCM lvlcs- ]- -- Try to simplify @c@ using the other constraints.- return $ simplifyLevelConstraint c $ fmap clValue lvlcs- | otherwise = return Nothing+ -- Try to simplify a level constraint+ simpl :: Constraint -> TCM (Maybe [Constraint])+ simpl c+ | isLvl c = do+ -- Get all level constraints.+ lvlcs <- instantiateFull =<< do+ List.filter (isLvl . clValue) . map theConstraint <$> getAllConstraints+ List1.ifNull lvlcs (return Nothing) $ {-else-} \ lvlcs -> do+ reportSDoc "tc.constr.lvl" 40 $ vcat+ [ "simplifying level constraint" <+> prettyTCM c+ , nest 2 $ hang "using" 2 $ prettyTCM lvlcs+ ]+ -- Try to simplify @c@ using the other constraints.+ return $ simplifyLevelConstraint c $ fmap clValue lvlcs+ | otherwise = return Nothing +{-# INLINE wakeConstraintsTCM #-} wakeConstraintsTCM :: (ProblemConstraint-> WakeUp) -> TCM () wakeConstraintsTCM wake = do- c <- useR stSleepingConstraints- let (wakeup, sleepin) = partitionEithers $ map checkWakeUp c+ tc <- getTC+ let c = tc ^. stSleepingConstraints+ let (wakeup, sleepin) = partitionEithers' $ map' checkWakeUp c reportSLn "tc.constr.wake" 50 $ "waking up " ++ show (List.map (Set.toList . constraintProblems) wakeup) ++ "\n" ++ " still sleeping: " ++ show (List.map (Set.toList . constraintProblems) sleepin)- modifySleepingConstraints $ const sleepin- modifyAwakeConstraints (++ wakeup)+ putTC $!+ mapAwakeConstraints (++! wakeup) $ -- TODO: quadratic append!!+ mapSleepingConstraints (const sleepin) tc where checkWakeUp c = case wake c of WakeUp -> Left c@@ -124,43 +138,45 @@ -- | Add all constraints belonging to the given problem to the current problem(s). stealConstraintsTCM :: ProblemId -> TCM () stealConstraintsTCM pid = do- current <- asksTC envActiveProblems+ current <- viewTC eActiveProblems reportSLn "tc.constr.steal" 50 $ "problem " ++ show (Set.toList current) ++ " is stealing problem " ++ show pid ++ "'s constraints!" -- Add current to any constraint in pid. let rename pc@(PConstr pids u c) | Set.member pid pids = PConstr (Set.union current pids) u c | otherwise = pc -- We should never steal from an active problem.- whenM (Set.member pid <$> asksTC envActiveProblems) __IMPOSSIBLE__- modifyAwakeConstraints $ List.map rename- modifySleepingConstraints $ List.map rename-+ whenM (Set.member pid <$> viewTC eActiveProblems) __IMPOSSIBLE__+ modifyTC $ mapAwakeConstraints (map' rename)+ . mapSleepingConstraints (map' rename) {-# SPECIALIZE noConstraints :: TCM a -> TCM a #-}--- | Don't allow the argument to produce any blocking constraints.+-- | Error out with @'NonFatalErrors' 'UnsolvedConstraints'@+-- if the computation produced blocking constraints. -- -- WARNING: this does not mean that the given computation cannot -- constrain the solution space further. -- It can well do so, by solving metas. noConstraints- :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m)+ :: (MonadConstraint m, MonadWarning m, MonadFresh ProblemId m) => m a -> m a noConstraints = noConstraints' False --- | As noConstraints but also fail for non-blocking constraints.+-- | As 'noConstraints' but also fail for non-blocking constraints. reallyNoConstraints- :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m)+ :: (MonadConstraint m, MonadWarning m, MonadFresh ProblemId m) => m a -> m a reallyNoConstraints = noConstraints' True -noConstraints'- :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m)+-- | Error out with @'NonFatalErrors' 'UnsolvedConstraints'@+-- when given computation produced constraints ('True') or blocking constraints ('False').+noConstraints' ::+ (MonadConstraint m, MonadWarning m, MonadFresh ProblemId m) => Bool -> m a -> m a noConstraints' includingNonBlocking problem = do (pid, x) <- newProblem problem- let counts | includingNonBlocking = const True- | otherwise = isBlockingConstraint . clValue . theConstraint- cs <- List.filter counts <$> getConstraintsForProblem pid- List1.ifNull cs (pure ()) \ cs -> do+ -- Consider only blocking constraints unless @includingNonBlocking@.+ let isBlocking = isBlockingConstraint . clValue . theConstraint+ cs <- applyUnless includingNonBlocking (List.filter isBlocking) <$> getConstraintsForProblem pid+ List1.unlessNull cs \ cs -> do withCurrentCallStack \ loc -> do w <- warning'_ loc $ UnsolvedConstraints cs typeError' loc $ NonFatalErrors $ singleton w@@ -169,17 +185,13 @@ -- | Run a computation that should succeeds without constraining -- the solution space, i.e., not add any information about meta-variables. nonConstraining ::- ( HasOptions m- , MonadConstraint m- , MonadDebug m- , MonadError TCErr m+ ( MonadConstraint m , MonadFresh ProblemId m- , MonadTCEnv m , MonadWarning m ) => m a -> m a nonConstraining = dontAssignMetas . noConstraints -{-# SPECIALIZE newProblem :: TCM a -> TCM (ProblemId, a) #-}+{-# INLINE newProblem #-} -- | Create a fresh problem for the given action. newProblem :: (MonadFresh ProblemId m, MonadConstraint m)@@ -192,12 +204,25 @@ solveAwakeConstraints return (pid, x) -{-# SPECIALIZE newProblem_ :: TCM a -> TCM ProblemId #-}+{-# INLINE newProblem_ #-} newProblem_ :: (MonadFresh ProblemId m, MonadConstraint m) => m a -> m ProblemId newProblem_ action = fst <$> newProblem action +{-# INLINE newProblemDontWake_ #-}+-- | Create a fresh problem for the given action. Don't wake problems after the action finishes.+newProblemDontWake_+ :: (MonadFresh ProblemId m, MonadConstraint m)+ => m a -> m ProblemId+newProblemDontWake_ action = do+ pid <- fresh+ -- Don't get distracted by other constraints while working on the problem+ _ <- nowSolvingConstraints $+ verboseBracket "tc.constr.solve" 50 ("working on problem " ++ show pid) $+ localTC (over eActiveProblems (Set.insert pid)) action+ pure pid+ ifNoConstraints :: TCM a -> (a -> TCM b) -> (ProblemId -> a -> TCM b) -> TCM b ifNoConstraints check ifNo ifCs = do (pid, x) <- newProblem check@@ -247,10 +272,11 @@ locallyTC eActiveProblems (const Set.empty) solve where solve = do- reportSDoc "tc.constr.solve" 10 $ hsep [ "Solving awake constraints."- , text . show . length =<< getAwakeConstraints- , "remaining." ]- whenJustM (takeAwakeConstraint' solveThis) $ \ c -> do+ verboseS "tc.constr.solve" 10 do+ unlessNullM getAwakeConstraints \ cs ->+ reportSDoc "tc.constr.solve" 10 $ hsep+ [ "Solving awake constraints.", text . show $ length cs, "remaining."]+ whenJustM (takeAwakeConstraint' solveThis) \ c -> do withConstraint solveConstraint c solve @@ -258,7 +284,7 @@ solveConstraintTCM c = do whenProfile Profile.Constraints $ liftTCM $ tick "attempted-constraints" verboseBracket "tc.constr.solve" 20 "solving constraint" $ do- pids <- asksTC envActiveProblems+ pids <- viewTC eActiveProblems reportSDoc "tc.constr.solve.constr" 20 $ text (show $ Set.toList pids) <+> prettyTCM c solveConstraint_ c @@ -272,7 +298,7 @@ solveConstraint_ (CheckSizeLtSat t) = checkSizeLtSat t solveConstraint_ (UnquoteTactic tac hole goal) = unquoteTactic tac hole goal solveConstraint_ (UnBlock m) = -- alwaysUnblock since these have their own unblocking logic (for now)- ifM (isFrozen m `or2M` (not <$> asksTC envAssignMetas)) (do+ ifM (isFrozen m `or2M` (not <$> viewTC eAssignMetas)) (do 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@@ -301,7 +327,7 @@ InstV{} -> __IMPOSSIBLE__ OpenMeta{} -> __IMPOSSIBLE__ solveConstraint_ (FindInstance _ m cands) = findInstance m cands-solveConstraint_ (ResolveInstanceHead q) = resolveInstanceHead q+solveConstraint_ (ResolveInstanceHead kwr q) = resolveInstanceHead kwr q solveConstraint_ (CheckFunDef i q cs _err) = withoutCache $ -- re #3498: checking a fundef would normally be cached, but here it's -- happening out of order so it would only corrupt the caching log.@@ -313,6 +339,7 @@ solveConstraint_ (CheckMetaInst m) = checkMetaInst m solveConstraint_ (CheckType t) = checkType t solveConstraint_ (UsableAtModality cc ms mod t) = usableAtModality' ms cc mod t+solveConstraint_ (RewConstraint eq) = checkRewConstraint eq checkTypeCheckingProblem :: TypeCheckingProblem -> TCM Term checkTypeCheckingProblem = \case@@ -337,6 +364,7 @@ updateBlocker :: (PureTCM m) => Blocker -> m Blocker updateBlocker = instantiate +{-# INLINE addAndUnblocker #-} addAndUnblocker :: (PureTCM m, MonadBlock m) => Blocker -> m a -> m a addAndUnblocker u | u == alwaysUnblock = id@@ -344,6 +372,7 @@ u <- updateBlocker u patternViolation (unblockOnBoth u u') +{-# INLINE addOrUnblocker #-} addOrUnblocker :: (PureTCM m, MonadBlock m) => Blocker -> m a -> m a addOrUnblocker u | u == neverUnblock = id
src/full/Agda/TypeChecking/Constraints.hs-boot view
@@ -2,9 +2,6 @@ module Agda.TypeChecking.Constraints where --import Control.Monad.Except (MonadError)- import Agda.Syntax.Internal (ProblemId) import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Constraints (MonadConstraint)@@ -12,7 +9,7 @@ instance MonadConstraint TCM where -noConstraints :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m)+noConstraints :: (MonadConstraint m, MonadWarning m, MonadFresh ProblemId m) => m a -> m a ifNoConstraints_ :: TCM () -> TCM a -> (ProblemId -> TCM a) -> TCM a ifNoConstraints :: TCM a -> (a -> TCM b) -> (ProblemId -> a -> TCM b) -> TCM b
src/full/Agda/TypeChecking/Conversion.hs view
@@ -1,22 +1,23 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NondecreasingIndentation #-}+-- {-# OPTIONS_GHC -Wunused-imports #-}+-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-all -dno-suppress-type-signatures -ddump-to-file -dno-typeable-binds #-} -#if __GLASGOW_HASKELL__ >= 810 {-# OPTIONS_GHC -fmax-pmcheck-models=390 #-} -- Andreas, 2023-05-12, limit determined by binary search-#endif -module Agda.TypeChecking.Conversion where+module Agda.TypeChecking.Conversion+ ( module Agda.TypeChecking.Conversion+ , failConversion+ )+ where -import Control.Arrow (second) import Control.Monad.Except ( MonadError(..) ) import Data.Function (on)-import Data.Semigroup ((<>)) import Data.IntMap (IntMap) -import qualified Data.List as List+-- 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@@ -36,6 +37,7 @@ import Agda.TypeChecking.Conversion.Pure (pureCompareAs, runPureConversion) import Agda.TypeChecking.Forcing (isForced, nextIsForced) import Agda.TypeChecking.Free+import Agda.TypeChecking.Free.Reduce (forceNonDepSort, IsFree (..)) import Agda.TypeChecking.Datatypes (getConType, getFullyAppliedConType) import Agda.TypeChecking.Records import Agda.TypeChecking.Pretty@@ -48,51 +50,42 @@ import Agda.TypeChecking.Primitive import Agda.TypeChecking.ProjectionLike import Agda.TypeChecking.Warnings (MonadWarning)+import Agda.TypeChecking.Conversion.Errors import Agda.Interaction.Options +import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.Lens+import Agda.Utils.List import Agda.Utils.List1 (List1, pattern (:|)) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Monad import Agda.Utils.Maybe import Agda.Utils.Permutation import Agda.Syntax.Common.Pretty (prettyShow)-import qualified Agda.Utils.ProfileOptions as Profile+import qualified Agda.Interaction.Options.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.Unsafe ( unsafeComparePointers )+import qualified Agda.Utils.VarSet as VarSet+import Agda.Utils.ExpandCase import Agda.Utils.Impossible -type MonadConversion m =- ( PureTCM m- , MonadConstraint m- , MonadMetaSolver m- , MonadError TCErr m- , MonadWarning m- , MonadStatistics m- , MonadFresh ProblemId m- , MonadFresh Int m- ) -- | Try whether a computation runs without errors or new constraints -- (may create new metas, though). -- Restores state upon failure.-tryConversion- :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m)- => m () -> m Bool+tryConversion :: TCM () -> TCM Bool tryConversion = isJust <.> tryConversion' -- | Try whether a computation runs without errors or new constraints -- (may create new metas, though). -- Return 'Just' the result upon success. -- Return 'Nothing' and restore state upon failure.-tryConversion'- :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m)- => m a -> m (Maybe a)+tryConversion' :: TCM a -> TCM (Maybe a) tryConversion' m = tryMaybe $ noConstraints m -- | Check if to lists of arguments are the same (and all variables).@@ -116,22 +109,19 @@ -- | @guardPointerEquality x y s m@ behaves as @m@ if @x@ and @y@ are equal as pointers, -- or does nothing otherwise. -- Use with care, see the documentation for 'unsafeComparePointers'-guardPointerEquality :: MonadConversion m => a -> a -> String -> m () -> m ()+guardPointerEquality :: a -> a -> String -> TCM () -> TCM () guardPointerEquality u v profileSection action = if unsafeComparePointers u v then whenProfile Profile.Conversion $ tick profileSection else action -{-# SPECIALIZE equalTerm :: Type -> Term -> Term -> TCM () #-}-equalTerm :: MonadConversion m => Type -> Term -> Term -> m ()+equalTerm :: Type -> Term -> Term -> TCM () equalTerm = compareTerm CmpEq -{-# SPECIALIZE equalAtom :: CompareAs -> Term -> Term -> TCM () #-}-equalAtom :: MonadConversion m => CompareAs -> Term -> Term -> m ()+equalAtom :: CompareAs -> Term -> Term -> TCM () equalAtom = compareAtom CmpEq -{-# SPECIALIZE equalType :: Type -> Type -> TCM () #-}-equalType :: MonadConversion m => Type -> Type -> m ()+equalType :: Type -> Type -> TCM () equalType = compareType CmpEq {- Comparing in irrelevant context always succeeds.@@ -145,23 +135,21 @@ -- | Ignore errors in irrelevant context. convError :: TypeError -> TCM () convError err =- ifM (isIrrelevant <$> viewTC eRelevance)- (return ())+ unlessM (isIrrelevant <$> viewTC eRelevance) (typeError err) -- | Type directed equality on values. ---compareTerm :: forall m. MonadConversion m => Comparison -> Type -> Term -> Term -> m ()-compareTerm cmp a u v = compareAs cmp (AsTermsOf a) u v+compareTerm :: Comparison -> Type -> Term -> Term -> TCM ()+compareTerm !cmp !a !u !v = compareAs cmp (AsTermsOf a) u v -{-# SPECIALIZE compareAs :: Comparison -> CompareAs -> Term -> Term -> TCM () #-} -- | Type directed equality on terms or types.-compareAs :: forall m. MonadConversion m => Comparison -> CompareAs -> Term -> Term -> m ()+compareAs :: Comparison -> CompareAs -> Term -> Term -> TCM () -- If one term is a meta, try to instantiate right away. This avoids unnecessary unfolding. -- Andreas, 2012-02-14: This is UNSOUND for subtyping!-compareAs cmp a u v = do+compareAs !cmp !a !u !v = do reportSDoc "tc.conv.term" 20 $ sep $ [ "compareTerm" , nest 2 $ prettyTCM u <+> prettyTCM cmp <+> prettyTCM v@@ -189,7 +177,7 @@ -- It seems to assume we are never comparing -- at function types into Size. let fallback = compareAs' cmp a u v- unlessSubtyping :: m () -> m ()+ unlessSubtyping :: TCM () -> TCM () unlessSubtyping cont = if cmp == CmpEq then cont else do -- Andreas, 2014-04-12 do not short cut if type is blocked.@@ -223,17 +211,17 @@ -- Amy, 2023-01-04, issue #6415: and not -- prim^unglue/prim^unglueU either! removing the unglue from a -- transport/hcomp may cause an infinite loop.- cubicalProjs <- traverse getName' [builtin_unglue, builtin_unglueU]+ unglue <- getName' builtin_unglue+ unglueU <- getName' builtin_unglueU let- notFirstOrder = isJust (isRelevantProjection_ def)- || (Just f) `elem` cubicalProjs+ notFirstOrder = isJust (isRelevantProjection_ def) || Just f == unglue || Just f == unglueU if notFirstOrder 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- assign :: CompareDirection -> MetaId -> Elims -> Term -> m ()+ assign :: CompareDirection -> MetaId -> Elims -> Term -> TCM () assign dir x es v = do -- Andreas, 2013-10-19 can only solve if no projections reportSDoc "tc.conv.term.shortcut" 20 $ sep@@ -248,13 +236,13 @@ 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 ()+ orelse :: TCM () -> TCM () -> TCM () orelse m h = catchError m (\_ -> h) -- | Try to assign meta. If meta is projected, try to eta-expand -- and run conversion check again.-assignE :: (MonadConversion m)- => CompareDirection -> MetaId -> Elims -> Term -> CompareAs -> (Term -> Term -> m ()) -> m ()+assignE :: CompareDirection -> MetaId -> Elims -> Term -> CompareAs+ -> (Term -> Term -> TCM ()) -> TCM () assignE dir x es v a comp = do whenProfile Profile.Conversion $ tick "compare meta" case allApplyElims es of@@ -262,7 +250,7 @@ Nothing -> do reportSDoc "tc.conv.assign" 30 $ sep [ "assigning to projected meta "- , prettyTCM x <+> sep (map prettyTCM es) <+> text (":" ++ show dir) <+> prettyTCM v+ , prettyTCM x <+> sep (map' prettyTCM es) <+> text (":" ++ show dir) <+> prettyTCM v ] etaExpandMeta [Records] x res <- isInstantiatedMeta' x@@ -278,20 +266,20 @@ reportSLn "tc.conv.assign" 30 "eta expansion did not instantiate meta" patternViolation $ unblockOnMeta x -- nothing happened, give up -compareAsDir :: MonadConversion m => CompareDirection -> CompareAs -> Term -> Term -> m ()-compareAsDir dir a = dirToCmp (`compareAs'` a) dir+compareAsDir :: CompareDirection -> CompareAs -> Term -> Term -> TCM ()+compareAsDir !dir !a = dirToCmp (`compareAs'` a) dir -compareAs' :: forall m. MonadConversion m => Comparison -> CompareAs -> Term -> Term -> m ()-compareAs' cmp tt m n = case tt of+compareAs' :: Comparison -> CompareAs -> Term -> Term -> TCM ()+compareAs' !cmp !tt !m !n = case tt of AsTermsOf a -> compareTerm' cmp a m n AsSizes -> compareSizes cmp m n AsTypes -> compareAtom cmp AsTypes m n -compareTerm' :: forall m. MonadConversion m => Comparison -> Type -> Term -> Term -> m ()-compareTerm' cmp a m n =+compareTerm' :: Comparison -> Type -> Term -> Term -> TCM ()+compareTerm' !cmp !a !m !n = verboseBracket "tc.conv.term" 20 "compareTerm" $ do (ba, a') <- reduceWithBlocker a- (catchConstraint (ValueCmp cmp (AsTermsOf a') m n) :: m () -> m ()) $ blockOnError ba $ do+ (catchConstraint (ValueCmp cmp (AsTermsOf a') m n) :: TCM () -> TCM ()) $ blockOnError ba $ do reportSDoc "tc.conv.term" 30 $ fsep [ "compareTerm", prettyTCM m, prettyTCM cmp, prettyTCM n, ":", prettyTCM a' ] propIrr <- isPropEnabled@@ -306,26 +294,27 @@ , "mlvl =" <+> pretty mlvl , text $ "(Just (unEl a') == mlvl) = " ++ show (Just (unEl a') == mlvl) ]- blockOnError bs- case unEl a' of+ blockOnError bs $+ expand \ret -> case unEl a' of _ | propIrr- , isProp s -> compareIrrelevant a' m n- _ | isSize -> compareSizes cmp m n- a | Just a == mlvl -> do+ , isProp s -> ret $ compareIrrelevant a' m n+ _ | isSize -> ret $ compareSizes cmp m n+ a | Just a == mlvl -> ret do a <- levelView m b <- levelView n- equalLevel a b- a@Pi{} -> equalFun s a m n- Lam _ _ -> do+ nowConversionChecking cmp (Level a) (Level b) (AsTermsOf a') $+ equalLevel a b+ a@Pi{} -> ret $ equalFun s a m n+ Lam _ _ -> ret 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+ Def r es -> ret do isrec <- isEtaRecord r- if isrec- then do+ expand \ret -> if isrec+ then ret do whenProfile Profile.Conversion $ tick "compare at eta record" sig <- getSignature @@ -333,7 +322,7 @@ hcomp <- getPrimitiveName' builtinHComp let- ps = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ ps = mustAllApplyElims es -- Andreas, 2010-10-11: allowing neutrals to be blocked things does not seem -- to change Agda's behavior -- isNeutral Blocked{} = False@@ -344,6 +333,10 @@ -- to trigger a reduction. isNeutral (NotBlocked r (Def q _)) = do -- Andreas, 2014-12-06 optimize this using r !! not <$> usesCopatterns q -- a def by copattern can reduce if projected+ isNeutral (NotBlocked r (Var i _)) = do+ -- Local rewrite rules can also make a variable applications+ -- reduce if projected+ not <$> rewUsesCopatterns (RewVarHead i) isNeutral _ = return True -- Amy, 2024-01-29: Is this blocked application headed by one of the@@ -370,6 +363,36 @@ mCub = isJust (isCubicalPrimHead m) nCub = isJust (isCubicalPrimHead n) + -- Amy, 2024-01-29 (fixing issue pointed out by Tom Jack):+ --+ -- Cubical primitives reduce to something awful, so we would like to skip comparing them (causes+ -- "timeout" in GroupPath).+ --+ -- We would also like to skip comparing a cubical primitive against something that is *small* and+ -- actually neutral (causes "timeout" in KleinBottle cohomology groups, comparing a 93KiB(!) transport+ -- against an application of set-truncation recursion to a metavariable)+ --+ -- The conditions for skipping eta expansion are thus:+ --+ -- (n) both are neutrals (which in this case also includes a "suspended"/copattern transp/hcomp); and+ --+ -- (c1) if both are headed by a cubical primitive, then they are the same primitive; or+ --+ -- (New! 2025-07-23:)+ -- (c2) if one side is a cubical primitive, then the other side must be actually *blocked*+ -- This prevents us from not noticing things like transport (λ i → Nat × Nat) x ≡ x+ -- (transport on Σ is "defined by copatterns" so both sides are "neutral",+ -- but the transport is a pair that contains x .fst and x .snd!)+ --+ -- So we will skip expanding transp A φ u0 = transp A' φ' u0', since it's definitionally injective;+ -- We will skip expanding transp A φ u0 = f ?, since it's wasted work; but we will not skip+ -- transp A φ u0 = hcomp u u0', since those must both compute if they are to be equal.+ cubSkipOk+ | mCub && nCub = h1 == h2+ | mCub, Blocked{} <- n = True+ | Blocked{} <- m, nCub = True+ | otherwise = mCub == nCub+ when (mCub || nCub) $ reportSDoc "tc.conv.term.cubical" 30 $ vcat [ ("m (" <> prettyTCM mNeutral <> ", " <> prettyTCM mCub <> ", " <> prettyTCM h1 <> "):")@@ -379,29 +402,14 @@ , "at type" , nest 2 (prettyTCM a') , "same head:" <+> prettyTCM (h1 == h2)+ , "skipping:" <+> prettyTCM cubSkipOk ] if | isMeta m || isMeta n -> do whenProfile Profile.Conversion $ tick "compare at eta-record: meta" compareAtom cmp (AsTermsOf a') (ignoreBlocking m) (ignoreBlocking n) - -- Amy, 2024-01-29 (fixing issue pointed out by Tom Jack):- --- -- Cubical primitives reduce to something awful, so we would like to skip comparing them (causes- -- "timeout" in GroupPath).- --- -- We would also like to skip comparing a cubical primitive against something that is *small* and- -- actually neutral (causes "timeout" in KleinBottle cohomology groups, comparing a 93KiB(!) transport- -- against an application of set-truncation recursion to a metavariable)- --- -- The condition for skipping eta expansion is thus:- -- (a) both are neutrals (which in this case also includes a "suspended"/copattern transp/hcomp)- -- (b) if both are headed by a cubical primitive, then they are the same primitive.- --- -- So we will skip expanding transp A φ u0 = transp A' φ' u0', since it's definitionally injective; We- -- will skip expanding transp A φ u0 = f ?, since it's wasted work; but we will not skip- -- transp A φ u0 = hcomp u u0', since those must both compute if they are to be equal.- | mNeutral && nNeutral && (not (mCub && nCub) || h1 == h2) -> do+ | mNeutral && nNeutral && cubSkipOk -> 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,@@ -412,126 +420,164 @@ 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'+ whenProfile Profile.Conversion $ tick "compare at eta-record: eta-expanding"+ mm' <- etaExpandRecord r ps $ ignoreBlocking m+ nn' <- etaExpandRecord r ps $ ignoreBlocking n+ case (mm', nn') of+ (Just (tel, m'), Just (_, n')) -> do+ -- No subtyping on record terms+ c <- getRecordConstructor r+ -- Record constructors are covariant (see test/succeed/CovariantConstructors).+ compareArgs (repeat $ polFromCmp cmp) []+ (telePi_ tel (raise (size tel) a'))+ (Con c ConOSystem [])+ m' n'+ -- Issue #8636: Eta-expansion may fail if a term is a+ -- constructor of a different (but possibly definitionally+ -- equal under unsolvable constraints) record type. In that+ -- case we fall back to atomic comparison, which will produce a+ -- proper conversion error rather than crashing.+ _ -> compareAtom cmp (AsTermsOf a') (ignoreBlocking m) (ignoreBlocking n) - else (do pathview <- pathView a'- equalPath pathview a' m n)- _ -> compareAtom cmp (AsTermsOf a') m n+ else ret do pathview <- pathView a'+ equalPath pathview a' m n+ _ -> ret $ compareAtom cmp (AsTermsOf a') m n where -- equality at function type (accounts for eta)- equalFun :: (MonadConversion m) => Sort -> Term -> Term -> Term -> m ()+ equalFun :: Sort -> Term -> Term -> Term -> TCM () 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)+ !mp <- fmap getPrimName <$> getBuiltin' builtinIsOne+ let dom' = set dIsFinite False dom+ let asFn = El s (Pi dom' b) case unEl $ unDom dom of Def q [Apply phi] | 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 _ (Pi dom@(view dInfo -> info) b) (Lam _ m) (Lam _ n) = do+ whenProfile Profile.Conversion $ tick "compare at function type"+ let name = suggests [ Suggestion b , Suggestion m , Suggestion n ]+ addConversionContext (ConvLam dom (void b) name)+ $ addContext (name, dom)+ $ compareTerm cmp (absBody b) (absBody m) (absBody n) + equalFun _ (Pi dom@(view dInfo -> info) b) m n = do+ whenProfile Profile.Conversion $ tick "compare at function type"+ let+ (m', n') = let !v = var 0 in raise 1 (m,n) `apply` [Arg info v]+ name = suggests [ Suggestion b , Suggestion m , Suggestion n ]+ addConversionContext (ConvLam dom (void b) name)+ $ addContext (name, dom)+ $ compareTerm cmp (absBody b) m' n'+ equalFun _ _ _ _ = __IMPOSSIBLE__ - equalPath :: (MonadConversion m) => PathView -> Type -> Term -> Term -> m ()+ equalPath :: PathView -> Type -> Term -> Term -> TCM () 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)]- addContext (name, defaultDom interval) $ compareTerm cmp (El (raise 1 s) $ raise 1 (unArg a) `apply` [argN $ var 0]) m' n'+ whenProfile Profile.Conversion $ tick "compare at path type"+ interval <- el primInterval+ let+ (m', n') = raise 1 (m, n) `applyE` [IApply (raise 1 $ unArg x) (raise 1 $ unArg y) (var 0)]+ name = "i" :: String+ addContext (name, defaultDom interval) $ cutConversionErrors $+ compareTerm cmp (El (raise 1 s) $ raise 1 (unArg a) `apply` [argN $ var 0]) m' n' equalPath OType{} a' m n = cmpDef a' m n cmpDef a'@(El s ty) m n = do- mI <- getBuiltinName' builtinInterval- mIsOne <- getBuiltinName' builtinIsOne- mGlue <- getPrimitiveName' builtinGlue- mHComp <- getPrimitiveName' builtinHComp- mSub <- getBuiltinName' builtinSub- mUnglueU <- getPrimitiveTerm' builtin_unglueU- mSubIn <- getBuiltin' builtinSubIn- case ty of- Def q es | Just q == mIsOne -> return ()- Def q es | Just q == mGlue, Just args@(l:_:a:phi:_) <- allApplyElims es -> do- aty <- el' (pure $ unArg l) (pure $ unArg a)- unglue <- prim_unglue- let mkUnglue m = apply unglue $ map (setHiding Hidden) args ++ [argN m]- reportSDoc "conv.glue" 20 $ prettyTCM (aty,mkUnglue m,mkUnglue n)+ mI <- getBuiltinName' builtinInterval+ mIsOne <- getBuiltinName' builtinIsOne+ mGlue <- getPrimitiveName' builtinGlue+ mHComp <- getPrimitiveName' builtinHComp+ mSub <- getBuiltinName' builtinSub+ mUnglueU <- getPrimitiveTerm' builtin_unglueU+ mSubIn <- getBuiltin' builtinSubIn+ case ty of+ Def q es | Just q == mIsOne -> return ()+ Def q es | Just q == mGlue, Just args@(l:_:a:phi:_) <- allApplyElims es -> do+ aty <- el' (pure $ unArg l) (pure $ unArg a)+ unglue <- prim_unglue+ let mkUnglue m = apply unglue $ (map' (setHiding Hidden) args) ++! [argN m]+ reportSDoc "conv.glue" 20 $ prettyTCM (aty,mkUnglue m,mkUnglue n) - -- Amy, 2023-01-04: Here and in hcompu below we *used to*- -- also compare whatever the glued terms would evaluate to- -- on φ. This is very loopy (consider φ = f i or φ = i0:- -- both generate empty substitutions so get us back to- -- exactly the same conversion problem)!- --- -- But is there a reason to do this comparison? The- -- answer, it turns out, is no!- --- -- Suppose you had- -- Γ ⊢ x = glue [φ → t] xb : Glue T S- -- Γ ⊢ y = glue [φ → s] yb : Glue T S- -- Γ ⊢ xb = yb : T- -- Is there a need to check whether Γ φ ⊢ t = s : S? No!- -- That's because the typing rule for glue is something like- -- glue φ : (s : PartialP φ S) (t : T [ φ → s ]) → Glue T S- -- where the bracket notation stands for an "implicit- -- Sub"-type, i.e. Γ, φ ⊢ t = s (definitionally)- --- -- So if we have a glued element, and we have xb = yb, we- -- can be sure that- -- Γ , φ ⊢ t = xb = yb = s- --- -- But what about the general case, where we're not- -- looking at a literal glue? Well, eta for Glue- -- means x = glue [φ → x] (unglue x), so the logic above- -- still applies. On φ, for the reducts to agree, it's- -- enough for the bases to agree.+ -- Amy, 2023-01-04: Here and in hcompu below we *used to*+ -- also compare whatever the glued terms would evaluate to+ -- on φ. This is very loopy (consider φ = f i or φ = i0:+ -- both generate empty substitutions so get us back to+ -- exactly the same conversion problem)!+ --+ -- But is there a reason to do this comparison? The+ -- answer, it turns out, is no!+ --+ -- Suppose you had+ -- Γ ⊢ x = glue [φ → t] xb : Glue T S+ -- Γ ⊢ y = glue [φ → s] yb : Glue T S+ -- Γ ⊢ xb = yb : T+ -- Is there a need to check whether Γ φ ⊢ t = s : S? No!+ -- That's because the typing rule for glue is something like+ -- glue φ : (s : PartialP φ S) (t : T [ φ → s ]) → Glue T S+ -- where the bracket notation stands for an "implicit+ -- Sub"-type, i.e. Γ, φ ⊢ t = s (definitionally)+ --+ -- So if we have a glued element, and we have xb = yb, we+ -- can be sure that+ -- Γ , φ ⊢ t = xb = yb = s+ --+ -- But what about the general case, where we're not+ -- looking at a literal glue? Well, eta for Glue+ -- means x = glue [φ → x] (unglue x), so the logic above+ -- still applies. On φ, for the reducts to agree, it's+ -- enough for the bases to agree. - 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- , Just unglueU <- mUnglueU, Just subIn <- mSubIn- -> do- let l = Level lvl- ty <- el' (pure $ l) (pure $ unArg u0)- let bA = subIn `apply` [sl,s,phi,u0]- let mkUnglue m = apply unglueU $ [argH l] ++ map (setHiding Hidden) [phi,u] ++ [argH bA,argN m]- reportSDoc "conv.hcompU" 20 $ prettyTCM (ty,mkUnglue m,mkUnglue n)- compareTerm cmp ty (mkUnglue m) (mkUnglue n)- Def q es | Just q == mSub, Just args@(l:a:_) <- allApplyElims es -> do- ty <- el' (pure $ unArg l) (pure $ unArg a)- out <- primSubOut- let mkOut m = apply out $ map (setHiding Hidden) args ++ [argN m]- compareTerm cmp ty (mkOut m) (mkOut n)- Def q [] | Just q == mI -> compareInterval cmp a' m n- _ -> compareAtom cmp (AsTermsOf a') m n+ compareTerm cmp aty (mkUnglue m) (mkUnglue n) -compareAtomDir :: MonadConversion m => CompareDirection -> CompareAs -> Term -> Term -> m ()+ Def q es+ | Just q == mHComp, Just (sl:s:args@[phi,u,u0]) <- allApplyElims es+ , Sort (Type lvl) <- unArg s+ , Just unglueU <- mUnglueU, Just subIn <- mSubIn -> do+ let l = Level lvl+ ty <- el' (pure $ l) (pure $ unArg u0)+ let bA = subIn `apply` [sl,s,phi,u0]+ let mkUnglue m = apply unglueU $! [argH l] ++! map' (setHiding Hidden) [phi,u] ++! [argH bA,argN m]+ reportSDoc "conv.hcompU" 20 $ prettyTCM (ty,mkUnglue m,mkUnglue n)+ compareTerm cmp ty (mkUnglue m) (mkUnglue n)++ Def q es | Just q == mSub, Just args@(l:a:_) <- allApplyElims es -> do+ ty <- el' (pure $ unArg l) (pure $ unArg a)+ out <- primSubOut+ let mkOut m = apply out $! map' (setHiding Hidden) args ++! [argN m]+ compareTerm cmp ty (mkOut m) (mkOut n)++ Def q [] | Just q == mI -> compareInterval cmp a' m n+ _ -> compareAtom cmp (AsTermsOf a') m n++compareAtomDir :: CompareDirection -> CompareAs -> Term -> Term -> TCM () compareAtomDir dir a = dirToCmp (`compareAtom` a) dir -- | Compute the head type of an elimination. For projection-like functions -- this requires inferring the type of the principal argument.-computeElimHeadType :: MonadConversion m => QName -> Elims -> Elims -> m Type+computeElimHeadType :: QName -> Elims -> Elims -> TCM Type computeElimHeadType f [] es' = computeDefType f es' computeElimHeadType f es _ = computeDefType f es +-- | Compute the type of a rewrite rule head. For projection-like+-- functions, this requires inferring the type of the principal argument,+-- using the eliminations.+computeRewHeadType ::+ Int -- Size of the "rewrite rule telescope"+ -> RewriteHead -- Rewrite rule head we want to compute the type of+ -> Elims -- Eliminations+ -> Elims -- Alternative eliminations, used if the first is empty+ -> TCM Type+computeRewHeadType !telSize (RewDefHead f) !es !es' = computeElimHeadType f es es'+computeRewHeadType telSize (RewVarHead x) es es' = typeOfBV $ x + telSize+ -- | Syntax directed equality on atomic values ---compareAtom :: forall m. MonadConversion m => Comparison -> CompareAs -> Term -> Term -> m ()+compareAtom :: Comparison -> CompareAs -> Term -> Term -> TCM () compareAtom cmp t m n = verboseBracket "tc.conv.atom" 20 "compareAtom" $ -- if a PatternErr is thrown, rebuild constraint!- (catchConstraint (ValueCmp cmp t m n) :: m () -> m ()) $ do+ (catchConstraint (ValueCmp cmp t m n) :: TCM () -> TCM ()) $ do reportSLn "tc.conv.atom.size" 50 $ "compareAtom term size: " ++ show (termSize m, termSize n) reportSDoc "tc.conv.atom" 50 $ "compareAtom" <+> fsep [ prettyTCM m <+> prettyTCM cmp@@ -540,23 +586,23 @@ ] whenProfile Profile.Conversion $ tick "compare by reduction" -- Are we currently defining mutual functions? Which?- currentMutuals <- maybe (pure Set.empty) (mutualNames <.> lookupMutualBlock) =<< asksTC envMutualBlock+ currentMutuals <-+ maybe (pure Set.empty) (mutualNames <.> lookupMutualBlock) =<< viewTC eMutualBlock -- 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')+ mb' <- etaExpandBlocked =<< reduceB m+ nb' <- etaExpandBlocked =<< reduceB n+ 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 -- only needed if the other side is not a literal- (mb'', nb'') <- case (ignoreBlocking mb', ignoreBlocking nb') of- (Lit _, Lit _) -> return (mb', nb')- _ -> (,) <$> traverse constructorForm mb'- <*> traverse constructorForm nb'+ (mb'', nb'') <- expand \ret -> case (ignoreBlocking mb', ignoreBlocking nb') of+ (Lit _, Lit _) -> ret $ return (mb', nb')+ _ -> ret $ (,) <$!> traverse constructorForm mb'+ <*!> traverse constructorForm nb' mb <- traverse unLevel mb'' nb <- traverse unLevel nb''@@ -568,7 +614,7 @@ checkDefinitionalEquality = unlessM (pureCompareAs CmpEq t m n) notEqual - notEqual = typeError $ UnequalTerms cmp m n t+ notEqual = failConversion cmp m n t dir = fromCmp cmp rid = flipCmp dir -- The reverse direction. Bad name, I know.@@ -585,20 +631,20 @@ "compareAtom" <+> fsep [ pretty mb <+> prettyTCM cmp , pretty nb , ":" <+> pretty t ]- case (mb, nb) of+ expand \ret -> 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.- compareMetas cmp t x xArgs y yArgs+ ret $ compareMetas cmp t x xArgs y yArgs -- one side a meta- _ | MetaV x es <- ignoreBlocking mb -> assign dir x es n- _ | MetaV x es <- ignoreBlocking nb -> assign rid x es m- (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- bs -> do+ _ | MetaV x es <- ignoreBlocking mb -> ret $ assign dir x es n+ _ | MetaV x es <- ignoreBlocking nb -> ret $ assign rid x es m+ (Blocked{}, Blocked{}) | not cmpBlocked -> ret $ checkDefinitionalEquality+ (Blocked b _, _) | not cmpBlocked -> ret $ useInjectivity (fromCmp cmp) b t m n -- The blocked term goes first+ (_, Blocked b _) | not cmpBlocked -> ret $ useInjectivity (flipCmp $ fromCmp cmp) b t n m+ bs -> ret do blockOnError blocker $ do -- -- Andreas, 2013-10-20 put projection-like function -- -- into the spine, to make compareElims work.@@ -609,22 +655,22 @@ -- Andreas, 2015-07-01, actually, don't put them into the spine. -- Polarity cannot be communicated properly if projection-like -- functions are post-fix.- case (m, n) of- (Pi{}, Pi{}) -> equalFun m n+ expand \ret -> case (m, n) of+ (Pi{}, Pi{}) -> ret $ equalFun m n - (Sort s1, Sort s2) ->+ (Sort s1, Sort s2) -> ret $ ifM (optCumulativity <$> pragmaOptions) (compareSort cmp s1 s2) (equalSort s1 s2) - (Lit l1, Lit l2) | l1 == l2 -> return ()- (Var i es, Var i' es') | i == i' -> do+ (Lit l1, Lit l2) | l1 == l2 -> ret $ return ()+ (Var i es, Var i' es') | i == i' -> ret do a <- typeOfBV i -- Variables are invariant in their arguments compareElims [] [] a (var i) es es' -- The case of definition application:- (Def f es, Def f' es') -> do+ (Def f es, Def f' es') -> ret do -- 1. All absurd lambdas are equal. unlessM (bothAbsurd f f') $ do@@ -648,7 +694,7 @@ -- Due to eta-expansion, these constructors are fully applied. (Con x ci xArgs, Con y _ yArgs)- | x == y -> do+ | x == y -> ret do -- Get the type of the constructor instantiated to the datatype parameters. a' <- case t of AsTermsOf a -> conType x a@@ -658,19 +704,19 @@ -- Constructors are covariant in their arguments -- (see test/succeed/CovariantConstructors). compareElims (repeat $ polFromCmp cmp) forcedArgs a' (Con x ci []) xArgs yArgs- _ -> notEqual+ _ -> ret notEqual where -- returns True in case we handled the comparison already.- compareEtaPrims :: MonadConversion m => QName -> Elims -> Elims -> m Bool+ compareEtaPrims :: QName -> Elims -> Elims -> TCM Bool compareEtaPrims q es es' = do munglue <- getPrimitiveName' builtin_unglue munglueU <- getPrimitiveName' builtin_unglueU msubout <- getPrimitiveName' builtinSubOut case () of- _ | Just q == munglue -> compareUnglueApp q es es'+ _ | Just q == munglue -> compareUnglueApp q es es' _ | Just q == munglueU -> compareUnglueUApp q es es'- _ | Just q == msubout -> compareSubApp q es es'- _ -> return False+ _ | Just q == msubout -> compareSubApp q es es'+ _ -> return False compareSubApp q es es' = do let (as,bs) = splitAt 5 es; (as',bs') = splitAt 5 es' case (allApplyElims as, allApplyElims as') of@@ -681,15 +727,15 @@ -- since b and b' should be neutral terms, but it's a -- precondition for the compareAtom call to make -- sense.- equalType (El (tmSSort $ unArg a) $ apply tSub $ a : map (setHiding NotHidden) [bA,phi,u])- (El (tmSSort $ unArg a) $ apply tSub $ a : map (setHiding NotHidden) [bA',phi',u'])- compareAtom cmp (AsTermsOf $ El (tmSSort $ unArg a) $ apply tSub $ a : map (setHiding NotHidden) [bA,phi,u])+ equalType (El (tmSSort $ unArg a) $! apply tSub $! (a :) $! map' (setHiding NotHidden) [bA,phi,u])+ (El (tmSSort $ unArg a) $! apply tSub $! (a :) $! map' (setHiding NotHidden) [bA',phi',u'])+ compareAtom cmp (AsTermsOf $ El (tmSSort $ unArg a) $! apply tSub $! (a :) $! map' (setHiding NotHidden) [bA,phi,u]) (unArg x) (unArg x')- compareElims [] [] (El (tmSort (unArg a)) (unArg bA)) (Def q as) bs bs'+ () <- compareElims [] [] (El (tmSort (unArg a)) (unArg bA)) (Def q as) bs bs' return True _ -> return False compareUnglueApp q es es' = do- let (as,bs) = splitAt 7 es; (as',bs') = splitAt 7 es'+ let (as,bs) = splitAt' 7 es; (as',bs') = splitAt' 7 es' case (allApplyElims as, allApplyElims as') of (Just [la,lb,bA,phi,bT,e,b], Just [la',lb',bA',phi',bT',e',b']) -> do tGlue <- getPrimitiveTerm builtinGlue@@ -700,14 +746,14 @@ -- sense. -- equalType (El (tmSort (unArg lb)) $ apply tGlue $ [la,lb] ++ map (setHiding NotHidden) [bA,phi,bT,e]) -- (El (tmSort (unArg lb')) $ apply tGlue $ [la',lb'] ++ map (setHiding NotHidden) [bA',phi',bT',e'])- compareAtom cmp (AsTermsOf $ El (tmSort (unArg lb)) $ apply tGlue $ [la,lb] ++ map (setHiding NotHidden) [bA,phi,bT,e])+ compareAtom cmp (AsTermsOf $ El (tmSort (unArg lb)) $ apply tGlue $! [la,lb] ++! map' (setHiding NotHidden) [bA,phi,bT,e]) (unArg b) (unArg b')- compareElims [] [] (El (tmSort (unArg la)) (unArg bA)) (Def q as) bs bs'+ () <- compareElims [] [] (El (tmSort (unArg la)) (unArg bA)) (Def q as) bs bs' return True _ -> return False- compareUnglueUApp :: MonadConversion m => QName -> Elims -> Elims -> m Bool+ compareUnglueUApp :: QName -> Elims -> Elims -> TCM Bool compareUnglueUApp q es es' = do- let (as,bs) = splitAt 5 es; (as',bs') = splitAt 5 es'+ let (as,bs) = splitAt' 5 es; (as',bs') = splitAt' 5 es' case (allApplyElims as, allApplyElims as') of (Just [la,phi,bT,bAS,b], Just [la',phi',bT',bA',b']) -> do tHComp <- primHComp@@ -723,9 +769,9 @@ bT <- open . unArg $ bT bAS <- open . unArg $ bAS (pure tSubOut <#> (pure tLSuc <@> la) <#> (Sort . tmSort <$> la) <#> phi <#> (bT <@> primIZero) <@> bAS)- compareAtom cmp (AsTermsOf $ El (tmSort . unArg $ sucla) $ apply tHComp $ [sucla, argH (Sort s), phi] ++ [argH (unArg bT), argH bA])+ compareAtom cmp (AsTermsOf $ El (tmSort . unArg $ sucla) $ apply tHComp $ [sucla, argH (Sort s), phi] ++! [argH (unArg bT), argH bA]) (unArg b) (unArg b')- compareElims [] [] (El s bA) (Def q as) bs bs'+ () <- compareElims [] [] (El s bA) (Def q as) bs bs' return True _ -> return False -- Andreas, 2013-05-15 due to new postponement strategy, type can now be blocked@@ -743,36 +789,25 @@ -- Thus, instead of crashing, just give up gracefully. patternViolation neverUnblock maybe impossible (return . snd) =<< getFullyAppliedConType c t- equalFun t1 t2 = case (t1, t2) of- (Pi dom1 b1, Pi dom2 b2) -> do+ equalFun t1 t2 = expand \ret -> case (t1, t2) of+ (Pi dom1 b1, Pi dom2 b2) -> ret do verboseBracket "tc.conv.fun" 15 "compare function types" $ do reportSDoc "tc.conv.fun" 20 $ nest 2 $ vcat [ "t1 =" <+> prettyTCM t1 , "t2 =" <+> prettyTCM t2 ]- compareDom cmp dom2 dom1 b1 b2 errH errR errQ errC errP errF $+ compareDom cmp dom2 dom1 b1 b2 (failConversion cmp t1 t2 AsTypes) $ 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- errP = typeError $ UnequalPolarity 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 :: Comparison -> CompareAs -> MetaId -> Elims -> MetaId -> Elims -> TCM () compareMetas cmp t x xArgs y yArgs | x == y = blockOnError (unblockOnMeta x) $ do cmpBlocked <- viewTC eCompareBlocked- let ok = return ()- notOk = patternViolation neverUnblock- fallback = do+ let fallback = do -- Fallback: check definitional equality a <- metaType x- runPureConversion (compareElims [] [] a (MetaV x []) xArgs yArgs) >>= \case- Just{} -> ok- Nothing -> notOk+ runPureConversion (compareElims [] [] a (MetaV x []) xArgs yArgs) if | cmpBlocked -> do a <- metaType x compareElims [] [] a (MetaV x []) xArgs yArgs@@ -782,8 +817,8 @@ -- kills is a list with 'True' for each different var killResult <- killArgs kills x case killResult of- NothingToPrune -> ok- PrunedEverything -> ok+ NothingToPrune -> pure ()+ PrunedEverything -> pure () PrunedNothing -> fallback PrunedSomething -> fallback -- not all relevant arguments are variables@@ -810,42 +845,40 @@ 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+compareDom ::+ Comparison -- ^ @cmp@ The comparison direction -> Dom Type -- ^ @a1@ The smaller domain. -> Dom Type -- ^ @a2@ The other domain.- -> Abs b -- ^ @b1@ The smaller codomain.- -> Abs c -- ^ @b2@ The bigger codomain.- -> m () -- ^ Continuation if mismatch in 'Hiding'.- -> m () -- ^ Continuation if mismatch in 'Relevance'.- -> m () -- ^ Continuation if mismatch in 'Quantity'.- -> m () -- ^ Continuation if mismatch in 'Cohesion'.- -> m () -- ^ Continuation if mismatch in 'Polarity'.- -> 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 errP errF cont = do- if | not $ sameHiding dom1 dom2 -> errH- | not $ (==) (getRelevance dom1) (getRelevance dom2) -> errR- | not $ sameQuantity (getQuantity dom1) (getQuantity dom2) -> errQ- | not $ sameCohesion (getCohesion dom1) (getCohesion dom2) -> errC- | not $ samePolarity (getModalPolarity dom1) (getModalPolarity dom2) -> errP- | not $ domIsFinite dom1 == domIsFinite dom2 -> errF+ -> Abs Type -- ^ @b1@ The smaller codomain.+ -> Abs Type -- ^ @b2@ The bigger codomain.+ -> TCM () -- ^ Error continuation+ -> TCM () -- ^ Success continuation+ -> TCM ()+compareDom cmp0 dom1@(unDom -> a1) dom2@(unDom -> a2) b1 b2 err cont = do+ let i1 = dom1 ^. dInfo; i2 = dom2 ^. dInfo+ if | not $ sameHiding dom1 dom2 -> err+ | not $ (==) (getRelevance dom1) (getRelevance dom2) -> err+ | not $ sameQuantity (getQuantity dom1) (getQuantity dom2) -> err+ | not $ sameCohesion (getCohesion dom1) (getCohesion dom2) -> err+ | not $ samePolarity (getModalPolarity dom1) (getModalPolarity dom2) -> err+ | not $ domIsFinite dom1 == domIsFinite dom2 -> err+ -- We compare both rewrite annotations AND the actual rewDoms to properly+ -- handle the case where we have use a rewrite annotation outside of a+ -- module telescope and continued trying to typecheck+ | not $ getRewriteAnn dom1 == getRewriteAnn dom2+ && isJust (rewDom dom1) == isJust (rewDom dom2) -> err | otherwise -> do let r = max (getRelevance dom1) (getRelevance dom2) -- take "most irrelevant" dependent = not (isIrrelevant r) && isBinderUsed b2- pid <- newProblem_ $ compareType cmp0 a1 a2+ pid <- addConversionContext (\r -> ConvDom (r <$ dom1) b2 b1) $ newProblem_ $ compareType cmp0 a1 a2 dom <- if dependent then (\ a -> dom1 {unDom = a}) <$> blockTypeOnProblem a1 pid else return dom1 -- We only need to require a1 == a2 if b2 is dependent -- If it's non-dependent it doesn't matter what we add to the context. let name = suggests [ Suggestion b1 , Suggestion b2 ]- addContext (name, dom) $ cont+ addConversionContext (ConvCod dom name) $ addContext (name, dom) $ cont stealConstraints pid -- Andreas, 2013-05-15 Now, comparison of codomains is not -- blocked any more by getting stuck on domains.@@ -869,7 +902,7 @@ -- This is really a crutch that lets us get away with things that otherwise -- would require heterogenous conversion checking. See for instance issue -- #2384.-antiUnify :: MonadConversion m => ProblemId -> Type -> Term -> Term -> m Term+antiUnify :: ProblemId -> Type -> Term -> Term -> TCM Term antiUnify pid a u v = do SynEq.checkSyntacticEquality u v (\u _ -> return u) $ \u v -> do (u, v) <- reduce (u, v)@@ -911,7 +944,7 @@ abort = patternViolation neverUnblock -- caught by maybeGiveUp fallback = blockTermOnProblem a u pid -antiUnifyArgs :: MonadConversion m => ProblemId -> Dom Type -> Arg Term -> Arg Term -> m (Arg Term)+antiUnifyArgs :: ProblemId -> Dom Type -> Arg Term -> Arg Term -> TCM (Arg Term) antiUnifyArgs pid dom u v | not (sameModality (getModality u) (getModality v)) = patternViolation neverUnblock@@ -920,12 +953,16 @@ {-then-} (return u) {-else-} ((<$ u) <$> antiUnify pid (unDom dom) (unArg u) (unArg v)) -antiUnifyType :: MonadConversion m => ProblemId -> Type -> Type -> m Type+antiUnifyType :: ProblemId -> Type -> Type -> TCM Type antiUnifyType pid (El s a) (El _ b) = workOnTypes $ El s <$> antiUnify pid (sort s) a b -antiUnifyElims :: MonadConversion m => ProblemId -> Type -> Term -> Elims -> Elims -> m Term+antiUnifyElims :: ProblemId -> Type -> Term -> Elims -> Elims -> TCM Term antiUnifyElims pid a self [] [] = return self antiUnifyElims pid a self (Proj o f : es1) (Proj _ g : es2) | f == g = do+ -- Andreas, 2026-09-05, issue #8532, projectTyped expects reduced type @a@.+ -- The reduce was already absent in the original feature commit a45f5ce (Agda 2.5.3).+ -- The bug was dormant for almost a decade.+ a <- reduce a res <- projectTyped self a o f case res of Just (_, self, a) -> antiUnifyElims pid a self es1 es2@@ -940,13 +977,20 @@ -- | @compareElims pols a v els1 els2@ performs type-directed equality on eliminator spines. -- @t@ is the type of the head @v@.-compareElims :: forall m. MonadConversion m => [Polarity] -> [IsForced] -> Type -> Term -> [Elim] -> [Elim] -> m ()-compareElims pols0 fors0 a v els01 els02 =+--+-- Note: since TCM is lazy in return values from @(>>=)@, it is+-- important that compareElims in non-tail position be called as @() <-+-- compareElims pols a v e1 e2@ so that any internal invariants upheld+-- by returning @__IMPOSSIBLE__@ actually get checked.+compareElims :: [Polarity] -> [IsForced] -> Type -> Term -> [Elim] -> [Elim] -> TCM ()+compareElims !pols0 !fors0 !a !v !els01 !els02 = verboseBracket "tc.conv.elim" 20 "compareElims" $- (catchConstraint (ElimCmp pols0 fors0 a v els01 els02) :: m () -> m ()) $ do+ (catchConstraint (ElimCmp pols0 fors0 a v els01 els02) :: TCM () -> TCM ()) $ do let v1 = applyE v els01 v2 = applyE v els02- failure = typeError $ UnequalTerms CmpEq v1 v2 (AsTermsOf a)++ -- Andreas, issue #8126, hack: use 'AsTypes' to suppress type in error message.+ failure = failConversion CmpEq v1 v2 (AsTermsOf a) -- Andreas, 2013-03-15 since one of the spines is empty, @a@ -- is the correct type here. unless (null els01) $ do@@ -971,8 +1015,35 @@ (Proj{} : _, Apply{} : _) -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True -- but should be impossible (but again in issue 1467) (IApply{} : _, Proj{} : _) -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True (Proj{} : _, IApply{} : _) -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True- (IApply{} : _, Apply{} : _) -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True- (Apply{} : _, IApply{} : _) -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True++ -- Mismatched IApply/Apply is possible: Cubical.Foundations.Prelude.compPathP, Issue3601+ -- Either keep comparing as functions or as paths depending on the type of the head.+ (e@(IApply _ _ r1) : els1, els2@(Apply r2:els2')) -> do+ a <- abortIfBlocked a+ va <- pathView a+ case va of+ OType t@(El _ Pi{}) -> compareElims pols0 fors0 t v (Apply (defaultArg r1):els1) els2+ PathType s path l bA x y -> do+ let (pol, pols) = nextPolarity pols0+ b <- primIntervalType+ compareWithPol pol (flip compareTerm b) r1 (unArg r2)+ codom <- el' (pure . unArg $ l) ((pure . unArg $ bA) <@> pure r1)+ compareElims pols [] codom (applyE v [e]) els1 els2'+ _ -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True++ (els1@(Apply r1:els1'), e@(IApply _ _ r2):els2) -> do+ a <- abortIfBlocked a+ va <- pathView a+ case va of+ OType t@(El _ Pi{}) -> compareElims pols0 fors0 t v els1 (Apply (defaultArg r2):els2)+ PathType s path l bA x y -> do+ let (pol, pols) = nextPolarity pols0+ b <- primIntervalType+ compareWithPol pol (flip compareTerm b) (unArg r1) r2+ codom <- el' (pure . unArg $ l) ((pure . unArg $ bA) <@> pure r2)+ compareElims pols [] codom (applyE v [e]) els1' els2+ _ -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True+ (e@(IApply x1 y1 r1) : els1, IApply x2 y2 r2 : els2) -> do reportSDoc "tc.conv.elim" 25 $ "compareElims IApply" -- Andrea: copying stuff from the Apply case..@@ -995,10 +1066,13 @@ -- because @etaContract@ can produce such terms OType t@(El _ Pi{}) -> compareElims pols0 fors0 t v (Apply (defaultArg r1) : els1) (Apply (defaultArg r2) : els2) - OType t -> patternViolation (unblockOnAnyMetaIn t) -- Can we get here? We know a is not blocked.+ OType t -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True + -- András 2026-03-26: this is one of the hottest pieces of code in Agda, so it makes a lot of+ -- sense to do focused core optimization on it. We add an 'expand' to every branching to make+ -- sure that GHC doesn't compile them to closures. (Apply arg1 : els1, Apply arg2 : els2) ->- (verboseBracket "tc.conv.elim" 20 "compare Apply" :: m () -> m ()) $ do+ (verboseBracket "tc.conv.elim" 20 "compare Apply" :: TCM () -> TCM ()) $ do reportSDoc "tc.conv.elim" 10 $ nest 2 $ vcat [ "a =" <+> prettyTCM a , "v =" <+> prettyTCM v@@ -1017,60 +1091,91 @@ a <- abortIfBlocked a reportSLn "tc.conv.elim" 40 $ "type is not blocked" case unEl a of- (Pi (Dom{domInfo = info, unDom = b}) codom) -> do+ (Pi dom@(unDom -> b) codom) -> do+ let info = dom ^. dInfo reportSLn "tc.conv.elim" 40 $ "type is a function type"- mlvl <- tryMaybe primLevel- let freeInCoDom (Abs _ c) = 0 `freeInIgnoringSorts` c- freeInCoDom _ = False- dependent = (Just (unEl b) /= mlvl) && freeInCoDom codom- -- Level-polymorphism (x : Level) -> ... does not count as dependency here- -- NB: we could drop the free variable test and still be sound.- -- It is a trade-off between the administrative effort of- -- creating a blocking and traversing a term for free variables.- -- Apparently, it is believed that checking free vars is cheaper.- -- Andreas, 2013-05-15 --- NEW, Andreas, 2013-05-15+ dependent <- do+ -- András, 2026-04-03: skipping the freeInIgnoringSorts+ -- is faster, but it causes "cubical" to loop when lossy unification+ -- is on! TODO: figure out.+ let freeInCoDom (Abs _ c) = 0 `freeInIgnoringSorts` c -- True+ freeInCoDom _ = False - -- compare arg1 and arg2- pid <- newProblem_ $ applyModalityToContext info $- if isForced for then+ expand \ret -> if freeInCoDom codom then ret do+ mlvl <- getBuiltin' BuiltinLevel+ -- Level-polymorphism (x : Level) -> ... does not count as dependency here+ -- NB: we could drop the free variable test and still be sound.+ -- It is a trade-off between the administrative effort of+ -- creating a blocking and traversing a term for free variables.+ -- Apparently, it is believed that checking free vars is cheaper.+ -- Andreas, 2013-05-15+ pure $! Just (unEl b) /= mlvl+ else ret do+ pure False++ expand \ret -> if dependent then ret do++ -- compare arg1 and arg2+ pid <- addConversionContext (\z -> ConvApply v codom (Arg info z) els1 els2) $+ newProblemDontWake_ $ applyModalityToContext info $+ expand \ret -> if isForced for then ret $ reportSLn "tc.conv.elim" 40 $ "argument is forced"- else if isIrrelevant info then do+ else ret $ expand \ret -> if isIrrelevant info then ret do reportSLn "tc.conv.elim" 40 $ "argument is irrelevant" compareIrrelevant b (unArg arg1) (unArg arg2)- else do+ else ret do reportSLn "tc.conv.elim" 40 $ "argument has polarity " ++ show pol- compareWithPol pol (flip compareTerm b)- (unArg arg1) (unArg arg2)- -- if comparison got stuck and function type is dependent, block arg- solved <- isProblemSolved pid- reportSLn "tc.conv.elim" 40 $ "solved = " ++ show solved- arg <- if dependent && not solved- then applyModalityToContext info $ do- reportSDoc "tc.conv.elims" 50 $ vcat $- [ "Trying antiUnify:"- , nest 2 $ "b =" <+> prettyTCM b- , nest 2 $ "arg1 =" <+> prettyTCM arg1- , nest 2 $ "arg2 =" <+> prettyTCM arg2- ]- arg <- (arg1 $>) <$> antiUnify pid b (unArg arg1) (unArg arg2)- reportSDoc "tc.conv.elims" 50 $ hang "Anti-unification:" 2 (prettyTCM arg)- reportSDoc "tc.conv.elims" 70 $ nest 2 $ "raw:" <+> pretty arg- return arg- else return arg1- -- continue, possibly with blocked instantiation- compareElims pols fors (codom `lazyAbsApp` unArg arg) (apply v [arg]) els1 els2- -- any left over constraints of arg are associated to the comparison- reportSLn "tc.conv.elim" 40 $ "stealing constraints from problem " ++ show pid- stealConstraints pid- {- Stealing solves this issue:+ compareWithPol pol (flip compareTerm b) (unArg arg1) (unArg arg2) - Does not create enough blocked tc-problems,- see test/fail/DontPrune.- (There are remaining problems which do not show up as yellow.)- Need to find a way to associate pid also to result of compareElims.- -}+ -- if comparison got stuck, block arg+ solved <- isProblemSolved'' pid+ reportSLn "tc.conv.elim" 40 $ "solved = " ++ show solved+ arg <- expand \ret -> if not solved then ret do+ applyModalityToContext info $ do+ reportSDoc "tc.conv.elims" 50 $ vcat $+ [ "Trying antiUnify:"+ , nest 2 $ "b =" <+> prettyTCM b+ , nest 2 $ "arg1 =" <+> prettyTCM arg1+ , nest 2 $ "arg2 =" <+> prettyTCM arg2+ ]+ arg <- (arg1 $>) <$> antiUnify pid b (unArg arg1) (unArg arg2)+ reportSDoc "tc.conv.elims" 50 $ hang "Anti-unification:" 2 (prettyTCM arg)+ reportSDoc "tc.conv.elims" 70 $ nest 2 $ "raw:" <+> pretty arg+ return arg+ else ret $ return arg1+ -- continue, possibly with blocked instantiation+ () <- compareElims pols fors (codom `lazyAbsApp` unArg arg) (apply v [arg]) els1 els2++ expand \ret -> if not solved then ret do+ -- any left over constraints of arg are associated to the comparison+ reportSLn "tc.conv.elim" 40 $ "stealing constraints from problem " ++ show pid+ stealConstraints pid+ {- Stealing solves this issue:++ Does not create enough blocked tc-problems,+ see test/fail/DontPrune.+ (There are remaining problems which do not show up as yellow.)+ Need to find a way to associate pid also to result of compareElims.+ -}+ else ret $ pure ()++ else ret do+ -- compare arg1 and arg2+ addConversionContext (\z -> ConvApply v codom (Arg info z) els1 els2) $+ applyModalityToContext info $+ expand \ret -> if isForced for then ret $+ reportSLn "tc.conv.elim" 40 $ "argument is forced"+ else ret $ expand \ret -> if isIrrelevant info then ret do+ reportSLn "tc.conv.elim" 40 $ "argument is irrelevant"+ compareIrrelevant b (unArg arg1) (unArg arg2)+ else ret do+ reportSLn "tc.conv.elim" 40 $ "argument has polarity " ++ show pol+ compareWithPol pol (flip compareTerm b) (unArg arg1) (unArg arg2)++ -- continue+ compareElims pols fors (codom `lazyAbsApp` unArg arg1) (apply v [arg1]) els1 els2+ a -> do reportSDoc "impossible" 10 $ "unexpected type when comparing apply eliminations " <+> prettyTCM a@@ -1083,8 +1188,22 @@ -- case: f == f' are projections (Proj o f : els1, Proj _ f' : els2)- | f /= f' -> typeError $ MismatchedProjectionsError f f'- | otherwise -> do+ | f /= f' -> do+ -- Andreas, 2026-09-05, while working on #8532: projectTyped expects reduced type.+ a <- reduce a+ -- Andreas, 2025-10-06, issue #8126+ -- If we are dealing with generalizable variables rather than projections,+ -- do not throw a MismatchedProjectionsError, but rather a generic f != f' error.+ reportSDoc "tc.error.mismatchedProjections" 30 $ "type:" <+> prettyTCM a+ reportSDoc "tc.error.mismatchedProjections" 40 $ "type:" <+> pretty a+ reportSDoc "tc.error.mismatchedProjections" 30 $ "f = " <+> prettyTCM f+ reportSDoc "tc.error.mismatchedProjections" 40 $ "f = " <+> pretty f+ t1 <- projectTyped v a o f+ t2 <- projectTyped v a o f'+ case (,) <$> t1 <*> t2 of+ Just ((_, lhs, t1), (_, rhs, t2)) -> mismatchedProjections t1 lhs els1 t2 rhs els2+ Nothing -> typeError $ MismatchedProjectionsError f f'+ | otherwise -> do a <- abortIfBlocked a res <- projectTyped v a o f -- fails only if f is proj.like but parameters cannot be retrieved case res of@@ -1102,17 +1221,17 @@ ] patternViolation (unblockOnAnyMetaIn a) -+{-# NOINLINE compareIrrelevant #-} -- | "Compare" two terms in irrelevant position. This always succeeds. -- However, we can dig for solutions of irrelevant metas in the -- terms we compare. -- (Certainly not the systematic solution, that'd be proof search...)-compareIrrelevant :: MonadConversion m => Type -> Term -> Term -> m ()+compareIrrelevant :: Type -> Term -> Term -> TCM () {- 2012-04-02 DontCare no longer present compareIrrelevant t (DontCare v) w = compareIrrelevant t v w compareIrrelevant t v (DontCare w) = compareIrrelevant t v w -}-compareIrrelevant t v0 w0 = do+compareIrrelevant !t !v0 !w0 = do let v = stripDontCare v0 w = stripDontCare w0 reportSDoc "tc.conv.irr" 20 $ vcat@@ -1147,7 +1266,8 @@ -- the value of irrelevant or unused meta does not matter try v w fallback = fallback -compareWithPol :: MonadConversion m => Polarity -> (Comparison -> a -> a -> m ()) -> a -> a -> m ()+{-# INLINE compareWithPol #-}+compareWithPol :: Polarity -> (Comparison -> a -> a -> TCM ()) -> a -> a -> TCM () compareWithPol Invariant cmp x y = cmp CmpEq x y compareWithPol Covariant cmp x y = cmp CmpLeq x y compareWithPol Contravariant cmp x y = cmp CmpLeq y x@@ -1159,17 +1279,16 @@ -- | Type-directed equality on argument lists ---compareArgs :: MonadConversion m => [Polarity] -> [IsForced] -> Type -> Term -> Args -> Args -> m ()+compareArgs :: [Polarity] -> [IsForced] -> Type -> Term -> Args -> Args -> TCM () compareArgs pol for a v args1 args2 =- compareElims pol for a v (map Apply args1) (map Apply args2)+ compareElims pol for a v (map' Apply args1) (map' Apply args2) --------------------------------------------------------------------------- -- * Types --------------------------------------------------------------------------- -{-# SPECIALIZE compareType :: Comparison -> Type -> Type -> TCM () #-} -- | Equality on Types-compareType :: MonadConversion m => Comparison -> Type -> Type -> m ()+compareType :: Comparison -> Type -> Type -> TCM () compareType cmp ty1@(El s1 a1) ty2@(El s2 a2) = workOnTypes $ verboseBracket "tc.conv.type" 20 "compareType" $ do@@ -1180,18 +1299,17 @@ ] compareAs cmp AsTypes a1 a2 -leqType :: MonadConversion m => Type -> Type -> m ()+leqType :: Type -> Type -> TCM () leqType = compareType CmpLeq -{-# SPECIALIZE coerce :: Comparison -> Term -> Type -> Type -> TCM Term #-} -- | @coerce v a b@ coerces @v : a@ to type @b@, returning a @v' : b@ -- with maybe extra hidden applications or hidden abstractions. -- -- In principle, this function can host coercive subtyping, but -- currently it only tries to fix problems with hidden function types. ---coerce :: (MonadConversion m, MonadTCM m) => Comparison -> Term -> Type -> Type -> m Term-coerce cmp v t1 t2 = blockTerm t2 $ do+coerce :: Comparison -> Term -> Type -> Type -> TCM Term+coerce !cmp !v !t1 !t2 = cutConversionErrors $ blockTerm t2 $ do verboseS "tc.conv.coerce" 10 $ do (a1,a2) <- reify (t1,t2) let dbglvl = 30@@ -1223,11 +1341,10 @@ ifBlocked b2 (\ _ _ -> fallback) $ \ _ _ -> do (args, t1') <- implicitArgs n notVisible t1 let v' = v `apply` args- v' <$ coerceSize (compareType cmp) v' t1' t2+ v' <$ coerceSize cmp v' t1' t2 where- fallback = v <$ coerceSize (compareType cmp) v t1 t2+ fallback = v <$ coerceSize cmp v t1 t2 -{-# SPECIALIZE coerceSize :: (Type -> Type -> TCM ()) -> Term -> Type -> Type -> TCM () #-} -- | Account for situations like @k : (Size< j) <= (Size< k + 1)@ -- -- Actually, the semantics is@@ -1237,8 +1354,8 @@ -- -- For now, we do a cheap heuristics. ---coerceSize :: MonadConversion m => (Type -> Type -> m ()) -> Term -> Type -> Type -> m ()-coerceSize leqType v t1 t2 = verboseBracket "tc.conv.size.coerce" 45 "coerceSize" $+coerceSize :: Comparison -> Term -> Type -> Type -> TCM ()+coerceSize !cmp !v !t1 !t2 = verboseBracket "tc.conv.size.coerce" 45 "coerceSize" $ workOnTypes $ do reportSDoc "tc.conv.size.coerce" 70 $ "coerceSize" <+> vcat@@ -1246,7 +1363,7 @@ , "from type t1 =" <+> pretty t1 , "to type t2 =" <+> pretty t2 ]- let fallback = leqType t1 t2+ let fallback = compareType cmp t1 t2 done = caseMaybeM (isSizeType =<< reduce t1) fallback $ \ _ -> return () -- Andreas, 2015-07-22, Issue 1615: -- If t1 is a meta and t2 a type like Size< v2, we need to make sure we do not miss@@ -1258,7 +1375,7 @@ mv <- sizeMaxView v if any (\case{ DOtherSize{} -> True; _ -> False }) mv then fallback else do -- Andreas, 2015-02-11 do not instantiate metas here (triggers issue 1203).- unlessM (tryConversion $ dontAssignMetas $ leqType t1 t2) $ do+ unlessM (tryConversion $ dontAssignMetas $ compareType cmp t1 t2) $ do -- A (most probably weaker) alternative is to just check syn.eq. -- ifM (snd <$> checkSyntacticEquality t1 t2) (return v) $ {- else -} do reportSDoc "tc.conv.size.coerce" 20 $ "coercing to a size type"@@ -1286,11 +1403,11 @@ -- * Sorts and levels --------------------------------------------------------------------------- -compareLevel :: MonadConversion m => Comparison -> Level -> Level -> m ()+compareLevel :: Comparison -> Level -> Level -> TCM () compareLevel CmpLeq u v = leqLevel u v compareLevel CmpEq u v = equalLevel u v -compareSort :: MonadConversion m => Comparison -> Sort -> Sort -> m ()+compareSort :: Comparison -> Sort -> Sort -> TCM () compareSort CmpEq = equalSort compareSort CmpLeq = leqSort @@ -1299,7 +1416,7 @@ -- We can put @SizeUniv@ below @Inf@, but otherwise, it is -- unrelated to the other universes. ---leqSort :: forall m. MonadConversion m => Sort -> Sort -> m ()+leqSort :: Sort -> Sort -> TCM () leqSort s1 s2 = do reportSDoc "tc.conv.sort" 30 $ sep [ "leqSort"@@ -1343,7 +1460,7 @@ omegaInOmegaEnabled <- optOmegaInOmega <$> pragmaOptions let infInInf = typeInTypeEnabled || omegaInOmegaEnabled - let fvsRHS = (`IntSet.member` allFreeVars s2)+ let fvsRHS = (`VarSet.member` freeVarSet s2) badRigid <- s1 `rigidVarsNotContainedIn` fvsRHS postponeIfBlocked $ case (s1, s2) of@@ -1421,7 +1538,7 @@ ] __IMPOSSIBLE__ -leqLevel :: MonadConversion m => Level -> Level -> m ()+leqLevel :: Level -> Level -> TCM () leqLevel a b = catchConstraint (LevelCmp CmpLeq a b) $ do reportSDoc "tc.conv.level" 30 $ "compareLevel" <+>@@ -1509,7 +1626,7 @@ (as , bs) | cumulativity , not areWeComputingOverlap- , Just (mb@(MetaV x es) , bs') <- singleMetaView $ (map . fmap) ignoreBlocking (List1.toList bs)+ , Just (mb@(MetaV x es) , bs') <- singleMetaView $ (map' . fmap) ignoreBlocking (List1.toList bs) , null bs' || noMetas (Level a , unSingleLevels bs') -> do mv <- lookupLocalMeta x -- Jesper, 2019-10-13: abort if this is an interaction@@ -1559,11 +1676,11 @@ isMetaLevel (SinglePlus (Plus _ MetaV{})) = True isMetaLevel _ = False -{-# SPECIALIZE equalLevel :: Level -> Level -> TCM () #-}-equalLevel :: forall m. MonadConversion m => Level -> Level -> m ()+equalLevel :: Level -> Level -> TCM () 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"+ lvl <- levelType' -- 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@@ -1596,7 +1713,7 @@ reportSDoc "tc.conv.level" 60 "checkSyntacticEquality returns False" let notok = unlessM typeInType notOk- notOk = typeError $ UnequalLevel CmpEq a' b'+ notOk = failConversion CmpEq (Level a') (Level b') (AsTermsOf lvl) postpone = do reportSDoc "tc.conv.level" 30 $ hang "postponing:" 2 $ hang (pretty a' <+> "==") 0 (pretty b') blocker <- unblockOnAnyMetaIn <$> instantiateFull (a', b')@@ -1661,7 +1778,6 @@ | MetaV x as' <- ignoreBlocking a , MetaV y bs' <- ignoreBlocking b , k == l -> do- lvl <- levelType' compareMetas CmpEq (AsTermsOf lvl) x as' y bs' (SinglePlus (Plus k a) :| [] , _) | MetaV x as' <- ignoreBlocking a@@ -1700,7 +1816,7 @@ -- 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]+ reportSDoc "tc.meta.level" 50 $ "meta" <+> sep [prettyList $ map' pretty as, pretty b] lvl <- levelType' assignE DirEq x as (levelTm b) (AsTermsOf lvl) (===) -- fallback: check equality as atoms @@ -1730,9 +1846,8 @@ _ `strictlySubsumes` _ = False -{-# SPECIALIZE equalSort :: Sort -> Sort -> TCM () #-} -- | Check that the first sort equal to the second.-equalSort :: forall m. MonadConversion m => Sort -> Sort -> m ()+equalSort :: Sort -> Sort -> TCM () equalSort s1 s2 = do reportSDoc "tc.conv.sort" 30 $ sep [ "equalSort"@@ -1758,7 +1873,7 @@ blocker = unblockOnEither (getBlocker s1b) (getBlocker s2b) let postponeIfBlocked = catchPatternErr $ \blocker -> do- if | blocker == neverUnblock -> typeError $ UnequalSorts s1 s2+ if | blocker == neverUnblock -> failConversion CmpEq (Sort s1) (Sort s2) AsTypes | otherwise -> do reportSDoc "tc.conv.sort" 30 $ vcat [ "Postponing constraint"@@ -1801,8 +1916,8 @@ (Inf u _ , Univ u' _ ) -> answer $ u == u' && typeInTypeEnabled -- equating @PiSort a b@ to another sort- (s1 , PiSort a b c) -> piSortEquals propEnabled s1 a b c blocker- (PiSort a b c , s2) -> piSortEquals propEnabled s2 a b c blocker+ (s1 , PiSort a b c d) -> piSortEquals propEnabled s1 a b c d blocker+ (PiSort a b c d , s2) -> piSortEquals propEnabled s2 a b c d blocker -- equating @FunSort a b@ to another sort (s1 , FunSort a b) -> funSortEquals propEnabled s1 a b blocker@@ -1831,10 +1946,10 @@ False -> no -- perform assignment (MetaS x es) := s- meta :: MetaId -> [Elim' Term] -> Sort -> m ()+ meta :: MetaId -> [Elim' Term] -> Sort -> TCM () meta x es s = do reportSLn "tc.meta.sort" 30 $ "Assigning meta sort"- reportSDoc "tc.meta.sort" 50 $ "meta" <+> sep [pretty x, prettyList $ map pretty es, pretty s]+ reportSDoc "tc.meta.sort" 50 $ "meta" <+> sep [pretty x, prettyList $ map' pretty es, pretty s] assignE DirEq x es (Sort s) AsTypes __IMPOSSIBLE__ -- Sorts that contain exactly one other kind of sorts.@@ -1849,7 +1964,7 @@ -- Equate a sort @s1@ to @univSort s2@ -- Precondition: @s1@ and @univSort s2@ are already reduced.- univSortEquals :: Bool -> Bool -> Sort -> Sort -> Blocker -> m ()+ univSortEquals :: Bool -> Bool -> Sort -> Sort -> Blocker -> TCM () univSortEquals propEnabled infInInf s1 s2 blocker = do reportSDoc "tc.conv.sort" 35 $ vcat [ "univSortEquals"@@ -1919,9 +2034,11 @@ -- Equate a sort @s@ to @piSort a s1 s2@ -- Precondition: @s@ and @piSort a s1 s2@ are already reduced.- piSortEquals :: Bool -> Sort -> Dom Term -> Sort -> Abs Sort -> Blocker -> m ()- piSortEquals propEnabled s a s1 NoAbs{} blocker = __IMPOSSIBLE__- piSortEquals propEnabled s a s1 s2Abs@(Abs x s2) blocker = do+ piSortEquals ::+ Bool -> Sort -> BlockedDepCheck Sort -> Dom Term -> Sort -> Abs Sort+ -> Blocker -> TCM ()+ piSortEquals propEnabled s c a s1 NoAbs{} blocker = __IMPOSSIBLE__+ piSortEquals propEnabled s c a s1 s2Abs@(Abs x s2) blocker = do let adom = El s1 <$> a reportSDoc "tc.conv.sort" 35 $ vcat [ "piSortEquals"@@ -1929,23 +2046,33 @@ , " a =" <+> prettyTCM adom , " s1 =" <+> prettyTCM s1 , " s2 =" <+> addContext (x,adom) (prettyTCM s2)+ , " c =" <+> pretty c ] 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 | 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 propEnabled s s1 s2' blocker+ -- We force @s2@ to be non-dependent by unifying it with+ -- a fresh meta that does not depend on @x : a@+ s2M <- newSortMeta+ addContext (x , adom) $ equalSort s2 (raise 1 s2M)+ -- This forces @s2@ to be non-dependent, but @s2'@ might still be+ -- dependent!+ -- We therefore need to double check @s2'@ for dependency,+ -- and otherwise postpone+ case c of+ CodomainSortSame -> funSortEquals propEnabled s s1 s2M blocker+ CodomainSortOld s2Old -> liftReduce+ (inLargeEnoughContext s2Old $ forceNonDepSort s2Old) >>= \case+ (NotFree, _) -> funSortEquals propEnabled s s1 s2M blocker+ (MaybeFree _, _) -> postpone -- Otherwise: postpone | otherwise -> postpone -- Equate a sort @s@ to @funSort s1 s2@ -- Precondition: @s@ and @funSort s1 s2@ are already reduced- funSortEquals :: Bool -> Sort -> Sort -> Sort -> Blocker -> m ()+ funSortEquals :: Bool -> Sort -> Sort -> Sort -> Blocker -> TCM () funSortEquals propEnabled s0 s1 s2 blocker = do reportSDoc "tc.conv.sort" 35 $ vcat [ "funSortEquals"@@ -1957,8 +2084,8 @@ cubicalEnabled <- isJust <$> cubicalOption levelUnivEnabled <- optLevelUniverse <$> pragmaOptions let postpone = patternViolation blocker- err :: m ()- err = typeError $ UnequalSorts s0 (FunSort s1 s2)+ err :: TCM ()+ err = failConversion CmpEq (Sort s0) (Sort (FunSort s1 s2)) AsTypes case s0 of -- If @Setωᵢ == funSort s1 s2@, then either @s1@ or @s2@ must -- be @Setωᵢ@.@@ -2013,8 +2140,8 @@ let s1 = ignoreBlocking s1b blocker = getBlocker s1b -- Jesper, 2019-12-27: SizeUniv is disabled at the moment.- if | {- sizedTypesEnabled || -} propEnabled || cubicalEnabled ->- case funSort' s1 (Type l2) of+ if | {- sizedTypesEnabled || -} propEnabled || cubicalEnabled -> do+ funSortM' s1 (Type l2) >>= \case -- If the work we did makes the @funSort@ compute, -- continue working. Right s -> equalSort (Type l) s@@ -2035,12 +2162,12 @@ s1b <- reduceB s1 let s1 = ignoreBlocking s1b blocker = getBlocker s1b- case funSort' s1 (Prop l2) of+ funSortM' s1 (Prop l2) >>= \case -- If the work we did makes the @funSort@ compute, -- continue working. Right s -> equalSort (Prop l) s -- Otherwise: postpone- Left _ -> patternViolation blocker+ Left b -> patternViolation (unblockOnEither blocker b) -- TODO: SSet l @@ -2050,7 +2177,7 @@ -- Anything else: postpone _ -> postpone - forceUniv :: Univ -> Sort -> m Level+ forceUniv :: Univ -> Sort -> TCM Level forceUniv u = \case Univ u' l | u == u' -> return l s -> do@@ -2070,12 +2197,9 @@ err -> throwError err -forallFaceMaps- :: MonadConversion m- => Term- -> (IntMap Bool -> Blocker -> Term -> m a)- -> (IntMap Bool -> Substitution -> m a)- -> m [a]+forallFaceMaps :: Term -> (IntMap Bool -> Blocker -> Term -> TCM a)+ -> (IntMap Bool -> Substitution -> TCM a)+ -> TCM [a] forallFaceMaps t kb k = do reportSDoc "conv.forall" 20 $ fsep ["forallFaceMaps"@@ -2088,7 +2212,7 @@ return (\b -> if b then io else iz) forM as $ \ (ms,ts) -> do ifBlockeds ts (kb ms) $ \ _ _ -> do- let xs = map (second boolToI) $ IntMap.toAscList ms+ let xs = map' (second boolToI) $ IntMap.toAscList ms cxt <- getContext reportSDoc "conv.forall" 20 $ fsep ["substContextN"@@ -2105,14 +2229,14 @@ sub <- getModuleParameterSub m reportSDoc "conv.forall" 30 $ vcat [ text (replicate 10 '-')- , prettyTCM (envCurrentModule $ clEnv cl)+ , prettyTCM (view eCurrentModule $ clEnv cl) -- , prettyTCM (envLetBindings $ clEnv cl) , prettyTCM tel -- (toTelescope $ envContext $ clEnv cl) , prettyTCM sigma , prettyTCM m , prettyTCM sub ]- k ms sigma+ cutConversionErrors $ 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@@ -2121,34 +2245,35 @@ let t = foldr (\ x r -> and `apply` [argN x,argN r]) io ts ifBlocked t blocked unblocked addBindings [] m = m- addBindings ((CtxVar nm Dom{domInfo = info,unDom = ty},t):bs) m = addLetBinding info Inserted nm t ty (addBindings bs m)+ addBindings ((CtxVar nm dom@(unDom -> ty),t):bs) m =+ addLetBinding (dom ^. dInfo) Inserted nm t ty (addBindings bs m) - substContextN :: MonadConversion m => Context -> [(Int,Term)] -> m (Context , Substitution)+ substContextN :: Context -> [(Int,Term)] -> TCM (Context , Substitution) substContextN c [] = return (c, idS) substContextN c ((i,t):xs) = do (c', sigma) <- substContext i t c- (c'', sigma') <- substContextN c' (map (subtract 1 -*- applySubst sigma) xs)+ (c'', sigma') <- substContextN c' (map' (subtract 1 *** applySubst sigma) xs) return (c'', applySubst sigma' sigma) -- assumes the term can be typed in the shorter telescope -- the terms we get from toFaceMaps are closed.- substContext :: MonadConversion m => Int -> Term -> Context -> m (Context , Substitution)- substContext i t [] = __IMPOSSIBLE__- substContext i t (x:xs) | i == 0 = return $ (xs , singletonS 0 t)- substContext i t (x:xs) | i > 0 = do- reportSDoc "conv.forall" 20 $- fsep ["substContext"- , text (show (i-1))- , prettyTCM t- , prettyTCM xs- ]- (c,sigma) <- substContext (i-1) t xs- let e = applySubst sigma x- return (e:c, liftS 1 sigma)- substContext i t (x:xs) = __IMPOSSIBLE__+ substContext :: Int -> Term -> Context -> TCM (Context , Substitution)+ substContext i t CxEmpty = __IMPOSSIBLE__+ substContext i t (CxExtend x xs) | i == 0 = return $ (xs , singletonS 0 t)+ substContext i t (CxExtend x xs) | i > 0 = do+ reportSDoc "conv.forall" 20 $+ fsep ["substContext"+ , text (show (i-1))+ , prettyTCM t+ , prettyTCM xs+ ]+ (c,sigma) <- substContext (i-1) t xs+ let e = applySubst sigma x+ return (CxExtend e c, liftS 1 sigma)+ substContext i t (CxExtend x xs) = __IMPOSSIBLE__ -compareInterval :: MonadConversion m => Comparison -> Type -> Term -> Term -> m ()+compareInterval :: Comparison -> Type -> Term -> Term -> TCM () compareInterval cmp i t u = do reportSDoc "tc.conv.interval" 15 $ sep [ "{ compareInterval" <+> prettyTCM t <+> "=" <+> prettyTCM u ]@@ -2173,7 +2298,7 @@ y <- leqInterval iu it let final = isCanonical it && isCanonical iu if x && y then reportSDoc "tc.conv.interval" 15 $ "Ok! }" else- if final then typeError $ UnequalTerms cmp t u (AsTermsOf i)+ if final then failConversion cmp t u (AsTermsOf i) else do reportSDoc "tc.conv.interval" 15 $ "Giving up! }" patternViolation (unblockOnAnyMetaIn (t, u))@@ -2189,7 +2314,7 @@ -- | leqInterval r q = r ≤ q in the I lattice. -- (∨ r_i) ≤ (∨ q_j) iff ∀ i. ∃ j. r_i ≤ q_j-leqInterval :: MonadConversion m => [Conj] -> [Conj] -> m Bool+leqInterval :: [Conj] -> [Conj] -> TCM Bool leqInterval r q = and <$> forM r (\ r_i -> or <$> forM q (\ q_j -> leqConj r_i q_j)) -- TODO shortcut@@ -2199,7 +2324,7 @@ -- ' (∧ r_i) ∧ (∧ q_j) = (∧ r_i) iff -- ' {r_i | i} ∪ {q_j | j} = {r_i | i} iff -- ' {q_j | j} ⊆ {r_i | i}-leqConj :: MonadConversion m => Conj -> Conj -> m Bool+leqConj :: Conj -> Conj -> TCM Bool leqConj (rs, rst) (qs, qst) = do if IntMap.isSubmapOfBy BoolSet.isSubsetOf qs rs then do@@ -2217,16 +2342,15 @@ return False -- | equalTermOnFace φ A u v = _ , φ ⊢ u = v : A-equalTermOnFace :: MonadConversion m => Term -> Type -> Term -> Term -> m ()+equalTermOnFace :: Term -> Type -> Term -> Term -> TCM () equalTermOnFace = compareTermOnFace CmpEq -compareTermOnFace :: MonadConversion m => Comparison -> Term -> Type -> Term -> Term -> m ()+compareTermOnFace :: Comparison -> Term -> Type -> Term -> Term -> TCM () compareTermOnFace = compareTermOnFace' (const compareTerm) -compareTermOnFace'- :: MonadConversion m- => (Substitution -> Comparison -> Type -> Term -> Term -> m ())- -> Comparison -> Term -> Type -> Term -> Term -> m ()+compareTermOnFace' ::+ (Substitution -> Comparison -> Type -> Term -> Term -> TCM ())+ -> Comparison -> Term -> Type -> Term -> Term -> TCM () compareTermOnFace' k cmp phi ty u v = do reportSDoc "tc.conv.face" 40 $ text "compareTermOnFace:" <+> pretty phi <+> "|-" <+> pretty u <+> "==" <+> pretty v <+> ":" <+> pretty ty@@ -2234,7 +2358,7 @@ phi <- reduce phi _ <- forallFaceMaps phi postponed $ \ faces alpha ->- k alpha cmp (applySubst alpha ty) (applySubst alpha u) (applySubst alpha v)+ k alpha cmp (applySubst alpha ty) (applySubst alpha u) (applySubst alpha v) return () where postponed ms blocker psi = do@@ -2251,7 +2375,7 @@ -- * Definitions --------------------------------------------------------------------------- -bothAbsurd :: MonadConversion m => QName -> QName -> m Bool+bothAbsurd :: QName -> QName -> TCM Bool bothAbsurd f f' | isAbsurdLambdaName f, isAbsurdLambdaName f' = do -- Double check we are really dealing with absurd lambdas:
src/full/Agda/TypeChecking/Conversion.hs-boot view
@@ -2,37 +2,23 @@ module Agda.TypeChecking.Conversion where -import Control.Monad.Except ( MonadError )- import Agda.Syntax.Internal import Agda.TypeChecking.Monad-import Agda.TypeChecking.Warnings -type MonadConversion m =- ( PureTCM m- , MonadConstraint m- , MonadMetaSolver m- , MonadError TCErr m- , MonadWarning m- , MonadStatistics m- , MonadFresh ProblemId m- , MonadFresh Int m- )--compareTerm :: MonadConversion m => Comparison -> Type -> Term -> Term -> m ()-compareAs :: MonadConversion m => Comparison -> CompareAs -> Term -> Term -> m ()-compareTermOnFace :: MonadConversion m => Comparison -> Term -> Type -> Term -> Term -> m ()-compareAtom :: MonadConversion m => Comparison -> CompareAs -> Term -> Term -> m ()-compareArgs :: MonadConversion m => [Polarity] -> [IsForced] -> Type -> Term -> Args -> Args -> m ()-compareElims :: MonadConversion m => [Polarity] -> [IsForced] -> Type -> Term -> [Elim] -> [Elim] -> m ()-compareType :: MonadConversion m => Comparison -> Type -> Type -> m ()-compareSort :: MonadConversion m => Comparison -> Sort -> Sort -> m ()-compareLevel :: MonadConversion m => Comparison -> Level -> Level -> m ()-equalTerm :: MonadConversion m => Type -> Term -> Term -> m ()-equalTermOnFace :: MonadConversion m => Term -> Type -> Term -> Term -> m ()-equalType :: MonadConversion m => Type -> Type -> m ()-equalSort :: MonadConversion m => Sort -> Sort -> m ()-equalLevel :: MonadConversion m => Level -> Level -> m ()-leqType :: MonadConversion m => Type -> Type -> m ()-leqLevel :: MonadConversion m => Level -> Level -> m ()-leqSort :: MonadConversion m => Sort -> Sort -> m ()+compareTerm :: Comparison -> Type -> Term -> Term -> TCM ()+compareAs :: Comparison -> CompareAs -> Term -> Term -> TCM ()+compareTermOnFace :: Comparison -> Term -> Type -> Term -> Term -> TCM ()+compareAtom :: Comparison -> CompareAs -> Term -> Term -> TCM ()+compareArgs :: [Polarity] -> [IsForced] -> Type -> Term -> Args -> Args -> TCM ()+compareElims :: [Polarity] -> [IsForced] -> Type -> Term -> [Elim] -> [Elim] -> TCM ()+compareType :: Comparison -> Type -> Type -> TCM ()+compareSort :: Comparison -> Sort -> Sort -> TCM ()+compareLevel :: Comparison -> Level -> Level -> TCM ()+equalTerm :: Type -> Term -> Term -> TCM ()+equalTermOnFace :: Term -> Type -> Term -> Term -> TCM ()+equalType :: Type -> Type -> TCM ()+equalSort :: Sort -> Sort -> TCM ()+equalLevel :: Level -> Level -> TCM ()+leqType :: Type -> Type -> TCM ()+leqLevel :: Level -> Level -> TCM ()+leqSort :: Sort -> Sort -> TCM ()
+ src/full/Agda/TypeChecking/Conversion/Errors.hs view
@@ -0,0 +1,842 @@+-- | Implementation of conversion checking errors which can reify part+-- of the context leading to the actual failure as terms.+module Agda.TypeChecking.Conversion.Errors+ (+ -- * Public interface+ -- $convErrors+ failConversion, mismatchedProjections, addConversionContext,++ -- * Unreifiable recursive calls+ -- $stackSlice+ nowConversionChecking, cutConversionErrors++ -- * Types+ , ConversionError(..)+ , ConversionZipper(..)+ , ConversionErrorContext(..)+ , FailedCompareAs(..)+ )+ where++import Control.Monad.Error.Class+import Control.Monad.Trans.Maybe+import Control.Monad.Except+import Control.Applicative+import Control.DeepSeq+import Control.Monad++import GHC.Generics (Generic)++import qualified Agda.Syntax.Common.Pretty as P+import Agda.Syntax.Internal+import Agda.Syntax.Fixity (Precedence(TopCtx))+import Agda.Syntax.Common++import Agda.TypeChecking.Monad.Constraints+import Agda.TypeChecking.Monad.Statistics+import Agda.TypeChecking.Monad.SizedTypes+import Agda.TypeChecking.Monad.Signature+import Agda.TypeChecking.Monad.MetaVars+import Agda.TypeChecking.Monad.Builtin+import Agda.TypeChecking.Monad.Closure+import Agda.TypeChecking.Monad.Context+import Agda.TypeChecking.Monad.Debug+import Agda.TypeChecking.Monad.Pure+import Agda.TypeChecking.Monad.Base++import {-# SOURCE #-} Agda.TypeChecking.Errors+import Agda.TypeChecking.Conversion.Pure+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Warnings+import Agda.TypeChecking.Records+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Reduce++import qualified Agda.Utils.Null as Null+import Agda.Utils.Impossible+import Agda.Utils.Functor+import Agda.Utils.Maybe+import Agda.Utils.Monad hiding (guard)+import Agda.Utils.Size++-- | The failing version of 'CompareAs'.+data FailedCompareAs+ = FailAsTermsOf Type Type+ -- ^ The conversion checker failed in a typed context.+ --+ -- While the conversion checker is homogeneous (so 'AsTermsOf' only+ -- stores a single type), a failing argument comparison early in the+ -- spine of a dependent function can cause the reconstructed+ -- "context" terms to be heterogeneous.+ | FailAsTypes+ -- ^ The conversion checker failed in a type-insensitive context.+ deriving (Show, Generic)++-- | A "zipper-like" representation of the edges between comparing a+-- normal form and comparing one of its immediate subterms in the+-- conversion checker's call graph.+data ConversionZipper+ -- | Thrown at the failing call.+ = ConvStop++ -- | A call to compare the body of a function-typed value.+ | ConvLam+ (Dom Type) -- ^ Argument type+ (Abs ()) -- ^ Simplified codomain+ ArgName -- ^ Name of the variable introduced for comparing the bodies+ ConversionZipper -- ^ Call stack suffix.++ -- | A call to compare the domain of a pair of pi types.+ | ConvDom+ (Dom ConversionZipper) -- ^ Information about the domain, and call stack suffix.+ (Abs Type) -- ^ Codomain of the left-hand side type.+ (Abs Type) -- ^ Codomain of the right-hand-side type.++ -- | A call to compare the codomain of a pair of pi types.+ | ConvCod+ (Dom Type) -- ^ The domain.+ ArgName -- ^ Name of the variable introduced for comparing the bodies+ ConversionZipper -- ^ Call stack suffix.++ -- | A call to compare an argument to a function.+ | ConvApply+ Term -- ^ The head term+ (Abs Type) -- ^ The codomain of the function type at the argument where conversion failed+ (Arg ConversionZipper) -- ^ Information about the argument, and call stack suffix.+ [Elim] -- ^ Remaining arguments from the LHS term that conversion checking could not get to.+ [Elim] -- ^ Remaining arguments from the RHS term that conversion checking could not get to.+ deriving (Show, Generic)++-- | Additional information regarding why two function types are distinct.+data WhyUnequalTypes+ = forall a. (NFData a, Verbalize a) => UnequalDomain a a+ -- ^ Their domains differ in relevance/modality/etc.+ | UnequalHiding Hiding Hiding+ -- ^ Their domains differ in hiding.++-- | Additional information as for why two terms which might print the+-- same are distinct.+--+-- Some constructors are duplicated so that the explanations can be+-- printed in the correct order.+data HeadMismatch+ -- | They are distinct extended lambdas.+ = HdmExtLam QName QName+ -- | They are distinct 'Pi' types.+ | HdmTypes WhyUnequalTypes+ -- | They are distinct variables.+ | HdmVars !Int !Int+ -- | They are the same variable, but their spines might be+ -- interesting.+ | HdmVarSpine !Int (Closure (Elims, Elims))++ | HdmVarDef -- ^ Variable-definition mismatch+ | HdmDefVar -- ^ Definition-variable mismatch+ | HdmVarCon -- ^ Variable-constructor mismatch+ | HdmConVar -- ^ Constructor-variable mismatch+ deriving (Show, Generic)++-- | Whether a 'ConversionZipper' generated nontrivial wrapper terms+-- when flattening the call stack of a t'ConversionError'.+--+-- Used to print error messages with correct grammar.+data HereOrThere+ = Here -- ^ It didn't.+ | There -- ^ It did.+ deriving (Show, Generic)++-- | Context for a conversion checking error.+data ConversionErrorContext+ = Floating ConversionZipper+ -- ^ It still makes sense to collect call stack information for this+ -- error.+ | Finished HereOrThere (Maybe HeadMismatch)+ -- ^ We can not, or do not want to, keep collecting call stack+ -- information for this error.+ -- Stores "crystallised" information about the actual failing+ -- comparison to use as context in error rendering.+ deriving (Show, Generic)++-- | A conversion checking failure.+--+-- A conversion checking error can be in two states (according to its+-- 'convErrCtx'): it is either 'Finished' or+-- 'Agda.TypeChecking.Conversion.Errors.Floating'.+--+-- A 'Finished' conversion-checking error packages a pair of unequal+-- terms, which are well-typed in the context that the error was raised+-- in, with sufficient information for printing an informative error+-- message. 'Finished' errors will not accumulate further call stack+-- information.+--+-- A 'Agda.TypeChecking.Conversion.Errors.Floating' conversion-checking+-- error is subject to be modified as the conversion checker's call+-- stack unwinds, by appending to its 'ConversionZipper'. Some frames in+-- a 'ConversionZipper' alter the context in which the terms+-- 'convErrLhs' and 'convErrRhs' should be interpreted. Floating errors+-- can be re-raised as 'Finished' errors using 'cutConversionErrors'.+-- This means that any code which catches those errors will have types+-- valid directly in the v'TypeError' closure, but no more context will+-- be accumulated for them.+data ConversionError = ConversionError+ { convErrCmp :: Comparison+ -- ^ Were we checking for equality or subtyping?+ , convErrTys :: FailedCompareAs+ -- ^ Were we comparing against a known type when conversion checking+ -- failed?+ , convErrLhs :: Term+ -- ^ The "LHS" of the comparison (if 'CmpLeq', the subtype).+ , convErrRhs :: Term+ -- ^ The "RHS" of the comparison (if 'CmpLeq', the supertype).+ , convErrCtx :: ConversionErrorContext+ -- ^ Call stack information about this error.+ }+ deriving (Show, Generic)++instance Show WhyUnequalTypes where+ show = const "<WhyUnequalTypes>"++instance NFData WhyUnequalTypes where+ rnf = \case+ UnequalDomain a b -> rnf (a, b)+ UnequalHiding a b -> rnf (a, b)++instance NFData ConversionErrorContext+instance NFData ConversionZipper+instance NFData ConversionError+instance NFData FailedCompareAs+instance NFData HeadMismatch+instance NFData HereOrThere++-- $convErrors+--+-- Conversion checking errors are initially thrown (by 'failConversion')+-- in the /floating/ state, which means they can accumulate information+-- on where they happened as the call stack unwinds. This information+-- will be presented to the user by wrapping the actual mismatched terms+-- in a skeleton of the term where the mismatch happened. These terms+-- had better not be nonsense! This requires that recursive calls within+-- the conversion checker cooperate with the reconstruction process,+-- using the functions in this module. Their use can be summarised as+-- follows:+--+-- * A recursive call to compare a subterm of a normal form should be+-- guarded by 'addConversionContext'.+-- * A recursive call to a domain-specific conversion checking function+-- which takes the input terms apart using a nontrivial view (e.g.,+-- 'Agda.TypeChecking.Conversion.equalLevel') should be guarded by+-- 'nowConversionChecking'.+-- * A recursive call under an application of a nontrivial substitution+-- to the context and terms under consideration should be guarded by+-- 'cutConversionErrors'.+-- * Recursive calls that preserve the definitional identities of the+-- terms under consideration do not need any special handling.+--+-- The goal of these rules is to allow for the user to pretend that+-- conversion checking works by normalising then checking for syntactic+-- equality: the reconstructed term should wrap the actual mismatch in+-- "hereditary neutrals (to the left)", i.e. everything that compared+-- equal on the way to the mismatched terms is normalised, but parts of+-- the term that are beyond the mismatch are left as-is (and, in the+-- future, will be presented "deemphasized").+--+-- /How much/ of the context to reify is a design parameter that can be+-- tuned. At the moment, we drop all 'ConvLam', 'ConvDom', 'ConvCod' and+-- __visible__ 'ConvApply' from the front of the zipper. Regardless, the+-- conversion checker must be set up as if the entire context will be+-- reified.++-- | Throw a floating t'ConversionError', given the arguments of+-- 'Agda.TypeChecking.Conversion.compareAs'.+failConversion+ :: (MonadTCError m, HasBuiltins m)+ => Comparison -- ^ Equality or subtyping?+ -> Term -- ^ See 'convErrLhs'+ -> Term -- ^ See 'convErrRhs'+ -> CompareAs -- ^ Will be converted to a 'FailedCompareAs'.+ -> m a+failConversion cmp l r cas = do+ as <- case cas of+ AsTypes -> pure FailAsTypes+ AsTermsOf t -> pure $ FailAsTermsOf t t+ AsSizes -> do+ t <- sizeType+ pure $ FailAsTermsOf t t++ typeError case (l, r) of+ (Sort MetaS{} , t ) -> ShouldBeASort $ El __IMPOSSIBLE__ t+ (s , Sort MetaS{} ) -> ShouldBeASort $ El __IMPOSSIBLE__ s+ (Sort DefS{} , t ) -> ShouldBeASort $ El __IMPOSSIBLE__ t+ (s , Sort DefS{} ) -> ShouldBeASort $ El __IMPOSSIBLE__ s+ _ -> ConversionError_ ConversionError+ { convErrTys = as+ , convErrRhs = r+ , convErrLhs = l+ , convErrCmp = cmp+ , convErrCtx = Floating ConvStop+ }+{-# SPECIALIZE NOINLINE failConversion :: Comparison -> Term -> Term -> CompareAs -> TCM a #-}++{-# INLINE addConversionContext #-}+-- | Add some call stack context to floating t'ConversionError's thrown+-- from the continuation.+--+-- This function should be placed on the __outside__ of 'addContext',+-- and the changes to the context should be reflected in the+-- 'ConversionZipper'.+addConversionContext+ :: (MonadTCError m)+ => (ConversionZipper -> ConversionZipper)+ -- ^ How to modify the zipper+ -> m a+ -- ^ Generally, a recursive call to the conversion checker+ -> m a+addConversionContext !ext !cont = cont `catchError` catchConversionContext ext++{-# SPECIALIZE NOINLINE catchConversionContext :: (ConversionZipper -> ConversionZipper) -> TCErr -> TCM a #-}+catchConversionContext :: MonadTCError m => (ConversionZipper -> ConversionZipper) -> TCErr -> m a+catchConversionContext !ext = \case+ TypeError loc st cl'@Closure{ clValue = ConversionError_ conv@ConversionError{ convErrCtx = Floating ctx } } -> do+ let+ !zip = ext ctx+ !old_c = view eCall $ clEnv cl'+ cl <- buildClosure $ ConversionError_ $! conv { convErrCtx = Floating zip }+ throwError $! TypeError loc st $! (cl {clEnv = (clEnv cl) & eCall .~ old_c})+ err -> throwError err++-- $stackSlice+--+-- The 'ConversionZipper' reflects recursive calls made to conversion+-- checking of the immediate subterms of a normal form, and it can+-- handle most cases of a recursive call happening in a weakening of the+-- current context as well. However, some conversion-checking functions+-- take the input values apart in nontrivial, type-specific ways before+-- eventually calling into "ordinary" term conversion checking again.+--+-- If a floating t'ConversionError' happens in one of these eventual+-- calls, the reified call stack will not have anything corresponding to+-- the value that got taken apart; this can result in the terms+-- presented to the user being ill-typed (see+-- @test/Fail/ConvErrCtxLevels@ for an example). These calls can be+-- handled in two ways, depending on whether or not preserving the+-- surrounding context is likely to be useful in an error message. Here+-- are examples of using each:+--+-- *+-- Calls to 'Agda.TypeChecking.Conversion.equalLevel' are likely to+-- happen while checking hidden arguments to a defined symbol (e.g.+-- a universe-polymorphic data type), which is a context worth+-- preserving for error messages: telling the user @l != l'@ is+-- significantly less useful than telling them @List {l} A != List+-- {l'} B@.+--+-- Therefore, the call to 'Agda.TypeChecking.Conversion.equalLevel'+-- in 'Agda.TypeChecking.Conversion.equalTerm'' is guarded by+-- 'nowConversionChecking'. If an error happens while+-- conversion-checking some levels, the mismatched terms will be+-- /replaced/ by the (normalised forms of) the entire levels that+-- were being compared.+--+-- *+-- On the other hand, conversion checking of partial elements+-- involves nontrivial modifications to the context, and, more+-- importantly, generally happens to terms which display quite+-- terribly /before/ these substitutions are applied, often+-- involving eta-expanded extended lambdas and the primitive+-- @primPOr@. Subjectively, it's less useful to say that conversion+-- checking failed for the hard-to-read system than it is to say+-- that it failed for a particular face.+--+-- For these reasons,+-- 'Agda.TypeChecking.Conversion.compareTermOnFace' (really,+-- 'Agda.TypeChecking.Conversion.forallFaceMaps') uses+-- 'cutConversionErrors' to turn any floating errors from+-- conversion-checking the faces into 'Finished' errors, which no+-- longer accumulate context. Whatever context was collected+-- /inside/ the face comparison will be preserved, but we will not+-- remember /that/ (or /where/) the partial elements were being+-- compared.++-- | Replaces any floating t'ConversionError's raised by the+-- continuation with the one generated (as per 'failConversion') from+-- the given arguments.+{-# INLINE nowConversionChecking #-}+nowConversionChecking ::+ forall m a. (MonadTCError m, HasBuiltins m)+ => Comparison -- ^ Equality or subtyping?+ -> Term -- ^ See 'convErrLhs'+ -> Term -- ^ See 'convErrRhs'+ -> CompareAs -- ^ Will be converted to a 'FailedCompareAs'.+ -> m a -- ^ Generally, a recursive call to a type-specific conversion checking function.+ -> m a+nowConversionChecking !cmp l r !cas !cont =+ cont `catchError` catchNowConversionChecking cmp l r cas++{-# SPECIALIZE NOINLINE catchNowConversionChecking ::+ Comparison -> Term -> Term -> CompareAs -> TCErr -> TCM a #-}+catchNowConversionChecking ::+ (MonadTCError m, HasBuiltins m)+ => Comparison -> Term -> Term -> CompareAs -> TCErr -> m a+catchNowConversionChecking cmp l r cas = \case+ TypeError loc st Closure{ clValue = err }+ | ConversionError_ ConversionError{ convErrCtx = Floating{} } <- err+ -> failConversion cmp l r cas+ err -> throwError err++-- | Freeze t'ConversionError's thrown by the continuation.+--+-- This function should be placed on the __inside__ of context updates.+{-# INLINE cutConversionErrors #-}+cutConversionErrors :: (MonadPretty m, MonadError TCErr m) => m a -> m a+cutConversionErrors cont = cont `catchError` catchCutConversionErrors+++{-# SPECIALIZE NOINLINE catchCutConversionErrors :: TCErr -> TCM a #-}+catchCutConversionErrors :: (MonadPretty m, MonadError TCErr m) => TCErr -> m a+catchCutConversionErrors = \case+ TypeError loc st cl@Closure{ clValue = ConversionError_ conv } -> enterClosure cl \_ ->+ flattenConversionError conv \conv@ConversionError{convErrLhs = lhs, convErrRhs = rhs} -> do+ cl <- buildClosure ()+ throwError $ TypeError loc st $ cl $> ConversionError_ conv+ err -> throwError err++-- | Intermediate type for storing the results of flattening a 'ConversionZipper'.+type ConversionProblem = (FailedCompareAs, Term, Term)++-- | @'eliminateLhsRhs' hd1 ty1 es1 hd2 ty2 es2@ generates a+-- @ConversionProblem@ between the mismatched terms @hd1@ and @hd2@,+-- which have the types @ty1@ and @ty2@ respectively.+--+-- If the types @ty1@ and @ty2@ respond to the given eliminations @es1@+-- and @es2@ respectively (which they should, since the inputs to+-- conversion checking are assumed to be well-typed), the mismatched+-- terms accumulate these, and the types are suitably refined.+--+-- Currently replaces large terms in the @es1@ by 'DontCare', as a HACK+-- to avoid the printing of big uncompared terms. In the future, this is+-- probably better handled in the reifier.+eliminateLhsRhs+ :: forall m. PureTCM m+ => Type -> Term -> Elims+ -> Type -> Term -> Elims+ -> m ConversionProblem+eliminateLhsRhs t1 v1 l_es t2 v2 r_es =+ let+ blank t+ | termSize t >= 15 = DontCare t+ | otherwise = t+ in+ fromMaybeT (FailAsTermsOf t1 t2, v1, v2) do+ t1 <- eliminateType mzero v1 t1 l_es+ t2 <- eliminateType mzero v2 t2 r_es+ pure+ ( FailAsTermsOf t1 t2+ , v1 `applyE` map (fmap blank) l_es+ , v2 `applyE` map (fmap blank) r_es+ )++-- | @'mismatchedProjections' t1 v1 e1 t2 v2 e2@ raises a floating+-- conversion-checking error (as per 'failConversion') indicating that+-- the terms @v1@ and @v2@ (which have type @t1@ and @t2@ respectively,+-- and are typically neutral) disagree on the last elimination in their+-- spines.+--+-- The further eliminations @e1@ and @e2@ are treated as "uncompared"+-- context for the error message.+{-# SPECIALIZE NOINLINE mismatchedProjections :: Type -> Term -> Elims -> Type -> Term -> Elims -> TCM a #-}+mismatchedProjections+ :: (MonadError TCErr m, PureTCM m)+ => Type -- ^ LHS type, @t1@+ -> Term -- ^ LHS term, @v1@; see 'convErrLhs'.+ -> Elims -- ^ Additional eliminations @e1@ present on the LHS beyond the failure of conversion checking+ -> Type -- ^ RHS type, @t2@+ -> Term -- ^ RHS term, @v2@; see 'convErrRhs'.+ -> Elims -- ^ Additional eliminations @e2@ present on the RHS beyond the failure of conversion checking+ -> m a+mismatchedProjections t1 v1 e1 t2 v2 e2 = do+ (tys, lhs, rhs) <- eliminateLhsRhs t1 v1 e1 t2 v2 e2+ typeError $ ConversionError_ $ ConversionError CmpEq tys lhs rhs (Floating ConvStop)++-- | Compute a 'HeadMismatch' explaining why two terms disagree, if+-- there is a possibility that they might be printed identically.+headMismatch :: forall m. (PureTCM m, MonadPlus m) => Term -> Term -> m HeadMismatch+headMismatch Var{} Def{} = pure HdmVarDef+headMismatch Def{} Var{} = pure HdmDefVar+headMismatch Var{} Con{} = pure HdmVarCon+headMismatch Con{} Var{} = pure HdmConVar+headMismatch (Var i xs) (Var j ys)+ | i == j = HdmVarSpine i <$> buildClosure (xs, ys)+headMismatch (Pi d1 _) (Pi d2 _) =+ let+ hint :: (a -> a -> b) -> (forall x y. Dom' x y -> a) -> (a -> a -> Bool) -> m b+ hint k g c = k (g d1) (g d2) <$ guard (not (c (g d1) (g d2)))+ in HdmTypes <$> asum+ [ hint UnequalDomain getRelevance sameRelevance+ , hint UnequalDomain getQuantity sameQuantity+ , hint UnequalDomain getModalPolarity samePolarity+ , hint UnequalDomain getCohesion sameCohesion+ , hint UnequalHiding getHiding sameHiding+ ]+headMismatch (Def i _) (Def j _)+ | isExtendedLambdaName i, isExtendedLambdaName j = pure $ HdmExtLam i j+headMismatch (Var i xs) (Var j ys) = pure $ HdmVars i j+headMismatch lhs rhs = do+ reportSDoc "tc.conv.ctx" 30 $ vcat+ [ "headMismatch no match"+ , " lhs:" <+> prettyTCM lhs+ , " rhs:" <+> prettyTCM rhs+ ]+ mzero++-- | Flatten a Floating conversion checking error into one that+-- presents interesting context around the failing terms.+--+-- The continuation is only invoked with 'Finished' t'ConversionError's.+flattenConversionError :: forall m z. PureTCM m => ConversionError -> (ConversionError -> m z) -> m z+flattenConversionError e@ConversionError{convErrCtx = Finished{}} cont = cont e+flattenConversionError (ConversionError cmp tys lhs rhs (Floating ctx)) cont =+ do+ reportSDoc "tc.conv.ctx" 30 $ vcat+ [ "unwinding conversion zipper:"+ , " env:" <+> (prettyTCM =<< getContextTelescope)+ , " tys:" <+> prettyTCM tys+ , " lhs:" <+> prettyTCM lhs+ , " rhs:" <+> prettyTCM rhs+ , " zip:" <+> prettyTCM ctx+ ]+ let+ k ht hdm (tys, lhs, rhs) = do+ reportSDoc "tc.conv.ctx" 30 $ vcat+ [ "conversion zipper unwound:"+ , " env:" <+> (prettyTCM =<< getContextTelescope)+ , " tys:" <+> prettyTCM tys+ , " lhs:" <+> prettyTCM lhs+ , " rhs:" <+> prettyTCM rhs+ , " hdm:" <+> text (show hdm)+ ]+ cont (ConversionError cmp tys lhs rhs (Finished ht hdm))+ seek k ctx+ where++ -- Actually apply the continuation. This is the innermost function in+ -- handling the ConversionProblem, so this is our opportunity to+ -- collect any headMismatch information that might get buried in+ -- backtrace terms.+ done :: forall z. (HereOrThere -> Maybe HeadMismatch -> ConversionProblem -> m z) -> m z+ done ok = do+ reportSDoc "tc.conv.ctx" 30 $ vcat+ [ "reached center of conversion zipper:"+ , " env:" <+> (prettyTCM =<< getContextTelescope)+ , " tys:" <+> prettyTCM tys+ , " lhs:" <+> pretty lhs+ , " rhs:" <+> pretty rhs+ ]+ hdm <- runMaybeT $ headMismatch lhs rhs+ ok Here hdm (tys, lhs, rhs)++ -- Discard an uninteresting prefix of call stack (anything that does+ -- not mention an implicit argument), moving any binders from the+ -- zipper to the context of the continuation.+ seek+ :: forall z. (HereOrThere -> Maybe HeadMismatch -> ConversionProblem -> m z)+ -> ConversionZipper+ -> m z+ seek ok zip = case zip of+ ConvStop -> done ok+ ConvApply hd ty (Arg info rest) l_es r_es+ | visible info -> seek ok rest+ | Con c o _ <- hd, IsRecord{} <- conDataRecord c -> seek ok rest+ ConvLam dom ty name rest -> addContext (name, dom) $ seek ok rest+ ConvCod dom name rest -> addContext (name, dom) $ seek ok rest+ ConvDom dom c1 c2 -> seek ok (unDom dom)+ _ -> reify zip (ok Here) ok++ -- Actually reifies a 'ConversionZipper' as a term around the conversion+ -- problem.+ -- This function takes both a success continuation (with three+ -- arguments) and a failing continuation, in case we had to give up on+ -- building the context term.+ reify+ :: forall z. ConversionZipper+ -> (Maybe HeadMismatch -> ConversionProblem -> m z)+ -> (HereOrThere -> Maybe HeadMismatch -> ConversionProblem -> m z)+ -> m z+ reify ctx err ok = case ctx of+ -- Empty call stack, nothing to do+ ConvStop -> done ok++ -- Going under binders.+ --+ -- These both function in the same way, though the lambda case seems+ -- much bigger because it has to update the expected types.+ --+ -- On the failure continuation, since we're not building a term+ -- wrapper to add any variables that are referred to by the+ -- mismatched terms, we have to move the binders into the context.+ --+ -- On the success continuation, the term binder is added, and (if+ -- possible) the comparison is updated for accuracy.+ ConvCod dom name rest -> reify rest (\hdm prob -> addContext (name, dom) $ err hdm prob)+ \_ hdm (_, lhs, rhs) -> ok There hdm+ ( FailAsTypes+ , Pi dom (mkAbs name (El __DUMMY_SORT__ lhs))+ , Pi dom (mkAbs name (El __DUMMY_SORT__ rhs))+ )++ ConvLam dom ty name rest -> reify rest+ (\hdm prob -> addContext (name, dom) $ err hdm prob)+ \ht hdm (cmp, lhs, rhs) -> ok There hdm+ ( case cmp of+ -- Ideally it would be provably impossible for a 'ConvLam'+ -- to be on the stack after an untyped comparison, but I+ -- can't be sure that this is actually the case.+ --+ -- If it does happen, it's safer to print a stupid-looking+ -- error (the types λ x → ... and λ x → ... are not equal)+ -- than it is to print an error with dummy terms.+ --+ -- And if someone complains about the error being stupid, we+ -- hopefully get a test case to fix it with.+ FailAsTypes -> FailAsTypes+ -- If we do have the expected types then we can just wrap+ -- them in Pi types.+ FailAsTermsOf a b -> FailAsTermsOf+ (El (piSort (unEl <$> dom) (getSort dom) (getSort a <$ ty)) (Pi dom (a <$ ty)))+ (El (piSort (unEl <$> dom) (getSort dom) (getSort b <$ ty)) (Pi dom (b <$ ty)))+ , Lam (domInfo dom) (mkAbs name lhs), Lam (domInfo dom) (mkAbs name rhs)+ )++ -- Entering the domain of a function type. Bolts the codomains onto+ -- the failing term. No context handling is needed.+ ConvDom dom c1 c2 -> reify (unDom dom) err \_ hdm (_, lhs, rhs) -> ok There hdm+ ( FailAsTypes+ , Pi (El __DUMMY_SORT__ lhs <$ dom) c1+ , Pi (El __DUMMY_SORT__ rhs <$ dom) c2+ )++ -- Entering an argument to a neutral.+ ConvApply hd ty (Arg info rest) l_es r_es -> reify rest err \_ hdm prob@(_, lhs', rhs') ->+ let info' = info { argInfoOrigin = ConversionFail } in case hd of++ -- If the argument is to an extended lambda, we give up on+ -- reifying this frame (and anything it would return to) since+ -- that generally makes the error messages *worse*.+ -- This is the purpose of passing the failing continuation+ -- around.+ Def nm as | isExtendedLambdaName nm -> do+ ~Function{ funExtLam = Just (ExtLamInfo m b sys) } <- theDef <$> getConstInfo nm+ bs <- lookupSection m+ reportSDoc "tc.conv.ctx" 30 $ vcat+ [ "conversion context has extended lambda" <+> pretty nm+ , "bs " <> parens (pretty (size bs)) <> colon <> " " <> pretty bs+ , "as " <> parens (pretty (size as)) <> colon <> " " <> pretty as+ ]+ err hdm prob++ -- Otherwise, we just build the function call. Note that the+ -- ArgInfo is updated so that the reifier will print the+ -- mismatched term in case it happens in an implicit argument.+ _ -> ok There hdm =<< eliminateLhsRhs+ (ty `absApp` lhs') (hd `apply` [Arg info' lhs']) l_es+ (ty `absApp` rhs') (hd `apply` [Arg info' rhs']) r_es++instance PrettyTCM FailedCompareAs where+ prettyTCM = \case+ FailAsTypes{} -> "(as types)"+ FailAsTermsOf a b -> prettyTCM a <+> comma <+> prettyTCM b++instance PrettyTCM ConversionZipper where+ prettyTCM = \case+ ConvStop -> "<>"+ ConvLam dom ret nm rest -> vcat+ [ "lam" <+> pretty nm <+> pretty dom+ , "ret: " <+> pretty ret+ , "rest:"+ , nest 2 (prettyTCM rest)+ ]+ ConvCod dom nm rest -> vcat+ [ "cod" <+> pretty nm <+> pretty dom+ , "rest:"+ , nest 2 (prettyTCM rest)+ ]+ ConvDom dom t1 t2 -> vcat+ [ "dom:" <+> pretty (() <$ dom)+ , "t1: " <+> pretty t1+ , "t2: " <+> pretty t2+ , "rest:"+ , nest 2 (prettyTCM (unDom dom))+ ]+ ConvApply hd ty (Arg info rest) lhs rhs -> vcat+ [ "apply" <+> pretty hd+ , "ty: " <+> pretty ty+ , "lhs: " <+> prettyTCM lhs+ , "rhs: " <+> prettyTCM rhs+ , "rest:"+ , nest 2 (prettyTCM rest)+ ]++instance PrettyTCM ConversionError where+ prettyTCM :: forall m. MonadPretty m => ConversionError -> m Doc+ prettyTCM err = flattenConversionError err \(ConversionError cmp tys lhs rhs ~(Finished ht hdm)) -> do+ (d1, d2, disamb) <- prettyInEqual ht hdm lhs rhs+ let+ disambs = nest 2 $ orEmpty (pure <$> disamb)+ what = hdm >>= \case+ HdmTypes x -> Just x+ _ -> Nothing+ case tys of+ FailAsTermsOf lhs_t rhs_t -> pureBlockOrEqualTypePureTCM lhs_t rhs_t >>= \case+ Right True -> vcat+ [ "The terms", nest 2 (pure d1)+ , "and", nest 2 (pure d2)+ , "are not equal at type " <> prettyTCM lhs_t <> orEmpty (comma <+> "because:" <$ disamb)+ , disambs+ ]+ _ -> vcat+ [ "The terms", nest 2 (pure d1 <+> colon <+> prettyTCM lhs_t)+ , "and", nest 2 (pure d2 <+> colon <+> prettyTCM rhs_t)+ , "are not equal" <> orEmpty (comma <+> "because:" <$ disamb)+ , disambs+ ]+ FailAsTypes | CmpEq <- cmp -> vcat+ [ "The" <+> case what of+ Just UnequalDomain{} -> "function types"+ Just UnequalHiding{} -> "function types"+ _ -> "types"+ , nest 2 (pure d1), "and", nest 2 (pure d2)+ , "are not equal" <> orEmpty (comma <+> "because:" <$ disamb)+ , disambs+ ]+ FailAsTypes | CmpLeq <- cmp -> vcat+ [ "The" <+> case what of+ Just UnequalDomain{} -> "function type"+ Just UnequalHiding{} -> "function type"+ _ -> "type"+ , nest 2 (pure d1), "is not a subtype of", nest 2 (pure d2)+ , orEmpty ("because:" <$ disamb)+ , disambs+ ]++-- | Pretty print a pair of distinct terms @t1@ and @t2@, producing a+-- disambiguator if the terms render the same with the ambient settings+-- but differently with display forms.+displayDisamb+ :: forall m. MonadPretty m+ => HereOrThere -- ^ For grammar+ -> Maybe (Int, Closure (Elims, Elims))+ -- ^ From a 'HeadMismatch', to indicate what projections' display+ -- forms caused the rerender (if any)+ -> Term -- ^ @t1@+ -> Term -- ^ @t2@+ -> m (Doc, Doc, Maybe Doc)+displayDisamb ht hdm t1 t2 = do+ d1 <- prettyTCMCtx TopCtx t1+ d2 <- prettyTCMCtx TopCtx t2+ let+ maybeProjs :: Elims -> Elims -> MaybeT m [m Doc]+ maybeProjs (Proj _ p:xs) (Proj _ p':ys) | p /= p' = do+ df <- hasDisplayForms p+ df' <- hasDisplayForms p'+ case (df, df') of+ (True, False) -> pure $ pwords "a display form for" <> [prettyTCM p, "has"]+ (False, True) -> pure $ pwords "a display form for" <> [prettyTCM p', "has"]+ (True, True) -> pure $ pwords "display forms for" <> [prettyTCM p, "and", prettyTCM p', "have"]+ (False, False) -> mzero+ maybeProjs (_:xs) (_:ys) = maybeProjs xs ys+ maybeProjs _ _ = mzero++ (d1, d2,) <$> runMaybeT do+ guard (P.render d1 == P.render d2)+ reportSDoc "tc.error.conv" 30 $ vcat+ [ "terms rendered the same"+ , " t1:" <+> pretty t1+ , " d1:" <+> pure d1+ , " t2:" <+> pretty t2+ , " d2:" <+> pure d2+ ]++ (d1, d2) <- locallyTC eDisplayFormsEnabled (const False) do+ (,) <$> prettyTCMCtx TopCtx t1 <*> prettyTCMCtx TopCtx t2+ guard (P.render d1 /= P.render d2)++ whatdf <- case hdm of+ Just (_, cl) -> enterClosure cl (lift . runMaybeT . uncurry maybeProjs) <&>+ fromMaybe (pwords "display forms have")+ Nothing -> pure $ pwords "display forms have"++ vcat+ [ fsep $ map lift whatdf <> pwords "caused" <> pwords case ht of+ Here -> "them"+ There -> "the mismatched terms"+ , nest 2 (pure d1), "and", nest 2 (pure d2)+ , "to render the same"+ ]+++-- | Print two terms that are supposedly unequal, additionally returning+-- an explanation (informed by the HeadMismatch) if they happened to+-- print to the same thing.+prettyInEqual+ :: MonadPretty m+ => HereOrThere -- ^ For grammar+ -> Maybe HeadMismatch -- ^ Collected disambiguator information+ -> Term -> Term -> m (Doc, Doc, Maybe Doc)+prettyInEqual ht hdm t1 t2+ -- If we don't know why they differ, or the mismatched terms are+ -- headed by the same variable, we defer to 'displayDisamb' which is+ -- capable of rendering the term without display forms to fish for an+ -- improvement in printing.+ | Nothing <- hdm = displayDisamb ht Nothing t1 t2+ | Just (HdmVarSpine i cl) <- hdm = displayDisamb ht (Just (i, cl)) t1 t2++ -- If they're distinct function types, we don't have to bother+ -- rerendering.+ | Just (HdmTypes x) <- hdm =+ let+ ecore = case x of+ UnequalDomain a b -> pwords "one has"+ <> [hlKeyword (text (verbalize a))]+ <> pwords "domain, while the other is"+ <> [hlKeyword (text (verbalize b)) <> "."]+ UnequalHiding a b -> pwords "one takes"+ <> [hlKeyword (text (verbalize (Indefinite a)))]+ <> pwords "argument, while the other takes"+ <> [hlKeyword (text (verbalize (Indefinite b))), "argument."]+ explain = case ht of+ Here -> fsep ecore+ There -> fsep $ pwords "the mismatched terms are function types;" <> ecore+ in (,,) <$> prettyTCMCtx TopCtx t1 <*> prettyTCMCtx TopCtx t2 <*> (Just <$> explain)++-- If it's some other class of mismatch, a rerender would probably not+-- improve things.+prettyInEqual ht (Just hdm) t1 t2 = do+ d1 <- prettyTCMCtx TopCtx t1+ d2 <- prettyTCMCtx TopCtx t2+ (d1, d2,) <$> runMaybeT do+ guard (P.render d1 == P.render d2)+ let+ mm = case ht of+ Here -> []+ There -> pwords "of the mismatched terms"+ case hdm of+ HdmExtLam a b -> vcat+ [ fsep $+ case ht of+ Here -> pure "they"+ There -> pwords "the mismatched terms"+ <> pwords "are distinct extended lambdas; "+ , fwords "one is defined at"+ , " " <+> pretty (nameBindingSite a)+ , fwords "and the other at"+ , " " <+> (pretty (nameBindingSite b) <> ",")+ , fwords "so they have different internal representations."+ ]++ HdmVarDef -> fsep $ pwords "one" <> mm <> pwords "is a variable, the other a definition"+ HdmVarCon -> fsep $ pwords "one" <> mm <> pwords "is a variable, the other a constructor"+ HdmDefVar -> fsep $ pwords "one" <> mm <> pwords "is a definition, the other a variable"+ HdmConVar -> fsep $ pwords "one" <> mm <> pwords "is a constructor, the other a variable"+ HdmVars i j -> fsep $+ pwords "one" <> mm <> pwords "has de Bruijn index "+ <> [pretty i <> comma] <> pwords "the other" <> [pretty j]
+ src/full/Agda/TypeChecking/Conversion/Errors.hs-boot view
@@ -0,0 +1,7 @@+module Agda.TypeChecking.Conversion.Errors where++import Control.DeepSeq++data ConversionError+instance Show ConversionError+instance NFData ConversionError
src/full/Agda/TypeChecking/Conversion/Pure.hs view
@@ -1,192 +1,92 @@+{-# OPTIONS_GHC -Wunused-imports #-} module Agda.TypeChecking.Conversion.Pure where import Control.Monad.Except-import Control.Monad.State--import Data.String--import Agda.Syntax.Common+import System.IO.Unsafe (unsafeDupablePerformIO) import Agda.Syntax.Internal import {-# SOURCE #-} Agda.TypeChecking.Conversion import Agda.TypeChecking.Monad import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Reduce (isBlocked)-import Agda.TypeChecking.Warnings--import Agda.Utils.Maybe-import Agda.Utils.Null-+import Agda.Utils.IORef.Strict qualified as Strict import Agda.Utils.Impossible -data FreshThings = FreshThings- { freshInt :: Int- , freshProblemId :: ProblemId- , freshNameId :: NameId- }--newtype PureConversionT m a = PureConversionT- { unPureConversionT :: ExceptT TCErr (StateT FreshThings m) a }- deriving (Functor, Applicative, Monad, MonadError TCErr, MonadState FreshThings, PureTCM)--{-# SPECIALIZE pureEqualTerm :: Type -> Term -> Term -> TCM Bool #-}-pureEqualTerm- :: (PureTCM m, MonadBlock m)- => Type -> Term -> Term -> m Bool-pureEqualTerm a u v =- isJust <$> runPureConversion (equalTerm a u v)--{-# SPECIALIZE pureEqualTermB :: Type -> Term -> Term -> TCM (Either Blocker Bool) #-}--- | Return the blocker instead of throwing a `patternViolation`.-pureEqualTermB :: PureTCM m => Type -> Term -> Term -> m (Either Blocker Bool)-pureEqualTermB a u v =- fmap isJust <$> runPureConversionB (equalTerm a u v)--{-# SPECIALIZE pureEqualType :: Type -> Type -> TCM Bool #-}-pureEqualType- :: (PureTCM m, MonadBlock m)- => Type -> Type -> m Bool-pureEqualType a b =- isJust <$> runPureConversion (equalType a b)--{-# SPECIALIZE pureEqualType :: Type -> Type -> TCM Bool #-}--- | Return the blocker instead of throwing a `patternViolation`.-pureEqualTypeB :: PureTCM m => Type -> Type -> m (Either Blocker Bool)-pureEqualTypeB a b =- fmap isJust <$> runPureConversionB (equalType a b)--{-# SPECIALIZE pureCompareAs :: Comparison -> CompareAs -> Term -> Term -> TCM Bool #-}-pureCompareAs- :: (PureTCM m, MonadBlock m)- => Comparison -> CompareAs -> Term -> Term -> m Bool-pureCompareAs cmp a u v =- isJust <$> runPureConversion (compareAs cmp a u v)--{-# SPECIALIZE runPureConversion :: PureConversionT TCM a -> TCM (Maybe a) #-}-runPureConversion- :: (MonadBlock m, PureTCM m)- => PureConversionT m a -> m (Maybe a)-runPureConversion m = either patternViolation pure =<< runPureConversionB m--{-# SPECIALIZE runPureConversionB :: PureConversionT TCM a -> TCM (Either Blocker (Maybe a)) #-}-runPureConversionB :: PureTCM m => PureConversionT m a -> m (Either Blocker (Maybe a))-runPureConversionB (PureConversionT m) = locallyTC eCompareBlocked (const True) $+pureConversion ::+ TCM b -- ^ What to do on `neverUnblock`+ -> (Blocker -> TCM b) -- ^ What to do on other blockers.+ -> (a -> TCM b) -- ^ What to do with successful result.+ -> TCM a+ -> TCM b+pureConversion rigidblock flexblock nonblocked = \m ->+ localTC (set eCompareBlocked True . set ePureConversion 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- case result of- Left (PatternErr block)- | block == neverUnblock -> do- debugResult "stuck"- return $ Right Nothing- | otherwise -> do- debugResult $ "blocked on" <+> prettyTCM block- return $ Left block- Left TypeError{} -> do- debugResult "type error"- return $ Right Nothing- Left GenericException{} -> __IMPOSSIBLE__- Left IOException{} -> __IMPOSSIBLE__- Left ParserError{} -> __IMPOSSIBLE__- Right x -> do- debugResult "success"- return $ Right $ Just x- where- debugResult msg = reportSDoc "tc.conv.pure" 40 $ "runPureConversion result: " <+> msg--instance MonadTrans PureConversionT where- lift = PureConversionT . lift . lift--deriving instance MonadFail m => MonadFail (PureConversionT m)-deriving instance HasBuiltins m => HasBuiltins (PureConversionT m)-deriving instance HasConstInfo m => HasConstInfo (PureConversionT m)-deriving instance HasOptions m => HasOptions (PureConversionT m)-deriving instance MonadTCEnv m => MonadTCEnv (PureConversionT m)-deriving instance ReadTCState m => ReadTCState (PureConversionT m)-deriving instance MonadReduce m => MonadReduce (PureConversionT m)-deriving instance MonadAddContext m => MonadAddContext (PureConversionT m)-deriving instance MonadDebug m => MonadDebug (PureConversionT m)--instance (Monad m, Semigroup a) => Semigroup (PureConversionT m a) where- d1 <> d2 = (<>) <$> d1 <*> d2--instance (IsString a, Monad m) => IsString (PureConversionT m a) where- fromString s = return (fromString s)--instance Monad m => Null (PureConversionT m Doc) where- empty = return empty- null = __IMPOSSIBLE__--instance Monad m => MonadBlock (PureConversionT m) where- patternViolation = throwError . PatternErr- catchPatternErr handle m = m `catchError` \case- PatternErr b -> handle b- err -> throwError err-+ oldState <- getTC+ let debugResult msg =+ reportSDoc "tc.conv.pure" 40 $ "runPureConversion result: " <+> msg+ res <- (Right <$> m) `catchError` \case+ PatternErr block ->+ pure $ Left block -instance PureTCM m => MonadConstraint (PureConversionT m) where- addConstraint u _ = patternViolation u- addAwakeConstraint u _ = patternViolation u- solveConstraint c = patternViolation alwaysUnblock -- TODO: does this happen?- solveSomeAwakeConstraints _ _ = return ()- wakeConstraints _ = return ()- stealConstraints _ = return ()- modifyAwakeConstraints _ = patternViolation alwaysUnblock -- TODO: does this happen?- modifySleepingConstraints _ = patternViolation alwaysUnblock -- TODO: does this happen?+ -- András 2024-10-21: we treat this as a rigid blocker. Not sure why,+ -- but the old code did it like this.+ TypeError{} -> do+ debugResult "type error"+ pure $ Left neverUnblock -instance PureTCM m => MonadMetaSolver (PureConversionT m) where- newMeta' _ _ _ _ _ _ = patternViolation alwaysUnblock -- TODO: does this happen?- assignV _ m _ v _ = do- bv <- isBlocked v- let blocker = caseMaybe bv id unblockOnEither $ unblockOnMeta m- patternViolation blocker- assignTerm' m _ v = do- bv <- isBlocked v- let blocker = caseMaybe bv id unblockOnEither $ unblockOnMeta m- patternViolation blocker- etaExpandMeta _ _ = return ()- updateMetaVar _ _ = patternViolation alwaysUnblock -- TODO: does this happen?- speculateMetas fallback m = m >>= \case- KeepMetas -> return ()- RollBackMetas -> fallback+ GenericException{} -> __IMPOSSIBLE__+ IOException{} -> __IMPOSSIBLE__+ ParserError{} -> __IMPOSSIBLE__+ putTC oldState+ case res of+ Left block | block == neverUnblock -> do+ debugResult "stuck"+ rigidblock+ Left block -> do+ debugResult $ "blocked on" <+> prettyTCM block+ flexblock block+ Right a ->+ nonblocked a+{-# INLINE pureConversion #-} -instance PureTCM m => MonadInteractionPoints (PureConversionT m) where- freshInteractionId = patternViolation alwaysUnblock -- TODO: does this happen?- modifyInteractionPoints _ = patternViolation alwaysUnblock -- TODO: does this happen?+-- | Run conversion without modifying constraint or meta state. A state+-- modification instead throws a pattern violation.+runPureConversion :: TCM a -> TCM a+runPureConversion =+ pureConversion (patternViolation neverUnblock) patternViolation pure --- This is a bogus instance that promptly forgets all concrete names,--- but we don't really care-instance ReadTCState m => MonadStConcreteNames (PureConversionT m) where- runStConcreteNames m = do- concNames <- useR stConcreteNames- fst <$> runStateT m concNames+-- | Don't catch pattern violation.+pureEqualTerm :: Type -> Term -> Term -> TCM Bool+pureEqualTerm a u v =+ pureConversion (pure False) patternViolation (\_ -> pure True) (equalTerm a u v) -instance PureTCM m => MonadWarning (PureConversionT m) where- addWarning _enabled w = case classifyWarning (tcWarning w) of- ErrorWarnings -> patternViolation neverUnblock- AllWarnings -> return ()+-- | Compare terms, catch and return pattern violation.+pureBlockOrEqualTerm :: Type -> Term -> Term -> TCM (Either Blocker Bool)+pureBlockOrEqualTerm a u v =+ pureConversion (pure $ Right False) (pure . Left) (\_ -> pure $ Right True) (equalTerm a u v) -instance ReadTCState m => MonadStatistics (PureConversionT m) where- modifyCounter _ _ = return ()+{-# INLINE pureBlockOrEqualTermPureTCM #-}+pureBlockOrEqualTermPureTCM :: PureTCM m => Type -> Term -> Term -> m (Either Blocker Bool)+pureBlockOrEqualTermPureTCM a u v = do+ st <- getTCState+ e <- askTC+ pure $! unsafeDupablePerformIO $ do+ ref <- Strict.newIORef st+ unTCM (pureBlockOrEqualTerm a u v) ref e -instance Monad m => MonadFresh ProblemId (PureConversionT m) where- fresh = do- i <- gets freshProblemId- modify $ \f -> f { freshProblemId = i + 1 }- return i+pureBlockOrEqualType :: Type -> Type -> TCM (Either Blocker Bool)+pureBlockOrEqualType a b =+ pureConversion (pure $ Right False) (pure . Left) (\_ -> pure $ Right True) (equalType a b) -instance Monad m => MonadFresh NameId (PureConversionT m) where- fresh = do- i <- gets freshNameId- modify $ \f -> f { freshNameId = succ i }- return i+{-# INLINE pureBlockOrEqualTypePureTCM #-}+pureBlockOrEqualTypePureTCM :: PureTCM m => Type -> Type -> m (Either Blocker Bool)+pureBlockOrEqualTypePureTCM a a' = do+ st <- getTCState+ e <- askTC+ pure $! unsafeDupablePerformIO $ do+ ref <- Strict.newIORef st+ unTCM (pureBlockOrEqualType a a') ref e -instance Monad m => MonadFresh Int (PureConversionT m) where- fresh = do- i <- gets freshInt- modify $ \f -> f { freshInt = i + 1 }- return i+pureCompareAs :: Comparison -> CompareAs -> Term -> Term -> TCM Bool+pureCompareAs cmp a u v =+ pureConversion (pure False) patternViolation (\_ -> pure True) (compareAs cmp a u v)
src/full/Agda/TypeChecking/Coverage.hs view
@@ -21,6 +21,7 @@ import Control.Monad.Except ( MonadError(..), ExceptT(..), runExceptT ) import Control.Monad.State ( State, evalState, state ) +import Data.Bifunctor (second) import Data.Either (partitionEithers) import Data.Foldable (for_) import Data.IntMap (IntMap)@@ -34,12 +35,13 @@ import qualified Agda.Benchmarking as Bench -import Agda.Syntax.Common+import Agda.Syntax.Common hiding (DataOrRecord) import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Syntax.Position-import Agda.Syntax.Internal hiding (DataOrRecord)+import Agda.Syntax.Internal import Agda.Syntax.Internal.Pattern import Agda.Syntax.Translation.InternalToAbstract (NamedClause(..))+import Agda.Syntax.Scope.Base (ScopeInfo(..)) import Agda.TypeChecking.Primitive hiding (Nat) import Agda.TypeChecking.Monad@@ -51,6 +53,7 @@ import Agda.TypeChecking.Rules.Term (unquoteTactic) import Agda.TypeChecking.Coverage.Match+import Agda.TypeChecking.Coverage.SplitPattern import Agda.TypeChecking.Coverage.SplitTree import Agda.TypeChecking.Coverage.SplitClause import Agda.TypeChecking.Coverage.Cubical@@ -70,6 +73,7 @@ import Agda.Interaction.Options +import Agda.Utils.Boolean ( toBool ) import Agda.Utils.Either import Agda.Utils.Function import Agda.Utils.Functor@@ -102,27 +106,22 @@ -> [Clause] -- ^ Clauses of @f@. These are the very clauses of @f@ in the signature. -> TCM SplitTree coverageCheck f t cs = do- reportSLn "tc.cover.top" 30 $ "entering coverageCheck for " ++ prettyShow f+ reportSLn "tc.cover.top" 30 $ "entering coverageCheck for " ++! prettyShow f reportSDoc "tc.cover.top" 75 $ " of type (raw): " <+> (text . prettyShow) t reportSDoc "tc.cover.top" 45 $ " of type: " <+> prettyTCM t- TelV gamma a <- telViewUpTo (-1) t+ TelV gamma1 a <- telViewUpTo (-1) t reportSLn "tc.cover.top" 30 $ "coverageCheck: computed telView" - let -- n = arity- -- xs = variable patterns fitting lgamma- n = size gamma- xs = map (setOrigin Inserted) $ teleNamedArgs gamma-- reportSLn "tc.cover.top" 30 $ "coverageCheck: getDefFreeVars"-- -- The initial module parameter substitutions need to be weakened by the- -- number of arguments that aren't module parameters.- fv <- getDefFreeVars f+ reportSLn "tc.cover.top" 30 $ "coverageCheck: getting context and checkpoints"+ (gamma, checkpoints) <- addContext gamma1 $ do+ (,) <$> getContextTelescope <*> viewTC eCheckpoints - reportSLn "tc.cover.top" 30 $ "coverageCheck: getting checkpoints"+ let -- n = arity+ -- xs = variable patterns fitting gamma+ n = size gamma+ xs = map (setOrigin Inserted) $ teleNamedArgs gamma - -- TODO: does this make sense? Why are we weakening by n - fv?- checkpoints <- applySubst (raiseS (n - fv)) <$> viewTC eCheckpoints+ unsafeInTopContext $ do -- construct the initial split clause let sc = SClause gamma xs idS checkpoints $ Just $ defaultDom a@@ -131,13 +130,13 @@ let prCl cl = addContext (clauseTel cl) $ prettyTCMPatternList $ namedClausePats cl vcat- [ text $ "Coverage checking " ++ prettyShow f ++ " with patterns:"- , nest 2 $ vcat $ map prCl cs+ [ text $ "Coverage checking " ++! prettyShow f ++! " with patterns:"+ , nest 2 $ vcat $ map' prCl cs ] -- used = actually used clauses for cover -- pss = non-covered cases- CoverResult splitTree used pss qss noex <- cover f cs sc+ CoverResult splitTree used pss qss noex <- cover YesInferMissing f cs sc -- Andreas, 2018-11-12, issue #378: -- some indices in @used@ and @noex@ point outside of @cs@,@@ -147,16 +146,16 @@ reportSDoc "tc.cover.top" 10 $ vcat [ "cover computed!"- , text $ "used clauses: " ++ show used- , text $ "non-exact clauses: " ++ show (IntSet.toList noex)+ , text $ "used clauses: " ++! show used+ , text $ "non-exact clauses: " ++! show (IntSet.toList noex) ] reportSDoc "tc.cover.splittree" 10 $ vcat [ "generated split tree for" <+> prettyTCM f , text $ prettyShow splitTree ] reportSDoc "tc.cover.covering" 10 $ vcat- [ text $ "covering patterns for " ++ prettyShow f- , nest 2 $ vcat $ map (\ cl -> addContext (clauseTel cl) $ prettyTCMPatternList $ namedClausePats cl) qss+ [ text $ "covering patterns for " ++! prettyShow f+ , nest 2 $ vcat $ map' (\ cl -> addContext (clauseTel cl) $ prettyTCMPatternList $ namedClausePats cl) qss ] -- Storing the covering clauses so that checkIApplyConfluence_ can@@ -189,7 +188,7 @@ , clauseBody = Nothing , clauseType = Nothing , clauseCatchall = YesCatchall empty -- absurd clauses are safe as catch-all- , clauseRecursive = Just False+ , clauseRecursive = NotRecursive , clauseUnreachable = Just False , clauseEllipsis = NoEllipsis , clauseWhereModule = Nothing@@ -203,7 +202,7 @@ , "i = " <+> pretty i , "cl = " <+> pretty (QNamed f cl) ]- addClauses f [cl]+ addClauses f $ singleton cl return False -- report a warning if there are uncovered cases,@@ -220,7 +219,7 @@ -- Replace the first clauses by @cs1@. There might be more -- added by @inferMissingClause@.- modifyFunClauses f $ \ cs0 -> cs1 ++ drop (length cs1) cs0+ modifyFunClauses f $ \ cs0 -> cs1 ++! drop (length cs1) cs0 -- Warn if there are unreachable clauses and mark them as unreachable. List1.unlessNull (filter ((Just True ==) . clauseUnreachable) cs1) \ unreached -> do@@ -248,6 +247,13 @@ return splitTree +-- | When checking whether a clause is already covered,+-- we do not want 'inferMissingClause' as a side effect.+data InferMissing+ = YesInferMissing -- ^ Infer missing instance and tactic clauses.+ | NoInferMissing -- ^ Don't.+ deriving (Eq, Show)+ -- | Top-level function for eliminating redundant clauses in the interactive -- case splitter isCovered :: QName -> [Clause] -> SplitClause -> TCM Bool@@ -256,35 +262,35 @@ [ "isCovered" , nest 2 $ vcat $ [ "f = " <+> prettyTCM f- , "cs = " <+> vcat (map (nest 2 . prettyTCM . NamedClause f True) cs)+ , "cs = " <+> vcat (map' (nest 2 . prettyTCM . NamedClause f True) cs) , "sc = " <+> prettyTCM sc ] ] -- Jesper, 2019-10: introduce trailing arguments (see #3828) (_ , sc') <- insertTrailingArgs True sc- CoverResult { coverMissingClauses = missing } <- cover f cs sc'+ CoverResult { coverMissingClauses = missing } <- cover NoInferMissing f cs sc' return $ null missing -- Andreas, 2019-08-08 and 2020-02-11 -- If there is an error (e.g. unification error), don't report it -- to the user. Rather, assume the clause is not already covered. `catchError` \ _ -> return False --- | @cover f cs (SClause _ _ ps _) = return (CoverResult splitTree used missing covering noex)@.+-- | @cover infermissing f cs (SClause _ _ ps _) = return (CoverResult splitTree used missing covering noex)@. -- checks that the list of clauses @cs@ covers the given split clause. -- Returns the @splitTree@, the @used@ clauses, @missing@ cases, the @covering@ clauses, -- and the non-exact clauses @noex@. ----- Effect: adds missing instance clauses for @f@ to signature.+-- Effect: if 'YesInferMissing', adds missing instance clauses for @f@ to signature. ---cover :: QName -> [Clause] -> SplitClause ->+cover :: InferMissing -> QName -> [Clause] -> SplitClause -> TCM CoverResult-cover f cs sc@(SClause tel ps _ _ target) = updateRelevance $ do+cover infermissing f cs sc@(SClause tel ps _ _ target) = updateRelevance $ do reportSDoc "tc.cover.cover" 10 $ inTopContext $ vcat [ "checking coverage of pattern:" , nest 2 $ prettyTCM sc , nest 2 $ "target sort =" <+> do addContext tel $ maybe (text "<none>") (prettyTCM . getSort . unDom) target ]- reportSLn "tc.cover.cover" 80 $ "raw target =\n" ++ show 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@@ -295,7 +301,7 @@ match cs ps >>= \case Yes (i,mps) -> do- reportSLn "tc.cover.cover" 10 $ "pattern covered by clause " ++ show i+ reportSLn "tc.cover.cover" 10 $ "pattern covered by clause " ++! show i reportSDoc "tc.cover.cover" 20 $ text "with mps = " <+> do addContext tel $ pretty mps let cl0 = indexWithDefault __IMPOSSIBLE__ cs i -- Szumi, 2024-09-15, issue #7495: If the split clause has more@@ -318,7 +324,7 @@ No -> do reportSLn "tc.cover" 20 $ "pattern is not covered" let infer dom = isInstance dom || isJust (domTactic dom)- if maybe False infer target+ if infermissing == YesInferMissing && maybe False infer target then do -- Ulf, 2016-10-31: For now we only infer instance clauses. It would -- make sense to do it also for hidden, but since the value of a@@ -338,7 +344,7 @@ when (null bs) __IMPOSSIBLE__ -- Otherwise, if there are variables to split, we try them -- in the order determined by a split strategy.- reportSLn "tc.cover.strategy" 20 $ "blocking vars = " ++ prettyShow bs+ reportSLn "tc.cover.strategy" 20 $ "blocking vars = " ++! prettyShow bs -- xs is a non-empty lists of blocking variables -- try splitting on one of them xs <- splitStrategy bs tel@@ -418,10 +424,12 @@ 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)+ Just nm' ->+ let !dom' = set dName (Just (WithOrigin CaseSplit (unranged nm'))) $+ fmap (const ((nm' , snd (unDom dom)))) dom+ !s' = s - 1+ in (dom', s')+ Nothing -> (dom ,) $! s - 1 applyCl :: SplitClause -> Clause -> [(Nat, SplitPattern)] -> TCM Clause applyCl sc@SClause{scTel = pretel, scPats = sps} cl mps@@ -454,16 +462,20 @@ -- and the body of the clause. mtv <- (traverse . traverse) (telViewUpToPath n_extra) $ clauseType cl- let ty = (fmap . fmap) ((parallelS (reverse $ map namedArg extra) `composeS` liftS n_extra s `applyPatSubst`) . theCore) mtv+ let ty = (fmap . fmap) ((parallelS (reverse $ map' namedArg extra) `composeS` liftS n_extra s `applyPatSubst`) . theCore) mtv+ let body = (`applyE` patternsToElims extra) . (s `applyPatSubst`) <$> clauseBody cl+ let pats = (s `applySubst` ps) ++! extra reportSDoc "tc.cover.applyCl" 40 $ "new ty =" <+> pretty ty+ reportSDoc "tc.cover.applyCl" 40 $ "new pats =" <+> pretty pats+ reportSDoc "tc.cover.applyCl" 40 $ "new body =" <+> pretty body return $ Clause { clauseLHSRange = clauseLHSRange cl , clauseFullRange = clauseFullRange cl , clauseTel = tel- , namedClausePats = (s `applySubst` ps) ++ extra- , clauseBody = (`applyE` patternsToElims extra) . (s `applyPatSubst`) <$> clauseBody cl+ , namedClausePats = pats+ , clauseBody = body , clauseType = ty , clauseCatchall = clauseCatchall cl , clauseRecursive = clauseRecursive cl@@ -474,7 +486,7 @@ where mps' = Map.fromList $- map (mapSnd (namedArg . fromSplitPattern . defaultNamedArg)) mps+ map' (second (namedArg . fromSplitPattern . defaultNamedArg)) mps s = parallelS (for (case Map.lookupMax mps' of Nothing -> [] Just (i, _) -> [0..i]) $ \ i ->@@ -485,8 +497,7 @@ -- Don't do anything if there is no target type info. caseMaybe target cont $ \ b -> do -- TODO (2018-10-16): if proofs get erased in the compiler, also wake erased vars!- let m = getModality b- applyModalityToContext m cont+ applyDomToContext b cont continue :: [BlockingVar]@@ -505,7 +516,7 @@ let qs = [] return $ CoverResult (SplittingDone (size tel)) empty [] qs empty Right (Covering n scs', x) -> do- let scs = map (\(t,(sc,i)) -> (t,sc)) scs'+ let scs = map' (\(t,(sc,i)) -> (t,sc)) scs' (results_trX, cs) <- createMissingIndexedClauses f n x sc scs' cs (scs, cs, results_hc) <- do@@ -518,28 +529,39 @@ (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- qsss = map coverPatterns results- noex = map coverNoExactClauses results+ results <- mapM (cover infermissing f cs . snd) scs+ let+ results_extra = results_hc ++! results_trX+ trees_extra = map' (second coverSplitTree) results_extra+ results' = results ++! map' snd results_extra+ -- Andreas, 2025-10-12: add trees_extra later because they would get lost+ -- by the zipWith that constructs trees' below.+ trees = map' coverSplitTree results -- missing ' is not a typo+ useds = map' coverUsedClauses results'+ psss = map' coverMissingClauses results'+ qsss = map' coverPatterns results'+ noex = map' coverNoExactClauses results' -- Jesper, 2016-03-10 We need to remember which variables were -- eta-expanded by the unifier in order to generate a correct split -- tree (see Issue 1872).- reportSDoc "tc.cover.split.eta" 60 $ vcat- [ "etaRecordSplits"+ addContext tel $ reportSDoc "tc.cover.split.lazy" 60 $ vcat+ [ "lazySplits" , nest 2 $ vcat- [ "n = " <+> text (show n)+ [ "n = " <+> pretty n , "scs = " <+> prettyTCM scs- , "ps = " <+> prettyTCMPatternList (fromSplitPatterns ps)+ , "ps = " <+> inTopContext (addContext tel $ prettyTCMPatternList $ fromSplitPatterns ps) ] ]- let trees' = zipWith (etaRecordSplits (unArg n) ps) scs trees- tree = SplitAt n StrictSplit (trees' ++ trees_extra) -- TODO: Lazy?+ trees' <- zipWithM (lazySplits (unArg n) ps) trees scs+ let tree = SplitAt n StrictSplit (trees' ++! trees_extra) -- TODO: Lazy?+ -- Andreas, 2025-10-12: Debug printing to clarify the trees_extra situation.+ reportSDoc "tc.cover.cubical" 30 $ vcat $+ "trees:" : map' pretty trees +++ "trees':" : map' pretty trees' +++ "trees_extra:" : map' pretty trees_extra +++ "coverSplitTree:" : pretty tree :+ "coverPatterns:" : map' prettyTCM (concat qsss) return $ CoverResult tree (IntSet.unions useds) (concat psss) (concat qsss) (IntSet.unions noex) -- Try to split result@@ -564,25 +586,36 @@ if null tel then if finalSplit then __IMPOSSIBLE__ -- already ruled out by lhs checker else cont- else cover f cs sc'+ else cover infermissing f cs sc' -- ...or it was an IApply pattern, so we might just need to introduce the variable now. trySplitRes (BlockedOnApply IsIApply) finalSplit splitError cont = do- caseMaybeM (splitResultPath f sc) fallback $ (cover f cs . snd) <=< insertTrailingArgs False+ caseMaybeM (splitResultPath f sc) fallback $ (cover infermissing f cs . snd) <=< insertTrailingArgs False where fallback | finalSplit = __IMPOSSIBLE__ -- already ruled out by lhs checker? | otherwise = cont + -- Andreas, 2025-10-25, issue #8139+ --+ -- - This was the old logic:+ --+ -- -- blocked on result but there are catchalls:+ -- -- try regular splits if there are any, or else throw an error,+ -- -- this is nicer than continuing and reporting unreachable clauses+ -- -- (see issue #2833)+ -- trySplitRes (BlockedOnProj True) finalSplit splitError cont+ -- | finalSplit = splitError CosplitCatchall+ -- | otherwise = cont+ --+ -- - The new logic allows copattern catchalls for the sake of further splitting+ -- but they are reported as unreachable.+ -- -- blocked on result but there are catchalls:- -- try regular splits if there are any, or else throw an error,- -- this is nicer than continuing and reporting unreachable clauses- -- (see issue #2833)- trySplitRes (BlockedOnProj True) finalSplit splitError cont- | finalSplit = splitError CosplitCatchall- | otherwise = cont+ -- try regular splits if there are any+ trySplitRes (BlockedOnProj True) False splitError cont = cont -- all clauses have an unsplit copattern: try to split- trySplitRes (BlockedOnProj False) finalSplit splitError cont = do+ trySplitRes (BlockedOnProj _) finalSplit splitError cont = do reportSLn "tc.cover" 20 $ "blocked by projection pattern" -- forM is a monadic map over a Maybe here mcov <- splitResultRecord f sc@@ -593,61 +626,66 @@ 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)) (map (\(t,(sc,i)) -> (t,sc)) scs)+ mapM (traverseF $ cover infermissing f cs <=< (snd <.> insertTrailingArgs False)) (map' (\(t,(sc,i)) -> (t,sc)) scs) -- OR: -- forM scs $ \ (proj, sc') -> (proj,) <$> do -- cover f cs =<< do -- snd <$> fixTarget sc'- let trees = map coverSplitTree results- useds = map coverUsedClauses results- psss = map coverMissingClauses results- qsss = map coverPatterns results- noex = map coverNoExactClauses results+ let trees = map' coverSplitTree results+ useds = map' coverUsedClauses results+ psss = map' coverMissingClauses results+ qsss = map' coverPatterns results+ noex = map' coverNoExactClauses results tree = SplitAt n StrictSplit $ zip projs trees -- TODO: Lazy? return $ CoverResult tree (IntSet.unions useds) (concat psss) (concat qsss) (IntSet.unions noex) - gatherEtaSplits :: Int -> SplitClause+ gatherLazySplits :: Int -> SplitClause -> [NamedArg SplitPattern] -> [NamedArg SplitPattern]- gatherEtaSplits n sc []+ gatherLazySplits n sc [] | n >= 0 = __IMPOSSIBLE__ -- we should have encountered the main -- split by now already | otherwise = []- gatherEtaSplits n sc (p:ps) = case namedArg p of+ gatherLazySplits n sc (p:ps) = case namedArg p of VarP _ x | n == 0 -> case p' of -- this is the main split- VarP _ _ -> p : gatherEtaSplits (-1) sc ps+ VarP _ _ -> p : gatherLazySplits (-1) sc ps DotP _ _ -> __IMPOSSIBLE__- ConP _ _ qs -> qs ++ gatherEtaSplits (-1) sc ps- LitP{} -> gatherEtaSplits (-1) sc ps+ ConP _ _ qs -> qs ++! gatherLazySplits (-1) sc ps+ LitP{} -> gatherLazySplits (-1) sc ps ProjP{} -> __IMPOSSIBLE__ IApplyP{} -> __IMPOSSIBLE__- DefP _ _ qs -> qs ++ gatherEtaSplits (-1) sc ps -- __IMPOSSIBLE__ -- Andrea: maybe?+ DefP _ _ qs -> qs ++! gatherLazySplits (-1) sc ps -- __IMPOSSIBLE__ -- Andrea: maybe? | otherwise ->- updateNamedArg (\ _ -> p') p : gatherEtaSplits (n-1) sc ps+ updateNamedArg (\ _ -> p') p : gatherLazySplits (n-1) sc ps where p' = lookupS (scSubst sc) $ splitPatVarIndex x IApplyP{} ->- updateNamedArg (applySubst (scSubst sc)) p : gatherEtaSplits (n-1) sc ps- DotP _ _ -> p : gatherEtaSplits (n-1) sc ps -- count dot patterns- ConP _ _ qs -> gatherEtaSplits n sc (qs ++ ps)- DefP _ _ qs -> gatherEtaSplits n sc (qs ++ ps)- LitP{} -> gatherEtaSplits n sc ps- ProjP{} -> gatherEtaSplits n sc ps+ updateNamedArg (applySubst (scSubst sc)) p : gatherLazySplits (n-1) sc ps+ DotP _ _ -> p : gatherLazySplits (n-1) sc ps -- count dot patterns+ ConP _ _ qs -> gatherLazySplits n sc (qs ++! ps)+ DefP _ _ qs -> gatherLazySplits n sc (qs ++! ps)+ LitP{} -> gatherLazySplits n sc ps+ ProjP{} -> gatherLazySplits n sc ps - addEtaSplits :: Int -> [NamedArg SplitPattern] -> SplitTree -> SplitTree- addEtaSplits k [] t = t- addEtaSplits k (p:ps) t = case namedArg p of- VarP _ _ -> addEtaSplits (k + 1) ps t- DotP _ _ -> addEtaSplits (k + 1) ps t- ConP c cpi qs -> SplitAt (p $> k) LazySplit [(SplitCon (conName c) , addEtaSplits k (qs ++ ps) t)]+ addLazySplits :: Int -> [NamedArg SplitPattern] -> SplitTree -> SplitTree+ addLazySplits k [] t = t+ addLazySplits k (p:ps) t = case namedArg p of+ VarP _ _ -> addLazySplits (k + 1) ps t+ DotP _ _ -> addLazySplits (k + 1) ps t+ ConP c cpi qs ->+ -- Jesper, 2026-08-18, issue #8638: propagate erasure to subpatterns+ let qs' = map (mapQuantity $ composeQuantity $ getQuantity p) qs+ in SplitAt (p $> k) LazySplit [(SplitCon (conName c) , addLazySplits k (qs' ++! ps) t)] LitP{} -> __IMPOSSIBLE__ ProjP{} -> __IMPOSSIBLE__ DefP{} -> __IMPOSSIBLE__ -- Andrea: maybe?- IApplyP{} -> addEtaSplits (k + 1) ps t+ IApplyP{} -> addLazySplits (k + 1) ps t - etaRecordSplits :: Int -> [NamedArg SplitPattern] -> (SplitTag,SplitClause)- -> SplitTree -> (SplitTag,SplitTree)- etaRecordSplits n ps (q , sc) t =- (q , addEtaSplits 0 (gatherEtaSplits n sc ps) t)+ lazySplits :: Int -> [NamedArg SplitPattern]+ -> SplitTree -> (SplitTag, SplitClause) -> TCM (SplitTag, SplitTree)+ lazySplits n ps t (tag, sc) = do+ let splitsTodo = gatherLazySplits n sc ps+ reportSDoc "tc.cover.split.lazy" 60 $ "gatherLazySplits result: " <+> pretty splitsTodo+ return (tag, addLazySplits 0 splitsTodo t) -- | Append a instance clause to the clauses of a function.@@ -680,12 +718,12 @@ , clauseBody = Just rhs , clauseType = Just (argFromDom t) , clauseCatchall = empty- , clauseRecursive = Nothing -- could be recursive- , clauseUnreachable = Just False -- missing, thus, not unreachable+ , clauseRecursive = MaybeRecursive -- could be recursive+ , clauseUnreachable = Just False -- missing, thus, not unreachable , clauseEllipsis = NoEllipsis , clauseWhereModule = Nothing }- addClauses f [cl] -- Important: add at the end.+ addClauses f $ singleton cl -- Important: add at the end. return cl inferMissingClause _ (SClause _ _ _ _ Nothing) = __IMPOSSIBLE__ @@ -695,7 +733,7 @@ -- we make our last try to split. -- Otherwise, we will not get a nice error message. where- xs = strict ++ lazy+ xs = strict ++! lazy (lazy, strict) = List.partition blockingVarLazy bs {- KEEP! -- Andreas, 2012-10-13@@ -713,7 +751,7 @@ -- the data type must be inductive. isDatatype :: (MonadTCM tcm, MonadError SplitError tcm) => Induction -> Dom Type ->- tcm (DataOrRecord, QName, Sort, Args, Args, [QName], Bool)+ tcm (DataOrRecord, QName, Sort, Args, Args, [QName], IsHIT) isDatatype ind at = do let t = unDom at throw f = throwError . f =<< do liftTCM $ buildClosure t@@ -725,22 +763,22 @@ Def d [Apply phi] | Just d == mIsOne -> do xs <- liftTCM $ decomposeInterval =<< reduce (unArg phi) if null xs- then return $ (IsData, d, mkSSet 0, [phi], [], [], False)+ then return $ (IsData, d, mkSSet 0, [phi], [], [], NotHIT) else throw NotADatatype Def d es -> do let ~(Just args) = allApplyElims es def <- liftTCM $ getConstInfo d case theDef def of- Datatype{dataSort = s, dataPars = np, dataCons = cs}+ Datatype{dataSort = s, dataPars = np, dataCons = cs, dataHIT = hit} | otherwise -> do let (ps, is) = splitAt np args- return (IsData, d, s, ps, is, cs, not $ null (dataPathCons $ theDef def))+ return (IsData, d, s, ps, is, cs, hit) Record{recPars = np, recConHead = con, recInduction = i, recEtaEquality'} | i == Just CoInductive && ind /= CoInductive -> throw CoinductiveDatatype | otherwise -> do s <- liftTCM $ shouldBeSort =<< defType def `piApplyM` args- return (IsRecord InductionAndEta { recordInduction=i, recordEtaEquality=recEtaEquality' }, d, s, args, [], [conName con], False)+ return (IsRecord InductionAndEta { recordInduction=i, recordEtaEquality=recEtaEquality' }, d, s, args, [], [conName con], NotHIT) _ -> throw NotADatatype _ -> throw NotADatatype @@ -801,12 +839,12 @@ let n = size tel -- Andreas, 2016-10-04 issue #2236 -- Need to set origin to "Inserted" to avoid printing of hidden patterns.- xs = map (mapArgInfo hiddenInserted) $ teleNamedArgs tel+ xs = map' (mapArgInfo hiddenInserted) $ teleNamedArgs tel -- Compute new split clause- sctel' = telFromList $ telToList (raise n sctel) ++ telToList tel+ sctel' = telFromList $ telToList (raise n sctel) ++! telToList tel -- Dot patterns in @ps@ need to be raised! (Issue 1298)- ps' = applySubst (raiseS n) ps ++ xs- newTarget = Just $ (if not (null tel) then a{ domTactic = Nothing } else a) $> b+ ps' = applySubst (raiseS n) ps ++! xs+ newTarget = Just $ (if not (null tel) then a & dTactic .~ Nothing else a) $> b sc' = SClause { scTel = sctel' , scPats = ps'@@ -869,7 +907,7 @@ 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+ dsort <- liftTCM $ (parallelS (reverse $ map' unArg pars) `applySubst`) . dataSort . theDef <$> getConstInfo d hCompName <- fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' builtinHComp theHCompT <- defType <$> getConstInfo hCompName @@ -877,7 +915,7 @@ caseMaybe (hasHComp dsort) (return Nothing) $ \ dlvl' -> do let dlvl = Level dlvl'- dterm = Def d [] `apply` (pars ++ ixs)+ dterm = Def d [] `apply` (pars ++! ixs) -- Δ1 ⊢ gamma TelV gamma _ <- lift $ telView (theHCompT `piApply` [setHiding Hidden $ defaultArg $ dlvl , defaultArg $ dterm]) case (delta1 `abstract` gamma,IdS) of@@ -887,10 +925,10 @@ -- 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) $ -- should there be a different Origin here?- map (fmap unnamed) [setHiding Hidden $ defaultArg $ applySubst rho1 $ DotP defaultPatternInfo $ dlvl+ 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?+ ++! applySubst rho2 (teleNamedArgs gamma) -- rho0? -- Compute final context and substitution let rho3 = consS defp rho1 -- Δ₁' ⊢ ρ₃ : Δ₁(x:D) delta2' = applySplitPSubst rho3 delta2 -- Δ₂' = Δ₂ρ₃@@ -960,14 +998,15 @@ Just cixs = allApplyElims es return (gamma0, cixs, boundary) - let (_, Dom{domInfo = info} : _) = splitAt (size tel - hix - 1) (telToList tel)+ let (_, dom : _) = splitAt (size tel - hix - 1) (telToList tel)+ info = dom ^. dInfo -- Andreas, 2012-02-25 preserve name suggestion for recursive arguments -- of constructor let preserve (x, t@(El _ (Def d' _))) | d == d' = (n, t) preserve (x, t) = (x, t)- gamma = (fmap . mapModality) (composeModality (getModality info)) $ telFromList . map (fmap preserve) . telToList $ gamma0+ gamma = (fmap . mapModality) (composeModality (getModality info)) $ telFromList . map' (fmap preserve) . telToList $ gamma0 delta1Gamma = delta1 `abstract` gamma debugInit con ctype d pars ixs cixs delta1 delta2 gamma tel ps hix@@ -975,7 +1014,7 @@ cforced <- defForced <$> getConstInfo c -- Variables in Δ₁ are not forced, since the unifier takes care to not introduce forced -- variables.- let forced = replicate (size delta1) NotForced ++ cforced+ let forced = replicate (size delta1) NotForced ++! cforced flex = allFlexVars forced delta1Gamma -- All variables are flexible -- Unify constructor target and given type (in Δ₁Γ)@@ -991,10 +1030,11 @@ return $ abstract (mapCohesion updCoh <$> dtel) dt dsort <- addContext delta1 $ reduce (getSort dtype) - let withKIfStrict = applyWhen (isStrictDataSort dsort) $ locallyTC eSplitOnStrict $ const True+ let withKIfStrict :: forall a. CoverM a -> CoverM a+ withKIfStrict = applyWhen (isStrictDataSort dsort) $ locallyTC eSplitOnStrict (const True) -- Should we attempt to compute a left inverse for this clause? When- -- --cubical-compatible --flat-split is given, we don't generate a+ -- --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.@@ -1003,7 +1043,6 @@ let flatSplit = boolToMaybe (getCohesion info == Flat) SplitOnFlat r <- withKIfStrict $ lift $- Bench.billTo [Bench.Coverage, Bench.UnifyIndices] $ unifyIndices' flatSplit delta1Gamma flex@@ -1025,13 +1064,14 @@ UnifyStuck errs -> stuck Nothing errs - Unifies (delta1',rho0,eqs,tauInv) -> do+ Unifies (delta1',rho0,eqs,getTauInv) -> do+ tauInv <- withKIfStrict $ lift getTauInv 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+ = TheInfo $ UE delta1Gamma delta1' eqTel (map' unArg conIxs) (map' unArg givenIxs) rho0 tau leftInv | otherwise = NoInfo @@ -1056,7 +1096,7 @@ -- Andreas, 2017-09-03, issue #2729: remember that pattern was generated by case split. let cpi = noConPatternInfo{ conPInfo = PatternInfo PatOSplit [] , conPRecord = True } conp = ConP con cpi $ applySubst rho0' $- map (mapArgInfo hiddenInserted . fmap (fmap setSplitArgOrigin)) $+ map' (mapArgInfo hiddenInserted . fmap (fmap setSplitArgOrigin)) $ telePatterns' (tele2NamedArgs gamma0) gamma boundary -- Andreas, 2016-09-08, issue #2166: use gamma0 for correct argument names @@ -1093,9 +1133,9 @@ , "ctype =" <+> prettyTCM ctype , "ps =" <+> do inTopContext $ addContext tel $ prettyTCMPatternList $ fromSplitPatterns ps , "d =" <+> prettyTCM d- , "pars =" <+> do prettyList $ map prettyTCM pars- , "ixs =" <+> do addContext delta1 $ prettyList $ map prettyTCM ixs- , "cixs =" <+> do addContext gamma $ prettyList $ map prettyTCM cixs+ , "pars =" <+> do prettyList $ map' prettyTCM pars+ , "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 n $ prettyTCM delta2 , "gamma =" <+> do inTopContext $ addContext delta1 $ prettyTCM gamma@@ -1129,12 +1169,12 @@ debugSubst s sub = liftTCM $ reportSDoc "tc.cover.split.con" 20 $ nest 2 $ vcat- [ text (s ++ " =") <+> prettyTCM sub+ [ text (s ++! " =") <+> prettyTCM sub ] debugTel s tel = liftTCM $ reportSDoc "tc.cover.split.con" 20 $ nest 2 $ vcat- [ text (s ++ " =") <+> prettyTCM tel+ [ text (s ++! " =") <+> prettyTCM tel ] debugPs tel ps =@@ -1261,18 +1301,20 @@ return (fst $ unDom dom, snd <$> dom, telFromList tel1, telFromList tel2) -- Compute the neighbourhoods for the constructors- let computeNeighborhoods = do+ let computeNeighborhoods :: ExceptT SplitError TCM (DataOrRecord, Sort, Bool, Int, [(SplitTag, (SplitClause, IInfo))])+ computeNeighborhoods = do -- Check that t is a datatype or a record -- Andreas, 2010-09-21, isDatatype now directly throws an exception if it fails -- cons = constructors of this datatype (dr, d, s, pars, ixs, cons', isHIT) <- inContextOfT $ isDatatype ind t isFib <- fromRight (const False) <$> lift (isFibrant' t) cons <- case checkEmpty of- CheckEmpty -> ifM (liftTCM $ inContextOfT $ isEmptyType $ unDom t) (pure []) (pure cons')+ CheckEmpty -> ifM (liftTCM $ inContextOfT $ isEmptyType 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 isFib && (isHIT || not (null ixs)) && not (null mns) && inserttrailing == DoInsertTrailing+ hcompsc <- if isFib && (isHIT == YesHIT || not (null ixs)) && not (null mns) && inserttrailing == DoInsertTrailing then computeHCompSplit delta1 n delta2 d pars ixs x tel ps cps else return Nothing let ns = catMaybes mns@@ -1280,9 +1322,10 @@ , s , not (null ixs) -- Is "d" indexed? , length $ ns- , ns ++ catMaybes ([fmap (fmap (,NoInfo)) hcompsc | not $ null $ ns])+ , ns ++! catMaybes ([fmap (fmap (,NoInfo)) hcompsc | not $ null $ ns]) ) + computeLitNeighborhoods :: ExceptT SplitError TCM (DataOrRecord, Sort, Bool, Int, [(SplitTag, (SplitClause, IInfo))]) computeLitNeighborhoods = do typeOk <- liftTCM $ do t' <- litType $ headWithDefault {-'-} __IMPOSSIBLE__ plits@@ -1310,7 +1353,7 @@ -- to an inductive family (with at least one index), then the -- following code should be changed (the constructor False -- stands for "not indexed").- let ns' = map ((fmap (,NoInfo))) $ ns ++ [ ca ]+ let ns' = map' ((fmap (,NoInfo))) $ ns ++! [ ca ] return (IsData, mkType 0, False, length ns', ns') -- numMatching is the number of proper constructors matching, excluding hcomp.@@ -1331,8 +1374,8 @@ mHCompName <- getPrimitiveName' builtinHComp opts <- pragmaOptions- let withoutK = optWithoutK opts- erasedMatches = optErasedMatches opts+ builtin <- currentModuleIsBuiltinModuleWithSafePostulates+ let erasedMatches = optErasedMatches opts isRecordWithEta = case dr of IsData -> False IsRecord r ->@@ -1341,12 +1384,23 @@ NoEta{} -> False erased <- hasQuantity0 <$> viewTC eQuantity- reportSLn "tc.cover.split" 60 $ "We are in erased context = " ++ show erased+ reportSLn "tc.cover.split" 60 $ "We are in erased context = " ++! show erased+ reportSDoc "tc.cover.split" 60 $ vcat+ [ "Allowed erased matches:"+ , "* Empty: " <+> text (show (emEmpty erasedMatches))+ , "* Non-dependent:" <+> text (show (emNonDependent erasedMatches))+ , "* Restricted: " <+> text (show (emRestricted erasedMatches))+ , "* Unrestricted: " <+> text (show (emUnrestricted erasedMatches))+ ] let erasedError reason = throwError . ErasedDatatype reason =<< do liftTCM $ inContextOfT $ buildClosure (unDom t) case numMatching of+ -- Erased matches for empty types can be disallowed, but there is+ -- no check for such matches here: such a check can instead be+ -- found in Agda.TypeChecking.Rules.LHS.checkAbsurdPattern (see+ -- issue #8788). 0 -> do let absurdp = VarP (PatternInfo PatOAbsurd []) $ SplitPatVar underscore 0 [] rho = liftS x $ consS absurdp $ raiseS 1@@ -1363,20 +1417,42 @@ n | n > 1 && not erased && not (usableQuantity t) -> erasedError SeveralConstructors - -- If exactly one constructor matches and the K rule is turned- -- off, then we only allow erasure for non-indexed data/record- -- types (#4172). If the type is not a record type with- -- η-equality, then the flag --erased-matches must be active.- 1 | not erased && not (usableQuantity t) && withoutK &&- (isIndexed || not isRecordWithEta && not erasedMatches) ->- erasedError (if isIndexed then NoK else NoErasedMatches)+ -- Exactly one constructor matches, the argument is erased, and+ -- run-time mode is active. This is disallowed (#4172) unless+ --+ -- ∗ the type is a (non-indexed) record type with η-equality, or+ --+ -- ∗ the type is non-indexed and erased matches are allowed for+ -- single-constructor, non-indexed data types, or+ --+ -- ∗ the type is indexed and erased matches are allowed for+ -- single-constructor, indexed data types, or+ --+ -- ∗ the type is indexed, []-cong is allowed, and the module+ -- currently being type-checked is a builtin module that allows+ -- safe postulates. (One could restrict this further to just the+ -- module @Agda.Builtin.Erased.Box-cong@.)+ --+ -- In the case where the type is indexed the error message only+ -- refers to @--erased-matches=unrestricted@ because+ -- @--erased-matches=restricted@ is only useful in builtin+ -- modules.+ 1 | not erased && not (usableQuantity t) &&+ not (not isIndexed && (isRecordWithEta ||+ emNonDependent erasedMatches) ||+ isIndexed && emUnrestricted erasedMatches ||+ isIndexed && emRestricted erasedMatches && builtin) ->+ erasedError $+ if isIndexed+ then ErasedMatchesDisabledDependent+ else ErasedMatchesDisabledNonDependent _ -> do -- Andreas, 2012-10-10 fail if precomputed constructor set does not cover -- all the data type constructors -- Andreas, 2017-10-08 ... unless partial covering is explicitly allowed.- let ptags = map (SplitCon . conName) pcons' ++ map SplitLit plits+ let ptags = map' (SplitCon . conName) pcons' ++! map' SplitLit plits -- clauses for hcomp will be automatically generated. let inferred_tags = maybe Set.empty (Set.singleton . SplitCon) mHCompName let all_tags = Set.fromList ptags `Set.union` inferred_tags@@ -1397,7 +1473,7 @@ return $ Right $ Covering (lookupPatternVar sc x) ns where- inContextOfT, inContextOfDelta2 :: (MonadTCM tcm, MonadAddContext tcm, MonadDebug tcm) => tcm a -> tcm a+ inContextOfT, inContextOfDelta2 :: (MonadAddContext tcm) => tcm a -> tcm a inContextOfT = addContext tel . escapeContext impossible (x + 1) inContextOfDelta2 = addContext tel . escapeContext impossible x @@ -1415,10 +1491,10 @@ reportSDoc "tc.cover.top" 60 $ vcat [ "TypeChecking.Coverage.split': split" , nest 2 $ vcat- [ "tel =" <+> (text . show) tel- , "x =" <+> (text . show) x- , "ps =" <+> (text . show) ps- , "cps =" <+> (text . show) cps+ [ "tel =" <+> pretty tel+ , "x =" <+> pretty x+ , "ps =" <+> pretty ps+ , "cps =" <+> pretty cps ] ] @@ -1448,7 +1524,7 @@ (TelV i b, boundary) <- telViewUpToPathBoundary' 1 (unDom t) let tel' = abstract tel i rho = raiseS 1- ps' = applySubst rho (scPats sc) ++ telePatterns i boundary+ ps' = applySubst rho (scPats sc) ++! telePatterns i boundary cps' = applySubst rho (scCheckpoints sc) target' = Just $ b <$ t return . Just $ SClause tel' ps' idS cps' target'@@ -1474,9 +1550,9 @@ failure . CosplitNoRecordType =<< buildClosure (unDom t) Just (_r, vs, RecordData{ _recFields = fs }) -> do reportSDoc "tc.cover" 20 $ sep- [ text $ "we are of record type _r = " ++ prettyShow _r+ [ text $ "we are of record type _r = " ++! prettyShow _r , text "applied to parameters vs =" <+> addContext tel (prettyTCM vs)- , text $ "and have fields fs = " ++ prettyShow fs+ , text $ "and have fields fs = " ++! prettyShow fs ] -- Andreas, 2018-06-09, issue #2170, we always have irrelevant projections -- available on the lhs.@@ -1486,7 +1562,7 @@ let es = patternsToElims $ fromSplitPatterns ps -- Note: module parameters are part of ps let self = defaultArg $ Def f [] `applyE` es- pargs = vs ++ [self]+ pargs = vs ++! [self] fieldValues = for fs $ \ proj -> unArg self `applyE` [Proj ProjSystem (unDom proj)] reportSDoc "tc.cover" 20 $ addContext tel $ sep [ text "we are self =" <+> prettyTCM (unArg self)@@ -1505,12 +1581,12 @@ dType <- defType <$> do getConstInfo $ unDom proj -- WRONG: typeOfConst $ unArg proj let -- Substitution for parameters and previous fields. Needs to be applied to potential -- tactic in proj.- fieldSub = reverse (map unArg vs ++ prevFields) ++# EmptyS impossible+ fieldSub = reverse (map' unArg vs ++! prevFields) ++# EmptyS impossible proj' = applySubst fieldSub proj -- type of projection instantiated at self target' = Just $ proj' $> dType `piApply` pargs -- Always visible (#2287) projArg = fmap (Named Nothing . ProjP projOrigin) $ argFromDom $ setHiding NotHidden proj- sc' = sc { scPats = scPats sc ++ [projArg]+ sc' = sc { scPats = scPats sc ++! [projArg] , scSubst = idS , scTarget = target' }@@ -1536,7 +1612,7 @@ [ "SplitClause" , nest 2 $ vcat [ "tel =" <+> prettyTCM tel- , "pats =" <+> sep (map (prettyTCM . namedArg) pats)+ , "pats =" <+> sep (map' (prettyTCM . namedArg) pats) , "subst =" <+> prettyTCM sigma , "checkpoints =" <+> prettyTCM cps , "target =" <+> do
src/full/Agda/TypeChecking/Coverage/Cubical.hs view
@@ -10,15 +10,16 @@ import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet -import Agda.Syntax.Common+import Agda.Syntax.Common hiding (DataOrRecord) import Agda.Syntax.Position-import Agda.Syntax.Internal hiding (DataOrRecord)+import Agda.Syntax.Internal import Agda.Syntax.Internal.Pattern import Agda.Syntax.Common.Pretty (prettyShow) import Agda.TypeChecking.Constraints () -- instance MonadConstraint TCM import Agda.TypeChecking.Coverage.Match import Agda.TypeChecking.Coverage.SplitClause+import Agda.TypeChecking.Coverage.SplitPattern import Agda.TypeChecking.Coverage.SplitTree import Agda.TypeChecking.Datatypes (getDatatypeArgs) import Agda.TypeChecking.Irrelevance@@ -46,13 +47,14 @@ import Agda.Utils.Impossible -createMissingIndexedClauses :: QName- -> Arg Nat- -> BlockingVar- -> SplitClause- -> [(SplitTag,(SplitClause,IInfo))]- -> [Clause]- -> TCM ([(SplitTag,CoverResult)],[Clause])+createMissingIndexedClauses ::+ QName+ -> Arg Nat+ -> BlockingVar+ -> SplitClause+ -> [(SplitTag,(SplitClause,IInfo))]+ -> [Clause]+ -> TCM ([(SplitTag,CoverResult)],[Clause]) createMissingIndexedClauses f n x old_sc scs cs = do let infos = [(c,i) | (SplitCon c, (_,TheInfo i)) <- scs ] case scs of@@ -73,8 +75,8 @@ 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 hcomp, SplittingDone $ size $ clauseTel hcomp_cl)+ ] -- = [ (SplitCon trX, SplittingDone $ size $ clauseTel trX_cl) ] extraCl = [trX_cl, hcomp_cl] -- = [trX_cl]@@ -102,12 +104,13 @@ Right d_f -> pure $ map unArg d_f Left failed_t -> typeError $ CannotGenerateTransportClause func failed_t -createMissingTrXTrXClause :: QName -- ^ trX- -> QName -- ^ f defined- -> Arg Nat- -> BlockingVar- -> SplitClause- -> TCM Clause+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@@ -349,19 +352,21 @@ , clauseBody = Just rhs , clauseType = Just $ Arg (getArgInfo ty) (unDom ty) , clauseCatchall = empty- , clauseRecursive = Just True+ , clauseRecursive = YesRecursive , 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 ::+ QName+ -> QName+ -> Arg Nat+ -> BlockingVar+ -> SplitClause+ -> TCM Clause createMissingTrXHCompClause q_trX f n x old_sc = do let old_tel = scTel old_sc@@ -616,21 +621,23 @@ , clauseBody = Just rhs , clauseType = Just $ Arg (getArgInfo ty) (unDom ty) , clauseCatchall = empty- , clauseRecursive = Just True+ , clauseRecursive = YesRecursive , 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 ::+ 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 $@@ -640,6 +647,7 @@ , "u" <+> addContext gamma (prettyTCM u) , "v" <+> addContext gamma (prettyTCM v) , "rho" <+> addContext gamma' (prettyTCM rho)+ , "tau" <+> pretty tau ] Constructor{conSrcCon = chead} <- theDef <$> getConstInfo c@@ -850,7 +858,7 @@ , clauseBody = Just rhs , clauseType = Just $ Arg (getArgInfo ty) (unDom ty) , clauseCatchall = empty- , clauseRecursive = Just True+ , clauseRecursive = YesRecursive , clauseUnreachable = Just False , clauseEllipsis = NoEllipsis , clauseWhereModule = Nothing@@ -864,12 +872,13 @@ , nest 2 $ prettyTCM . QNamed f $ cl ] - let mod =+ let dom = setRelevance irrelevant $ -- See #5611.- getModality $ fromMaybe __IMPOSSIBLE__ $ scTarget old_sc+ fromMaybe __IMPOSSIBLE__ $ scTarget old_sc+ mod = getModality dom -- we follow what `cover` does when updating the modality from the target.- applyModalityToContext mod $ do- unlessM (hasQuantity0 <$> viewTC eQuantity) $ do+ applyDomToContext dom $ do+ unlessM (hasQuantity0 <$> viewTC eQuantityZeroHardCompile) $ do reportSDoc "tc.cover.trxcon" 20 $ text "testing usable at mod: " <+> pretty mod addContext cTel $ usableAtModality IndexedClause mod rhs @@ -894,13 +903,16 @@ -} -- | Append an hcomp clause to the clauses of a function.-createMissingHCompClause- :: QName+createMissingHCompClause ::+ QName -- ^ Function name.- -> Arg Nat -- ^ index of hcomp pattern- -> BlockingVar -- ^ Blocking var that lead to hcomp split.- -> SplitClause -- ^ Clause before the hcomp split+ -> 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])@@ -1123,7 +1135,7 @@ , clauseBody = Just $ rhs , clauseType = Just $ defaultArg t , clauseCatchall = empty- , clauseRecursive = Nothing -- TODO: can it be recursive?+ , clauseRecursive = MaybeRecursive -- TODO: can it be recursive? , clauseUnreachable = Just False -- missing, thus, not unreachable , clauseEllipsis = NoEllipsis , clauseWhereModule = Nothing
src/full/Agda/TypeChecking/Coverage/Match.hs view
@@ -13,10 +13,6 @@ module Agda.TypeChecking.Coverage.Match ( Match(..), match, matchClause- , SplitPattern, SplitPatVar(..)- , fromSplitPattern, fromSplitPatterns, toSplitPatterns- , toSplitPSubst, applySplitPSubst- , isTrivialPattern , BlockingVar(..), BlockingVars, BlockedOnResult(..) , setBlockingVarOverlap , ApplyOrIApply(..)@@ -28,24 +24,26 @@ import Data.Foldable (toList) import qualified Data.List as List import Data.Maybe (mapMaybe, fromMaybe)-import Data.Semigroup ( Semigroup, (<>)) import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Literal import Agda.TypeChecking.Monad+import Agda.TypeChecking.Coverage.SplitPattern import Agda.TypeChecking.Pretty ( PrettyTCM(..) ) import Agda.TypeChecking.Records import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute +import Agda.Utils.List import Agda.Utils.Null import Agda.Syntax.Common.Pretty ( Pretty(..), text, (<+>), cat , prettyList_ ) import Agda.Utils.Monad import Agda.Utils.Singleton import Agda.Utils.Impossible+import Agda.Syntax.Position (KillRange, killRange, killRangeN) -- | If matching is inconclusive (@Block@) we want to know which -- variables or projections are blocking the match.@@ -114,115 +112,6 @@ -> m (Match (Nat, SplitInstantiation)) 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.---- (See issue #708.)-data SplitPatVar = SplitPatVar- { splitPatVarName :: PatVarName- , splitPatVarIndex :: Int- , splitExcludedLits :: [Literal]- } deriving (Show)--instance Pretty SplitPatVar where- prettyPrec _ x =- text (patVarNameToString (splitPatVarName x)) <>- text ("@" ++ show (splitPatVarIndex x)) <>- ifNull (splitExcludedLits x) empty (\lits ->- "\\{" <> prettyList_ lits <> "}")--instance PrettyTCM SplitPatVar where- prettyTCM = prettyTCM . var . splitPatVarIndex--type SplitPattern = Pattern' SplitPatVar--toSplitVar :: DBPatVar -> SplitPatVar-toSplitVar x = SplitPatVar (dbPatVarName x) (dbPatVarIndex x) []--fromSplitVar :: SplitPatVar -> DBPatVar-fromSplitVar x = DBPatVar (splitPatVarName x) (splitPatVarIndex x)--instance DeBruijn SplitPatVar where- deBruijnView x = deBruijnView (fromSplitVar x)- deBruijnNamedVar n i = toSplitVar (deBruijnNamedVar n i)--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 fromSplitPattern--type SplitPSubstitution = Substitution' SplitPattern--toSplitPSubst :: PatternSubstitution -> SplitPSubstitution-toSplitPSubst = (fmap . fmap) toSplitVar--fromSplitPSubst :: SplitPSubstitution -> PatternSubstitution-fromSplitPSubst = (fmap . fmap) fromSplitVar--applySplitPSubst :: TermSubst a => SplitPSubstitution -> a -> a-applySplitPSubst = applyPatSubst . fromSplitPSubst---- TODO: merge this instance and the one for DeBruijnPattern in--- Substitute.hs into one for Subst (Pattern' a) (Pattern' a).-instance Subst SplitPattern where- type SubstArg SplitPattern = SplitPattern-- applySubst IdS = id- applySubst rho = \case- VarP i x ->- usePatternInfo i $- useName (splitPatVarName x) $- useExcludedLits (splitExcludedLits x) $- lookupS rho $ splitPatVarIndex x- DotP i u -> DotP i $ applySplitPSubst rho u- ConP c ci ps -> ConP c ci $ applySubst rho ps- DefP i q ps -> DefP i q $ applySubst rho ps- p@LitP{} -> p- p@ProjP{} -> p- IApplyP i l r x ->- useEndPoints (applySplitPSubst rho l) (applySplitPSubst rho r) $- usePatternInfo i $- useName (splitPatVarName x) $- useExcludedLits (splitExcludedLits x) $- lookupS rho $ splitPatVarIndex x-- where- -- see Subst for DeBruijnPattern- useEndPoints :: Term -> Term -> SplitPattern -> SplitPattern- useEndPoints l r (VarP o x) = IApplyP o l r x- useEndPoints l r (IApplyP o _ _ x) = IApplyP o l r x- useEndPoints l r x = __IMPOSSIBLE__-- useName :: PatVarName -> SplitPattern -> SplitPattern- useName n (VarP o x)- | isUnderscore (splitPatVarName x)- = VarP o $ x { splitPatVarName = n }- useName _ x = x-- useExcludedLits :: [Literal] -> SplitPattern -> SplitPattern- useExcludedLits lits = \case- (VarP o x) -> VarP o $ x- { splitExcludedLits = lits ++ splitExcludedLits x }- p -> p---{-# SPECIALIZE isTrivialPattern :: Pattern' a -> TCM Bool #-}--- | A pattern that matches anything (modulo eta).-isTrivialPattern :: (HasConstInfo m) => Pattern' a -> m Bool-isTrivialPattern = \case- VarP{} -> return True- DotP{} -> return True- ConP c i ps -> andM $ ((conPLazy i ||) <$> isEtaCon (conName c))- : (map (isTrivialPattern . namedArg) ps)- DefP{} -> return False- LitP{} -> return False- ProjP{} -> return False- IApplyP{} -> return True- -- | If matching succeeds, we return the instantiation of the clause pattern vector -- to obtain the split clause pattern vector. type MatchResult = Match (DList (Nat, SplitPattern))@@ -253,24 +142,16 @@ blockedOnApplication :: Monad m => ApplyOrIApply -> m (Match a) blockedOnApplication b = return $ Block (BlockedOnApply b) []---UNUSED Liang-Ting Chen 2019-07-16----- | Lens for 'blockingVarCons'.---mapBlockingVarCons :: ([ConHead] -> [ConHead]) -> BlockingVar -> BlockingVar---mapBlockingVarCons f b = b { blockingVarCons = f (blockingVarCons b) }-------- | Lens for 'blockingVarLits'.---mapBlockingVarLits :: ([Literal] -> [Literal]) -> BlockingVar -> BlockingVar---mapBlockingVarLits f b = b { blockingVarLits = f (blockingVarLits b) } setBlockingVarOverlap :: BlockingVar -> BlockingVar-setBlockingVarOverlap = \x -> x { blockingVarOverlap = True }+setBlockingVarOverlap x = x { blockingVarOverlap = True } overlapping :: BlockingVars -> BlockingVars-overlapping = map setBlockingVarOverlap+overlapping = map' setBlockingVarOverlap -- | Left dominant merge of blocking vars. zipBlockingVars :: BlockingVars -> BlockingVars -> BlockingVars-zipBlockingVars xs ys = map upd xs+zipBlockingVars xs ys = map' upd xs where upd (BlockingVar x cons lits o l) = case List.find ((x ==) . blockingVarNo) ys of Just (BlockingVar _ cons' lits' o' l') -> BlockingVar x (cons ++ cons') (lits ++ lits') (o || o') (l || l')@@ -475,9 +356,9 @@ unDotP (DotP o v) = reduce v >>= \case Var i [] -> return $ deBruijnVar i Con c _ vs -> do- let ps = map (fmap $ unnamed . DotP o) $ fromMaybe __IMPOSSIBLE__ $ allApplyElims vs+ let ps = map' (fmap $ unnamed . DotP o) $ mustAllApplyElims vs return $ ConP c noConPatternInfo ps- Lit l -> return $ LitP (PatternInfo PatODot []) l+ Lit l -> return $ LitP (LitPatternInfo (PatternInfo PatODot []) empty) l v -> return $ dotP v unDotP p = return p @@ -505,15 +386,12 @@ {-# SPECIALIZE unLitP :: Pattern' a -> TCM (Pattern' a) #-} unLitP :: HasBuiltins m => Pattern' a -> m (Pattern' a)-unLitP (LitP info l@(LitNat n)) | n >= 0 = do- constructorForm'- (fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinZero)- (fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSuc)- (Lit l) >>= \case+unLitP (LitP lpi@(LitPatternInfo info prio) l@(LitNat n)) | n >= 0 = do+ constructorForm (Lit l) >>= \case Con c ci es -> do- let toP (Apply (Arg i (Lit l))) = Arg i (LitP info l)+ let toP (Apply (Arg i (Lit l))) = Arg i (LitP lpi l) toP _ = __IMPOSSIBLE__- cpi = noConPatternInfo { conPInfo = info }- return $ ConP c cpi $ map (fmap unnamed . toP) es+ cpi = noConPatternInfo { conPInfo = info, conPPrio = prio }+ return $ ConP c cpi $ map' (fmap unnamed . toP) es _ -> __IMPOSSIBLE__ unLitP p = return p
src/full/Agda/TypeChecking/Coverage/SplitClause.hs view
@@ -11,11 +11,13 @@ import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet -import Agda.Syntax.Common-import Agda.Syntax.Common.Pretty (prettyShow)-import Agda.Syntax.Internal hiding (DataOrRecord)+import Agda.Syntax.Common hiding (DataOrRecord)+import Agda.Syntax.Common.Pretty (Pretty, pretty, prettyShow)+import qualified Agda.Syntax.Common.Pretty as P+import Agda.Syntax.Internal import Agda.TypeChecking.Coverage.Match+import Agda.TypeChecking.Coverage.SplitPattern import Agda.TypeChecking.Coverage.SplitTree import Agda.TypeChecking.Monad import Agda.TypeChecking.Substitute@@ -69,22 +71,33 @@ -- 'fixTargetType' computes the new 'scTarget' by applying -- substitution 'scSubst'. }+ deriving Show -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+instance Pretty SplitClause where+ pretty (SClause tel ps _rho _cps mt) =+ P.vcat+ [ "SplitClause"+ , P.text "tel =" P.<+> P.pretty tel+ , P.text "ps =" P.<+> P.pretty ps+ , P.text "mt =" P.<+> P.pretty mt+ ] +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'.@@ -119,6 +132,6 @@ , coverUsedClauses :: IntSet -- Set Nat , coverMissingClauses :: [(Telescope, [NamedArg DeBruijnPattern])] , coverPatterns :: [Clause]- -- ^ The set of patterns used as cover.+ -- ^ The set of patterns used as cover. , coverNoExactClauses :: IntSet -- Set Nat }
+ src/full/Agda/TypeChecking/Coverage/SplitPattern.hs view
@@ -0,0 +1,137 @@+{-# OPTIONS -Wunused-imports #-}++module Agda.TypeChecking.Coverage.SplitPattern+ ( SplitPattern, SplitPatVar(..)+ , fromSplitPattern, fromSplitPatterns, toSplitPatterns+ , toSplitPSubst, applySplitPSubst+ , isTrivialPattern+ ) where++import Prelude hiding ( null )++import Agda.Syntax.Common+import Agda.Syntax.Internal+import Agda.Syntax.Literal++import Agda.TypeChecking.Monad+import Agda.TypeChecking.Pretty ( PrettyTCM(..) )+import Agda.TypeChecking.Records+import Agda.TypeChecking.Substitute++import Agda.Utils.Null+import Agda.Syntax.Common.Pretty ( Pretty(..), text, prettyList_ )+import Agda.Utils.Monad++import Agda.Utils.Impossible+import Agda.Syntax.Position (KillRange, killRange, killRangeN)++{-# SPECIALIZE isTrivialPattern :: Pattern' a -> TCM Bool #-}+-- | A pattern that matches anything (modulo eta).+isTrivialPattern :: (HasConstInfo m) => Pattern' a -> m Bool+isTrivialPattern = \case+ VarP{} -> return True+ DotP{} -> return True+ ConP c i ps -> andM $ ((conPLazy i ||) <$> isEtaCon (conName c))+ : (map (isTrivialPattern . namedArg) ps)+ DefP{} -> return False+ LitP{} -> return False+ ProjP{} -> return False+ IApplyP{} -> return True++-- | For each variable in the patterns of a split clause, we remember the+-- de Bruijn-index and the literals excluded by previous matches.++-- (See issue #708.)+data SplitPatVar = SplitPatVar+ { splitPatVarName :: PatVarName+ , splitPatVarIndex :: Int+ , splitExcludedLits :: [Literal]+ } deriving (Show)++instance Pretty SplitPatVar where+ prettyPrec _ x =+ text (patVarNameToString (splitPatVarName x)) <>+ text ("@" ++ show (splitPatVarIndex x)) <>+ ifNull (splitExcludedLits x) empty (\lits ->+ "\\{" <> prettyList_ lits <> "}")++instance PrettyTCM SplitPatVar where+ prettyTCM = prettyTCM . var . splitPatVarIndex++instance KillRange SplitPatVar where+ killRange (SplitPatVar n i lits) = killRangeN SplitPatVar n i lits++type SplitPattern = Pattern' SplitPatVar++toSplitVar :: DBPatVar -> SplitPatVar+toSplitVar x = SplitPatVar (dbPatVarName x) (dbPatVarIndex x) []++fromSplitVar :: SplitPatVar -> DBPatVar+fromSplitVar x = DBPatVar (splitPatVarName x) (splitPatVarIndex x)++instance DeBruijn SplitPatVar where+ deBruijnView x = deBruijnView (fromSplitVar x)+ deBruijnNamedVar n i = toSplitVar (deBruijnNamedVar n i)++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 fromSplitPattern++type SplitPSubstitution = Substitution' SplitPattern++toSplitPSubst :: PatternSubstitution -> SplitPSubstitution+toSplitPSubst = (fmap . fmap) toSplitVar++fromSplitPSubst :: SplitPSubstitution -> PatternSubstitution+fromSplitPSubst = (fmap . fmap) fromSplitVar++applySplitPSubst :: TermSubst a => SplitPSubstitution -> a -> a+applySplitPSubst = applyPatSubst . fromSplitPSubst++-- TODO: merge this instance and the one for DeBruijnPattern in+-- Substitute.hs into one for Subst (Pattern' a) (Pattern' a).+instance Subst SplitPattern where+ type SubstArg SplitPattern = SplitPattern++ applySubst IdS = id+ applySubst rho = \case+ VarP i x ->+ usePatternInfo i $+ useName (splitPatVarName x) $+ useExcludedLits (splitExcludedLits x) $+ lookupS rho $ splitPatVarIndex x+ DotP i u -> DotP i $ applySplitPSubst rho u+ ConP c ci ps -> ConP c ci $ applySubst rho ps+ DefP i q ps -> DefP i q $ applySubst rho ps+ p@LitP{} -> p+ p@ProjP{} -> p+ IApplyP i l r x ->+ useEndPoints (applySplitPSubst rho l) (applySplitPSubst rho r) $+ usePatternInfo i $+ useName (splitPatVarName x) $+ useExcludedLits (splitExcludedLits x) $+ lookupS rho $ splitPatVarIndex x++ where+ -- see Subst for DeBruijnPattern+ useEndPoints :: Term -> Term -> SplitPattern -> SplitPattern+ useEndPoints l r (VarP o x) = IApplyP o l r x+ useEndPoints l r (IApplyP o _ _ x) = IApplyP o l r x+ useEndPoints l r x = __IMPOSSIBLE__++ useName :: PatVarName -> SplitPattern -> SplitPattern+ useName n (VarP o x)+ | isUnderscore (splitPatVarName x)+ = VarP o $ x { splitPatVarName = n }+ useName _ x = x++ useExcludedLits :: [Literal] -> SplitPattern -> SplitPattern+ useExcludedLits lits = \case+ (VarP o x) -> VarP o $ x+ { splitExcludedLits = lits ++ splitExcludedLits x }+ p -> p
src/full/Agda/TypeChecking/Coverage/SplitTree.hs view
@@ -83,12 +83,18 @@ instance Pretty a => Pretty (SplitTreeLabel a) where pretty = \case SplitTreeLabel Nothing Nothing _ (Just n) -> text $ "done, " ++ prettyShow n ++ " bindings"- SplitTreeLabel Nothing (Just n) lz Nothing -> lzp lz <+> text ("split at " ++ prettyShow n)+ SplitTreeLabel Nothing (Just n) lz Nothing -> lzp n lz <+> text ("split at " ++ prettyShow n) SplitTreeLabel (Just q) Nothing _ (Just n) -> pretty q <+> text ("-> done, " ++ prettyShow n ++ " bindings")- SplitTreeLabel (Just q) (Just n) lz Nothing -> pretty q <+> text "->" <+> lzp lz <+> text ("split at " ++ prettyShow n)+ SplitTreeLabel (Just q) (Just n) lz Nothing -> pretty q <+> text "->" <+> lzp n lz <+> text ("split at " ++ prettyShow n) _ -> __IMPOSSIBLE__- where lzp lz | lz == LazySplit = "lazy"- | otherwise = empty+ where+ lzp n lz =+ (if hasQuantity0 (getQuantity n)+ then "erased"+ else empty) <+>+ (case lz of+ LazySplit -> "lazy"+ StrictSplit -> empty) -- | Convert a split tree into a 'Data.Tree' (for printing). toTree :: SplitTree' a -> Tree (SplitTreeLabel a)
src/full/Agda/TypeChecking/Datatypes.hs view
@@ -16,6 +16,8 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.Pretty +import Agda.Utils.Boolean ( toBool )+import Agda.Utils.CallStack import Agda.Utils.Either import Agda.Utils.Functor import Agda.Syntax.Common.Pretty ( prettyShow )@@ -28,7 +30,7 @@ --------------------------------------------------------------------------- -- | Get true constructor with record fields.-getConHead :: (HasConstInfo m) => QName -> m (Either SigError ConHead)+getConHead :: (HasCallStack, HasConstInfo m) => QName -> m (Either SigError ConHead) getConHead c = runExceptT $ do def <- ExceptT $ getConstInfo' c case theDef def of@@ -36,25 +38,28 @@ Record { recConHead = c' } -> return c' _ -> throwError $ SigUnknown $ prettyShow c ++ " is not a constructor" -isConstructor :: (HasConstInfo m) => QName -> m Bool+isConstructor :: (HasCallStack, 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)+getConForm :: HasCallStack => QName -> TCM (Either SigError ConHead) getConForm c = caseEitherM (getConHead c) (return . Left) $ \ ch -> do Con con _ [] <- constructorForm (Con ch ConOCon []) return $ Right con -- | Augment constructor with record fields (preserve constructor name). -- The true constructor might only surface via 'reduce'.-getOrigConHead :: QName -> TCM (Either SigError ConHead)-getOrigConHead c = mapRight (setConName c) <$> getConHead c+getOrigConHead :: HasCallStack => QName -> TCM ConHead+getOrigConHead c = setConName c <$> do+ fromRightM+ (sigError c (typeError $ AbstractConstructorNotInScope c)) $+ getConHead c -- | Get the name of the datatype constructed by a given constructor. -- Precondition: The argument must refer to a constructor {-# SPECIALIZE getConstructorData :: QName -> TCM QName #-}-getConstructorData :: HasConstInfo m => QName -> m QName+getConstructorData :: (HasCallStack, HasConstInfo m) => QName -> m QName getConstructorData c = do def <- getConstInfo c case theDef def of@@ -63,22 +68,26 @@ -- | Is the datatype of this constructor a Higher Inductive Type? -- Precondition: The argument must refer to a constructor of a datatype or record.-consOfHIT :: HasConstInfo m => QName -> m Bool+consOfHIT :: (HasCallStack, HasConstInfo m) => QName -> m Bool consOfHIT c = do- d <- getConstructorData c- def <- theDef <$> getConstInfo d- case def of- Datatype {dataPathCons = xs} -> return $ not $ null xs- Record{} -> return False+ theDef <$> getConstInfo c >>= \case+ -- A path constructor is always a constructor of a HIT,+ -- so we only need to consult the data type for point constructors.+ Constructor{ conPathCons = PathCons } -> return True+ Constructor{ conPathCons = PointCons, conData = d } ->+ theDef <$> getConstInfo d >>= \case+ Datatype{ dataHIT = hit } -> return $ toBool hit+ Record{} -> return False+ _ -> __IMPOSSIBLE__ _ -> __IMPOSSIBLE__ -isPathCons :: HasConstInfo m => QName -> m Bool+-- | Is this a path constructor (of a higher inductive type)?+-- Precondition: The argument must refer to a constructor of a datatype or record.+isPathCons :: (HasCallStack, HasConstInfo m) => QName -> m Bool isPathCons c = do- d <- getConstructorData c- def <- theDef <$> getConstInfo d+ def <- theDef <$> getConstInfo c case def of- Datatype {dataPathCons = xs} -> return $ c `elem` xs- Record{} -> return False+ Constructor{ conPathCons = p } -> return $ p == PathCons _ -> __IMPOSSIBLE__ -- | @getFullyAppliedConType c t@ computes the constructor parameters@@ -114,7 +123,7 @@ reportSLn "tc.getConType" 35 $ unwords $ [ "getFullyAppliedConType: case Def", prettyShow d, prettyShow es ] dt <- defType <$> getConstInfo d- let pars = fromMaybe __IMPOSSIBLE__ $ allApplyElims $ take npars es+ let pars = mustAllApplyElims $ take npars es ctPars <- ctype `piApplyM` pars return $ Just ((d, dt, pars), ctPars) _ -> return Nothing@@ -218,10 +227,10 @@ -- | Return the number of non-parameter arguments to a constructor (arity). -- In case of record constructors, also return the field names (plus other info). ---getConstructorInfo :: HasConstInfo m => QName -> m ConstructorInfo+getConstructorInfo :: (HasCallStack, HasConstInfo m) => QName -> m ConstructorInfo getConstructorInfo c = fromMaybe __IMPOSSIBLE__ <$> getConstructorInfo' c -getConstructorInfo' :: HasConstInfo m => QName -> m (Maybe ConstructorInfo)+getConstructorInfo' :: (HasCallStack, HasConstInfo m) => QName -> m (Maybe ConstructorInfo) getConstructorInfo' c = do getConstInfo c <&> theDef >>= \case Constructor{ conData = d, conArity = n } -> Just <$> do@@ -266,7 +275,7 @@ Def d _ -> fmap (d,) <$> isDataOrRecordType d _ -> return Nothing -getNumberOfParameters :: HasConstInfo m => QName -> m (Maybe Nat)+getNumberOfParameters :: (HasCallStack, HasConstInfo m) => QName -> m (Maybe Nat) getNumberOfParameters d = do def <- getConstInfo d case theDef def of@@ -277,7 +286,7 @@ -- | 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 :: (HasCallStack, HasConstInfo m) => Type -> m (Maybe (QName, Args, Args)) getDatatypeArgs t = do case unEl t of Def d es -> do
src/full/Agda/TypeChecking/Datatypes.hs-boot view
@@ -2,8 +2,9 @@ module Agda.TypeChecking.Datatypes where -import Agda.TypeChecking.Monad.Signature-import Agda.Syntax.Internal+import Agda.TypeChecking.Monad.Signature ( HasConstInfo, SigError )+import Agda.Syntax.Internal ( QName, ConHead )+import Agda.Utils.CallStack ( HasCallStack ) -getConHead :: HasConstInfo m => QName -> m (Either SigError ConHead)-getConstructorData :: HasConstInfo m => QName -> m QName+getConHead :: (HasCallStack, HasConstInfo m) => QName -> m (Either SigError ConHead)+getConstructorData :: (HasCallStack, HasConstInfo m) => QName -> m QName
src/full/Agda/TypeChecking/DeadCode.hs view
@@ -2,13 +2,16 @@ module Agda.TypeChecking.DeadCode (eliminateDeadCode) where -import Control.Monad (filterM)+import Control.Monad import Control.Monad.Trans import Data.Maybe import qualified Data.Map.Strict as MapS import qualified Data.HashMap.Strict as HMap+import Data.IORef +import Agda.Interaction.Options (optSaveMetas)+ import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.Names@@ -19,11 +22,11 @@ import Agda.TypeChecking.Monad -import Agda.Utils.Monad (mapMaybeM) import Agda.Utils.Impossible-import Agda.Utils.Lens+import Agda.Utils.List+import qualified Agda.Utils.List1 as List1 -import Agda.Utils.HashTable (HashTable)+import Agda.Utils.HashTable (HashTableLU, HashTableLL) import qualified Agda.Utils.HashTable as HT -- | Run before serialisation to remove data that's not reachable from the@@ -46,6 +49,7 @@ !sig <- getSignature let !defs = sig ^. sigDefinitions !metas <- useR stSolvedMetaStore+ !saveMetas <- optSaveMetas <$> pragmaOptions -- #2921: Eliminating definitions with attached COMPILE pragmas results in -- the pragmas not being checked. Simple solution: don't eliminate these.@@ -67,64 +71,113 @@ -- Ulf, 2016-04-12: -- Non-closed display forms are not applicable outside the module anyway, -- and should be dead-code eliminated (#1928).+ let eliminateNonClosed = List1.nonEmpty . List1.filter isClosed+ !rootDisplayForms <-- HMap.filter (not . null) . HMap.map (filter isClosed) <$> useTC stImportsDisplayForms+ HMap.mapMaybe eliminateNonClosed <$> useTC stImportsDisplayForms - let !rootPubNames = map anameName $ publicNamesOfModules pubModules+ let !rootPubNames = map' anameName $ publicNamesOfModules pubModules let !rootExtraDefs = mapMaybe extraRootsFilter $ HMap.toList defs let !rootRewrites = sig ^. sigRewriteRules let !rootModSections = sig ^. sigSections !rootBuiltins <- useTC stLocalBuiltins !rootPatSyns <- getPatternSyns - !seenNames <- liftIO HT.empty :: TCM (HashTable QName ())- !seenMetas <- liftIO HT.empty :: TCM (HashTable MetaId ())+ -- When we're traversing the definition of a name, we want to record if the definition contains+ -- any metas. If a definition doesn't contain metas, we can skip instantiateFull on it before+ -- serialization.+ --+ -- We record "meta-closedness" in the following way. If we're traversing a name definition,+ -- "insideDef" contains the IORef Bool which can be flipped if we hit a metavariable. We+ -- store these IORef Bool-s in "seenNames". A new IORef Bool is created for each QName when we+ -- encounter it for the first time.+ !insideDef <- lift $ newIORef Nothing :: TCM (IORef (Maybe (IORef Bool))) + !seenNames <- lift $ HT.empty :: TCM (HashTableLL QName (IORef Bool))+ !seenMetas <- lift $ HT.empty :: TCM (HashTableLU MetaId ())+ let goName :: QName -> IO ()- goName !x = HT.lookup seenNames x >>= \case- Just _ ->- pure ()- Nothing -> do- HT.insert seenNames x ()- go (HMap.lookup x defs)+ goName !x = HT.insertingIfAbsent seenNames x+ -- already visited name, do nothing+ (\_ -> pure ()) + -- unvisited, insert new IORef into table+ (newIORef False)++ (\ref -> do+ prevRef <- readIORef insideDef -- save ref+ writeIORef insideDef (Just ref)+ go (HMap.lookup x defs)+ writeIORef insideDef prevRef -- restore ref+ )+ goMeta :: MetaId -> IO ()- goMeta !m = HT.lookup seenMetas m >>= \case- Just _ ->- pure ()- Nothing -> do- HT.insert seenMetas m ()- case MapS.lookup m metas of+ goMeta !m = do+ prevRef <- readIORef insideDef+ case prevRef of+ -- we're not inside any name definition+ Nothing -> pure ()+ -- we're inside a name definition, record meta occurrence+ Just ref -> writeIORef ref True++ HT.insertingIfAbsent seenMetas m+ -- already visited, do nothing+ (\_ -> pure ())++ (pure ())+ -- unvisited+ (\_ -> case MapS.lookup m metas of Nothing -> pure () Just mv -> do+ writeIORef insideDef Nothing go (instBody (theInstantiation mv))- go (jMetaType (mvJudgement mv))+ -- The meta's judgement reaches the interface (as+ -- rmvJudgement) only under --save-metas; otherwise the+ -- meta store is dropped after instantiateFull, so+ -- nothing reachable solely through the judgement's type+ -- can occur in the serialised interface, and traversing+ -- it would only grow the kept sets and the traversal+ -- cost (quadratically in the module's section+ -- telescopes, since each solved meta's type is closed+ -- over its context).+ when saveMetas $ go (jMetaType (mvJudgement mv))+ writeIORef insideDef prevRef -- restore ref+ ) go :: NamesIn a => a -> IO () go !x = namesAndMetasIn' (either goName goMeta) x {-# INLINE go #-} - Bench.billTo [Bench.DeadCode, Bench.DeadCodeReachable] $ liftIO $ do+ Bench.billTo [Bench.DeadCode, Bench.DeadCodeReachable] $ lift $ do go rootDisplayForms foldMap goName rootPubNames foldMap goName rootExtraDefs go rootRewrites go rootModSections go rootBuiltins- foldMap (go . PSyn) rootPatSyns+ foldMap go rootPatSyns - let filterMeta :: (MetaId, MetaVariable) -> IO (Maybe (MetaId, RemoteMetaVariable))- filterMeta (!i, !m) = HT.lookup seenMetas i >>= \case- Nothing -> pure Nothing- Just _ -> let !m' = remoteMetaVariable m in pure $ Just (i, m')+ let goMetas :: [(MetaId, MetaVariable)] -> IO [(MetaId, RemoteMetaVariable)]+ goMetas [] = pure []+ goMetas ((!i, !m):metas) = HT.lookup seenMetas i >>= \case+ Nothing -> goMetas metas+ Just _ -> do+ let !m' = remoteMetaVariable m+ ((i, m'):) <$!> goMetas metas - filterDef :: (QName, Definition) -> IO Bool- filterDef (!x, !d) = HT.lookup seenNames x >>= \case- Nothing -> pure False- Just _ -> pure True+ goDefs :: [(QName, Definition)] -> IO [(QName, Definition)]+ goDefs [] = pure []+ goDefs ((!x, !d):defs) = HT.lookup seenNames x >>= \case+ Nothing -> goDefs defs+ Just r -> do+ hasM <- readIORef r+ !d <- case hasM of+ True -> pure d+ False -> pure $! d {defMightContainMetas = False}+ ((x, d):) <$!> goDefs defs - !metas <- liftIO $ HMap.fromList <$> mapMaybeM filterMeta (MapS.toList metas)- !defs <- liftIO $ HMap.fromList <$> filterM filterDef (HMap.toList defs)+ !metas <- lift $ HMap.fromList <$> goMetas (MapS.toList metas)+ !defs <- lift $ HMap.fromList <$> goDefs (HMap.toList defs) pure (metas, defs, rootDisplayForms) -- | Returns the instantiation.
src/full/Agda/TypeChecking/DiscrimTree.hs view
@@ -29,10 +29,11 @@ import Agda.TypeChecking.DiscrimTree.Types -import qualified Agda.Utils.ProfileOptions as Profile+import qualified Agda.Interaction.Options.ProfileOptions as Profile import Agda.Utils.Impossible import Agda.Utils.Trie (Trie(..))+import Agda.Utils.List -- | Dummy term to use as a stand-in for expanded eta-records while -- building instance trees.@@ -51,7 +52,10 @@ -- Since the case tree was generated with wildcards everywhere an eta -- record appeared, if we're *looking up* an instance, we don't have to -- do the censorship again.-termKeyElims False _ es = pure (length es, map unArg es)+termKeyElims False _ es = do+ let !l = length es+ !es' = map' unArg es+ pure (l, es') termKeyElims precise ty args = do let@@ -81,7 +85,7 @@ -- incremented. tickExplore :: Term -> TCM () tickExplore tm = whenProfile Profile.Instances do- tick "flex term blocking instance"+ tick "explore" case tm of Def{} -> tick "explore: Def"@@ -323,9 +327,7 @@ -- matching con, we need to make sure that the spine has the -- right number of arguments, otherwise the (sp0, t:sp1) pattern -- for a Case will fail.- let- dummy n = Dummy ("_pad" <> show n) []- args' = take (keyArity key) (args ++ [ dummy n | n <- [0..] ])+ let args' = take' (keyArity key) $ args ++! [ __DUMMY_TERM_WITH__ ("_pad" <> show n) | n <- [0..] ] reportSDoc "tc.instance.discrim.lookup" 99 $ vcat [ "explore" <+> prettyTCM key <+> pretty (keyArity key) <+> pretty (length args)
src/full/Agda/TypeChecking/DisplayForm.hs view
@@ -86,7 +86,7 @@ return [ m | Just (d, m) <- ms, wellScoped scope d ] -- Not safe when printing non-terminating terms. -- (nfdfs, us) <- normalise (dfs, es)- unlessDebugPrinting $ reportSDoc "tc.display.top" 100 $ return $ vcat+ unlessDebugPrinting $ reportS "tc.display.top" 100 $ vcat [ "name :" <+> pretty q , "displayForms:" <+> pretty dfs , "arguments :" <+> pretty es
src/full/Agda/TypeChecking/DropArgs.hs view
@@ -2,8 +2,6 @@ module Agda.TypeChecking.DropArgs where -import Control.Arrow (second)- import Agda.Syntax.Common import Agda.Syntax.Internal @@ -13,8 +11,9 @@ import Agda.TypeChecking.CompiledClause import Agda.TypeChecking.Coverage.SplitTree -import Agda.Utils.Functor+import Agda.Utils.List import Agda.Utils.Permutation+import Agda.Utils.Tuple (second) import Agda.Utils.Impossible @@ -35,7 +34,7 @@ dropArgs n tel = telFromList $ drop n $ telToList tel instance DropArgs Permutation where- dropArgs n (Perm m p) = Perm (m - n) $ map (subtract n) $ drop n p+ dropArgs n (Perm m p) = Perm (m - n) $! map' (subtract n) $ drop n p -- | NOTE: does not work for recursive functions. instance DropArgs Clause where@@ -67,14 +66,17 @@ -- NOTE: this only works for non-recursive functions, we -- are not dropping arguments to recursive calls in bodies. instance DropArgs CompiledClauses where- dropArgs n cc = case cc of- Case i br | unArg i < n -> __IMPOSSIBLE__- | otherwise -> Case (i <&> \ j -> j - n) $ fmap (dropArgs n) br- Done xs t | length xs < n -> __IMPOSSIBLE__- | otherwise -> Done (drop n xs) t- Fail xs | length xs < n -> __IMPOSSIBLE__- | otherwise -> Fail (drop n xs)+ dropArgs n = \case+ Case i br+ | unArg i < n -> __IMPOSSIBLE__+ | otherwise -> Case (i <&> \ j -> j - n) $ fmap (dropArgs n) br+ Done no mr xs t+ | length xs < n -> __IMPOSSIBLE__+ | otherwise -> Done no mr (drop n xs) t+ Fail xs+ | length xs < n -> __IMPOSSIBLE__+ | otherwise -> Fail (drop n xs) instance DropArgs SplitTree where dropArgs n (SplittingDone m) = SplittingDone (m - n)- dropArgs n (SplitAt i lz ts) = SplitAt (subtract n <$> i) lz $ map (second $ dropArgs n) ts+ dropArgs n (SplitAt i lz ts) = SplitAt (subtract n <$> i) lz $ map' (second $ dropArgs n) ts
src/full/Agda/TypeChecking/Empty.hs view
@@ -9,8 +9,6 @@ import Control.Monad.Except ( MonadError(..) ) -import Data.Semigroup- import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.MetaVars@@ -18,7 +16,7 @@ import Agda.TypeChecking.Monad import Agda.TypeChecking.Coverage-import Agda.TypeChecking.Coverage.Match ( fromSplitPatterns )+import Agda.TypeChecking.Coverage.SplitPattern ( fromSplitPatterns ) import Agda.TypeChecking.Records import Agda.TypeChecking.Reduce ( instantiateFull ) import Agda.TypeChecking.Substitute@@ -44,22 +42,24 @@ instance Monoid ErrorNonEmpty where mempty = Fail- mappend = (Data.Semigroup.<>) -- | Ensure that a type is empty. -- This check may be postponed as emptiness constraint. ensureEmptyType- :: Range -- ^ Range of the absurd pattern.- -> Type -- ^ Type that should be empty (empty data type or iterated product of such).+ :: Range+ -- ^ Range of the absurd pattern.+ -> Dom Type+ -- ^ Type that should be empty (empty data type or iterated+ -- product of such). -> TCM () ensureEmptyType r t = caseEitherM (checkEmptyType r t) failure return where failure (DontKnow u) = addConstraint u $ IsEmpty r t failure (FailBecause err) = throwError err- failure Fail = typeError $ ShouldBeEmpty t []+ failure Fail = typeError $ ShouldBeEmpty (unDom t) [] -- | Check whether a type is empty.-isEmptyType :: MonadTCM tcm => Type -> tcm Bool+isEmptyType :: MonadTCM tcm => Dom Type -> tcm Bool isEmptyType ty = liftTCM $ isRight <$> checkEmptyType noRange ty -- | Check whether some type in a telescope is empty.@@ -68,9 +68,9 @@ -- Either the type is possibly non-empty (Left err) or it is really empty -- (Right ()).-checkEmptyType :: Range -> Type -> TCM (Either ErrorNonEmpty ())-checkEmptyType range t = do- mr <- tryRecordType t+checkEmptyType :: Range -> Dom Type -> TCM (Either ErrorNonEmpty ())+checkEmptyType range t0 = do+ mr <- tryRecordType (unDom t0) case mr of -- If t is blocked or a meta, we cannot decide emptiness now. Postpone.@@ -81,7 +81,9 @@ -- from the current context xs:ts, create a pattern list -- xs _ : ts t and try to split on _ (the last variable) tel0 <- getContextTelescope- let gamma = telToList tel0 ++ [domFromArg $ defaultArg (underscore, t)]+ let gamma = telToList tel0 +++ -- Do not forget the original 'DomInfo' (see #8744).+ [(underscore, t) <$ t0] tel = telFromList gamma ps = teleNamedArgs tel @@ -91,7 +93,12 @@ Left UnificationStuck{} -> do blocker <- unblockOnAnyMetaIn <$> instantiateFull tel -- TODO Jesper: get proper blocking information from unification return $ Left $ DontKnow blocker- Left _ -> return $ Left Fail+ Left err@ErasedDatatype{} ->+ -- This case is for disallowed erased matches on empty+ -- types.+ Left . FailBecause <$> typeError_ (SplitError err)+ Left _ ->+ return $ Left Fail Right cov -> do let ps = map (namedArg . lastWithDefault __IMPOSSIBLE__ . fromSplitPatterns . scPats) $ splitClauses cov if (null ps) then return (Right ()) else@@ -109,6 +116,6 @@ where loop i EmptyTel = return $ Left Fail loop i (ExtendTel dom tel) = orEitherM- [ (i <$) <$> checkEmptyType r (unDom dom)+ [ (i <$) <$> checkEmptyType r dom , underAbstraction dom tel $ loop (succ i) ]
src/full/Agda/TypeChecking/Empty.hs-boot view
@@ -8,13 +8,13 @@ ) where import Agda.TypeChecking.Monad (TCM, MonadTCM)-import Agda.Syntax.Internal (Type, Telescope)+import Agda.Syntax.Internal (Dom, Telescope, Type) import Agda.Syntax.Position (Range) data ErrorNonEmpty -isEmptyType :: MonadTCM tcm => Type -> tcm Bool+isEmptyType :: MonadTCM tcm => Dom Type -> tcm Bool isEmptyTel :: MonadTCM tcm => Telescope -> tcm Bool -ensureEmptyType :: Range -> Type -> TCM ()+ensureEmptyType :: Range -> Dom Type -> TCM () checkEmptyTel :: Range -> Telescope -> TCM (Either ErrorNonEmpty Int)
src/full/Agda/TypeChecking/Errors.hs view
@@ -5,6 +5,7 @@ module Agda.TypeChecking.Errors ( renderError , prettyError+ , prettyShadowedModule , tcErrString , prettyTCWarnings' , prettyTCWarnings@@ -18,7 +19,7 @@ , dropTopLevelModule , topLevelModuleDropper , explainWhyInScope- , Verbalize(verbalize)+ , Verbalize(verbalize), Indefinite(..), Ordinal(..) ) where import Prelude hiding ( null, foldl )@@ -48,17 +49,19 @@ import Agda.Syntax.Common import Agda.Syntax.Common.Pretty ( prettyShow, render ) import qualified Agda.Syntax.Common.Pretty as P-import Agda.Syntax.Concrete.Definitions (notSoNiceDeclarations)+import Agda.Syntax.Concrete.Definitions (notSoNiceDeclarations, NiceDeclaration (NiceDataDef, NiceRecDef)) import Agda.Syntax.Concrete.Definitions.Errors (declarationExceptionString) import Agda.Syntax.Concrete.Pretty (attributesForModality) import Agda.Syntax.Notation+import Agda.Syntax.Parser (agdaFileExtensions) import Agda.Syntax.Position import qualified Agda.Syntax.Concrete as C import Agda.Syntax.Abstract as A import Agda.Syntax.Internal as I import Agda.Syntax.Translation.InternalToAbstract-import Agda.Syntax.Scope.Monad (isDatatypeModule)+import Agda.Syntax.Scope.Monad (isDatatypeModule, resolveName', tryResolveName) import Agda.Syntax.Scope.Base+import Agda.Syntax.TopLevelModuleName (moduleNameToFileName) import Agda.TypeChecking.Errors.Names (typeErrorString) import Agda.TypeChecking.Monad@@ -70,26 +73,30 @@ import Agda.TypeChecking.Reduce (instantiate) import Agda.Interaction.Library.Base (formatLibErrors, libFile)+import qualified Agda.Interaction.Options.Base as Opts +import Agda.Utils.AssocList qualified as AssocList import Agda.Utils.FileName-import Agda.Utils.Float ( toStringWithoutDotZero )+import Agda.Utils.Float ( toStringWithoutDotZero ) import Agda.Utils.Function-import Agda.Utils.Functor( for )-import Agda.Utils.IO ( showIOException )+import Agda.Utils.Functor ( for )+import Agda.Utils.IO ( showIOException ) import Agda.Utils.Lens-import Agda.Utils.List ( initLast, lastMaybe )-import Agda.Utils.List1 ( List1, pattern (:|) )-import Agda.Utils.List2 ( pattern List2 )-import qualified Agda.Utils.List1 as List1-import qualified Agda.Utils.List2 as List2+import Agda.Utils.List ( initLast, lastMaybe, hasElem )+import Agda.Utils.List1 ( List1, pattern (:|) )+import Agda.Utils.List2 ( pattern List2 )+import Agda.Utils.List1 qualified as List1+import Agda.Utils.List2 qualified as List2 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null-import qualified Agda.Utils.Set1 as Set1+import Agda.Utils.Set1 qualified as Set1 import Agda.Utils.Singleton import Agda.Utils.Size+import Agda.Utils.String ( rtrim ) import Agda.Utils.Impossible+import Agda.TypeChecking.Conversion.Errors --------------------------------------------------------------------------- -- * Top level function@@ -101,16 +108,22 @@ {-# SPECIALIZE prettyError :: TCErr -> TCM Doc #-} prettyError :: MonadTCM tcm => TCErr -> tcm Doc-prettyError = liftTCM . flip renderError' [] where- renderError' :: TCErr -> [TCErr] -> TCM Doc- renderError' err errs- | length errs > 3 = fsep (- pwords "total panic: error when printing error from printing error from printing error." ++- pwords "I give up! Approximations of errors (original error last):" )- $$ vcat (map (text . tcErrString) errs)- | otherwise = applyUnless (null errs) ("panic: error when printing error!" $$) $ do- (prettyTCM err $$ vcat (map (text . ("when printing error " ++) . tcErrString) errs))- `catchError` \ err' -> renderError' err' (err:errs)+prettyError = liftTCM . go []+ where+ go :: [TCErr] -> TCErr -> TCM Doc+ go errs err+ | length errs > 3 = vcat $+ fwords ("total panic: error when printing error from printing error from printing error." +++ "I give up! Approximations of errors (original error last):")+ : map (text . tcErrString) errs+ | otherwise =+ applyUnless (null errs)+ (\ d -> vcat $+ "panic: error when printing error!"+ : d+ : map (text . ("when printing error " ++) . tcErrString) errs)+ (prettyTCM err)+ `catchError` go (err:errs) --------------------------------------------------------------------------- -- * Helpers@@ -123,7 +136,7 @@ nameWithBinding q = (prettyTCM q <+> "bound at") <?> prettyTCM r where- r = nameBindingSite $ qnameName q+ r = nameBindingSite q tcErrString :: TCErr -> String tcErrString err =@@ -148,7 +161,7 @@ -- Benchmark info during printing errors. TypeError loc s e -> withTCState (const s) $ do reportSLn "error" 2 $ "Error raised at " ++ prettyShow loc- let r = envRange $ clEnv e+ let r = clEnv e ^. eRange vcat [ hsep [ if null r then empty else prettyTCM r <> ":"@@ -156,7 +169,7 @@ , brackets (text $ typeErrorString $ clValue e) ] , prettyTCM e- , prettyTCM (envCall $ clEnv e)+ , prettyTCM (clEnv e ^. eCall) ] ParserError err -> pretty err GenericException msg -> fwords msg@@ -189,8 +202,41 @@ -- Print the range in 'qnameName'. This fixes the bad error message in #4130. prettyDisambCons :: MonadPretty m => QName -> m Doc-prettyDisambCons = prettyDisamb $ Just . nameBindingSite . qnameName+prettyDisambCons = prettyDisamb $ Just . nameBindingSite +prepruneErrorRefinedContext :: forall m. MonadPretty m => Closure MetaId -> m Doc+prepruneErrorRefinedContext = prepruneError empty $+ "Failed to generalize because some of the generalized variables depend on an " +++ "unsolved meta created in a refined context (not a simple extension of the context where " +++ "generalization happens)."++prepruneErrorCyclicDependencies :: forall m. MonadPretty m => Closure MetaId -> m Doc+prepruneErrorCyclicDependencies = prepruneError empty $+ "Failed to generalize due to circular dependencies between the generalized " +++ "variables and an unsolved meta."++prepruneErrorFailedToInstantiate :: forall m. MonadPretty m => Closure MetaId -> m Doc+prepruneErrorFailedToInstantiate = prepruneError prepruneErrorBounty $+ "Failed to generalize because the generalized variables depend on an unsolved meta " +++ "that could not be lifted outside the generalization."++prepruneErrorBounty :: Doc+prepruneErrorBounty = P.fsep $ concat+ [ P.pwords "Congratulations, you have hit a so far unreproduced error in generalization!"+ , P.pwords "Please submit your self-contained reproducer (max 50 lines) at"+ , [ P.url "https://github.com/agda/agda/issues/8161" ]+ , P.pwords "to earn a honorable mention in the next Agda release."+ ]++prepruneError :: forall m. MonadPretty m => Doc -> String -> Closure MetaId -> m Doc+prepruneError bounty msg x = enterClosure x \ x -> do+ r <- getMetaRange x+ vcat+ [ pure bounty+ , fwords $ msg ++ " The problematic unsolved meta is"+ , nest 2 $ prettyTCM (MetaV x []) <+> "at" <+> pretty r+ ]+ instance PrettyTCM TypeError where prettyTCM :: forall m. MonadPretty m => TypeError -> m Doc prettyTCM err = case err of@@ -202,10 +248,19 @@ CompilationError s -> sep [fwords "Compilation error:", text s] - GenericError s -> fwords s+ UserError d -> return d - GenericDocError d -> return d+ GeneralizationFailed d -> return d + GeneralizationPrepruneErrorRefinedContext x ->+ prepruneErrorRefinedContext x++ GeneralizationPrepruneErrorCyclicDependencies x ->+ prepruneErrorCyclicDependencies x++ GeneralizationPrepruneErrorFailedToInstantiate x ->+ prepruneErrorFailedToInstantiate x+ ExecError err -> prettyTCM err NicifierError err -> pretty err@@ -233,9 +288,11 @@ ShouldBeRecordType t -> fsep $ pwords "Expected non-abstract record type, found " ++ [prettyTCM t] - ShouldBeRecordPattern p -> fsep $- pwords "Expected record pattern" -- ", found " ++ [prettyTCM p]+ ShouldBeRecordPattern -> fsep $+ pwords "Expected record pattern" + EtaPragmaVsNoEtaEquality -> fwords $ "Record has both ETA_EQUALITY pragma and no-eta-equality directive"+ WrongHidingInLHS -> fwords "Unexpected implicit argument" WrongHidingInLambda t ->@@ -270,6 +327,15 @@ where xs = List1.filter (not . isNoName) xs0 + WrongNamedArgumentInLHS h x xs -> fsep $+ pwords "Unexpected" ++ [ hid h ] ++ pwords "argument named" ++ [ text x ]+ ++ [ parens $ fsep $ text "possible arguments:" : map text xs | not (null xs) ]+ where+ hid = \case+ Hidden -> "hidden"+ Instance{} -> "instance"+ NotHidden -> "visible"+ WrongHidingInApplication t -> fwords "Found an implicit application where an explicit application was expected" @@ -331,7 +397,7 @@ A.AsP _ _ p -> kindOfPattern p A.PatternSynP{} -> __IMPOSSIBLE__ - CannotEliminateWithProjection ty isAmbiguous projection -> sep+ CannotEliminateWithProjection _ ty isAmbiguous projection -> sep [ "Cannot eliminate type " , prettyTCM (unArg ty) , " with projection "@@ -356,46 +422,12 @@ pwords "The constructor" ++ [prettyTCM c] ++ pwords "does not construct an element of" ++ [prettyTCM t] - ConstructorPatternInWrongDatatype c d -> fsep $- [prettyTCM c] ++ pwords "is not a constructor of the datatype"+ ConstructorPatternInWrongDatatype c d dataOrRec -> fsep $+ [prettyTCM c] ++ pwords "is not a constructor of the"+ ++ [case dataOrRec of IsData -> "datatype"; IsRecord_ -> "record type"] ++ [prettyTCM d] - ShadowedModule x ms@(m0 :| _) -> do- -- Clash! Concrete module name x already points to the abstract names ms.- (r, m) <- do- -- Andreas, 2017-07-28, issue #719.- -- First, we try to find whether one of the abstract names @ms@ points back to @x@- scope <- getScope- -- Get all pairs (y,m) such that y points to some m ∈ ms.- let xms0 = concat $ ms <&> \ m -> map (,m) $ inverseScopeLookupModule m scope- reportSLn "scope.clash.error" 30 $ "candidates = " ++ prettyShow xms0-- -- Try to find x (which will have a different Range, if it has one (#2649)).- let xms = filter ((\ y -> not (null $ getRange y) && y == C.QName x) . fst) xms0- reportSLn "scope.class.error" 30 $ "filtered candidates = " ++ prettyShow xms-- -- If we found a copy of x with non-empty range, great!- ifJust (listToMaybe xms) (\ (x', m) -> return (getRange x', m)) $ {-else-} do-- -- If that failed, we pick the first m from ms which has a nameBindingSite.- let rms = concat $ ms <&> \ m -> map (,m) $- filter (noRange /=) $ map nameBindingSite $ reverse $ mnameToList m- -- Andreas, 2017-07-25, issue #2649- -- Take the first nameBindingSite we can get hold of.- reportSLn "scope.class.error" 30 $ "rangeful clashing modules = " ++ prettyShow rms-- -- If even this fails, we pick the first m and give no range.- return $ fromMaybe (noRange, m0) $ listToMaybe rms-- fsep $- pwords "Duplicate definition of module" ++ [prettyTCM x <> "."] ++- pwords "Previous definition of" ++ [help m] ++ pwords "module" ++ [prettyTCM x] ++- pwords "at" ++ [prettyTCM r]- where- help :: MonadPretty m => ModuleName -> m Doc- help m = caseMaybeM (isDatatypeModule m) empty $ \case- IsDataModule -> "(datatype)"- IsRecordModule -> "(record)"+ ShadowedModule x ms -> join $ fst <$> prettyShadowedModule x ms ModuleArityMismatch m EmptyTel args -> fsep $ pwords "The module" ++ [prettyTCM m] ++@@ -478,7 +510,7 @@ , pwords "is not allowed" , [ parens "to activate, add declaration `pattern` to record definition" ] ]- where r = nameBindingSite $ qnameName q+ where r = nameBindingSite q SplitOnAbstract d -> "Cannot split on abstract data type" <+> prettyTCM d@@ -496,11 +528,10 @@ ] where kindOfData :: DataOrRecordE -> String- kindOfData IsData = "datatype"- kindOfData (IsRecord InductionAndEta {recordInduction=Nothing}) = "record type"- kindOfData (IsRecord InductionAndEta {recordInduction=(Just Inductive)}) = "inductive record type"- kindOfData (IsRecord InductionAndEta {recordInduction=(Just CoInductive)}) = "coinductive record type"-+ kindOfData IsData = "datatype"+ kindOfData (IsRecord InductionAndEta {recordInduction=Nothing}) = "record type"+ kindOfData (IsRecord InductionAndEta {recordInduction=Just Inductive}) = "inductive record type"+ kindOfData (IsRecord InductionAndEta {recordInduction=Just CoInductive}) = "coinductive record type" DefinitionIsIrrelevant x -> fsep $ "Identifier" : prettyTCM x : pwords "is declared irrelevant, so it cannot be used here"@@ -530,80 +561,40 @@ InvalidModalTelescopeUse t used avail def -> fsep [ "Telescope variable" <+> prettyTCM t- , "is indirectly being used in the" <+> text (verbalize (getModality used)) <+> "modality"- , "but only available in the" <+> text (verbalize (getModality avail)) <+> "modality"+ , "is indirectly being used in the" <+> text (verbalizePositional used) <+> "modality"+ , "but only available in the" <+> text (verbalizePositional avail) <+> "modality" , "when inserting into the telescope of definition" , pretty (defName def) <+> ":" <+> prettyTCM (defType def) ]+ where+ -- Only the cohesion and polarity components are relevant here.+ verbalizePositional m =+ case [ verbalize c | c /= defaultCohesion ] ++ [ verbalize p | p /= defaultPolarity ] of+ [] -> "default"+ ws -> intercalate ", " ws+ where+ c = getCohesion m+ p = getModalPolarity m VariableIsOfUnusablePolarity x c -> fsep $- ["Variable", prettyTCM (nameConcrete x), "is bound with", text (verbalize p)] ++ pwords "polarity, so it cannot be used here at" +++ ["Variable", prettyTCM (nameConcrete x), "is bound with", text (verbalize p)] ++ pwords "polarity, so it cannot be used here at" ++ [text (verbalize (Indefinite l)), "position"] where PolarityModality _ p l = c - UnequalTerms cmp s t a -> case (s,t) of- (Sort s1 , Sort s2 )- | CmpEq <- cmp -> prettyTCM $ UnequalSorts s1 s2- | CmpLeq <- cmp -> prettyTCM $ NotLeqSort s1 s2- (Sort MetaS{} , t ) -> prettyTCM $ ShouldBeASort $ El __IMPOSSIBLE__ t- (s , Sort MetaS{} ) -> prettyTCM $ ShouldBeASort $ El __IMPOSSIBLE__ s- (Sort DefS{} , t ) -> prettyTCM $ ShouldBeASort $ El __IMPOSSIBLE__ t- (s , Sort DefS{} ) -> prettyTCM $ ShouldBeASort $ El __IMPOSSIBLE__ s- (_ , _ ) -> do- (d1, d2, d) <- prettyInEqual s t- fsep $ concat $- [ [return d1, notCmp cmp, return d2]- , case a of- AsTermsOf t -> pwords "of type" ++ [prettyTCM t]- AsSizes -> pwords "of type" ++ [prettyTCM =<< sizeType]- AsTypes -> []- , [return d]- ]-- UnequalLevel cmp s t -> fsep $- [prettyTCM s, notCmp cmp, prettyTCM t]-- UnequalRelevance cmp a b -> fsep $- [prettyTCM a, notCmp cmp, prettyTCM b] ++- pwords "because one is a relevant function type and the other is an irrelevant function type"-- UnequalQuantity cmp a b -> fsep $- [prettyTCM a, notCmp cmp, prettyTCM b] ++- pwords "because one is a non-erased function type and the other is an erased function type"-- UnequalCohesion cmp a b -> fsep $- [prettyTCM a, notCmp cmp, prettyTCM b] ++- 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.-- UnequalPolarity cmp a b -> fsep $- [prettyTCM a, notCmp cmp, prettyTCM b] ++- pwords "because they do not have the same polarity annotations"-- 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"-- UnequalSorts s1 s2 -> fsep $- [prettyTCM s1, "!=", prettyTCM s2]+ ConversionError_ err -> prettyTCM err NotLeqSort s1 s2 -> fsep $ [prettyTCM s1] ++ pwords "is not less or equal than" ++ [prettyTCM s2] TooManyFields r missing xs -> prettyTooManyFields r missing xs - DuplicateConstructors xs -> fsep $ concat+ DuplicateConstructors xs -> (fsep . concat) [ [ "Duplicate" ] , [ pluralS xs "constructor" ]- , punctuate comma $ fmap pretty xs- , pwords "in datatype"+ , pwords "in datatype:" ]+ <?> fsep (fmap pretty xs) DuplicateFields xs -> prettyDuplicateFields xs @@ -708,6 +699,10 @@ pwords "No binding for builtin " ++ [pretty x <> comma] ++ pwords ("use {-# BUILTIN " ++ getBuiltinId builtinNat ++ " name #-} to bind builtin natural " ++ "numbers to the type 'name'")+ | x `elem` [builtinRefl] -> fsep $+ pwords "No binding for builtin " ++ [pretty x <> comma] +++ pwords ("use {-# BUILTIN " ++ getBuiltinId builtinEquality ++ " name #-} to bind the builtin equality " +++ "type to 'name'") | otherwise -> fsep $ pwords "No binding for builtin thing" ++ [pretty x <> comma] ++ pwords ("use {-# BUILTIN " ++ getBuiltinId x ++ " name #-} to bind it to 'name'")@@ -733,15 +728,18 @@ things i = [verbalize $ getHiding i, "at modality " ++ verbalize (getModality i)] + TrustedBuiltin x -> fsep $+ pwords "The trusted builtin" ++ [text (show x)] +++ pwords "is only allowed in certain \"builtin\" modules"++ TrustedPrimitive x -> fsep $+ pwords "The trusted primitive" ++ [prettyTCM x] +++ pwords "is only allowed in certain \"builtin\" modules"+ BuiltinInParameterisedModule x -> fwords $ "The BUILTIN pragma cannot appear inside a bound context " ++ "(for instance, in a parameterised module or as a local declaration)" - IllegalDeclarationInDataDefinition ds -> vcat- [ "Illegal declaration in data type definition"- , nest 2 $ vcat $ fmap pretty ds- ]- IllegalLetInTelescope tb -> fsep $ -- pwords "The binding" ++ pretty tb :@@ -762,18 +760,22 @@ , text "must not be located in the directory" <+> text (takeDirectory (lib ^. libFile)) ] - SolvedButOpenHoles -> fsep $- pwords "Module cannot be imported since it has open interaction points" ++- pwords "(consider adding {-# OPTIONS --allow-unsolved-metas #-} to this module)"+ SolvedButOpenHoles x -> do+ vcat $+ [ fsep $ prettyTCM x :+ pwords "cannot be imported since it has open interaction points"+ , "(consider adding {-# OPTIONS --allow-unsolved-metas #-} to that module)"+ ] - CyclicModuleDependency (List2 m0 m1 ms) ->+ CyclicModuleDependency ms0 -> do+ List2 m0 m1 ms <- for ms0 <$> topLevelModuleNameWithSourceFileCompleter fsep (pwords "cyclic module dependency:")- $$ nest 2 (vcat $ (pretty m0 :) $ map (("importing" <+>) . pretty) (m1 : ms))+ $$ nest 2 (vcat $ (prettyTCM m0 :) $ map (("importing" <+>) . prettyTCM) (m1 : ms)) - FileNotFound x files ->+ FileNotFound x dirs -> fsep ( pwords "Failed to find source of module" ++ [pretty x] ++ pwords "in any of the following locations:"- ) $$ nest 2 (vcat $ map (text . filePath) files)+ ) $$ prettyPossibleFilesForModule x dirs OverlappingProjects f m1 m2 | canon d1 == canon d2 -> fsep $ concat@@ -806,7 +808,9 @@ ] AmbiguousOverloadedProjection ds reason -> do- let nameRaw = pretty $ A.nameConcrete $ A.qnameName $ List1.head ds+ let+ x = headAmbQ ds+ nameRaw = pretty $ A.nameConcrete $ A.qnameName x vcat [ fsep [ text "Cannot resolve overloaded projection"@@ -815,9 +819,18 @@ , pure reason ] , nest 2 $ text "candidates in scope:"- , vcat $ for ds $ \ d -> do+ , vcat $ for (getAmbiguous ds) $ \ d -> do t <- typeOfConst d text "-" <+> nest 2 (nameRaw <+> text ":" <+> prettyTCM t)+ -- , vcat . concat $ for (unAmbQ ds) \ d ->+ -- [ text "-" <+> nest 2 (nameRaw <+> text ":" <+> (prettyTCM =<< typeOfConst (fromAmbQName d))) ]+ -- +++ -- case d of+ -- AmbQName{} -> []+ -- AmbAbstractName x -> [ nest 2 $ prettyTCM x ]+ , case whyInScopeDataFromAmbiguousQName (qnameToConcrete x) ds of+ Nothing -> empty+ Just why -> explainWhyInScope why ] AmbiguousConstructor c disambs -> vcat@@ -849,23 +862,30 @@ else empty ] - ModuleNameUnexpected given expected- | canon dGiven == canon dExpected -> fsep $ concat+ ModuleNameUnexpected given expected -> do+ let+ canon = CaseInsens.mk . P.render+ dExpected = P.pretty expected+ dGiven <- prettyTCM given+ if| canon dGiven == canon dExpected -> fsep $ concat [ pwords "Case mismatch between the actual module name" , [ pure dGiven ] , pwords "and the expected module name" , [ pure dExpected ] ]- | otherwise -> fsep $ concat- [ pwords "The name of the top level module does not match the file name. The module"- , [ pure dGiven ]+ | otherwise -> fsep $ concat+ [ pwords "The name of the top level module does not match the file name."+ , if moduleNameInferred (fileModuleName given) then+ pwords "The unnamed module" +++ [ do+ path <- srcFilePath $ fileModuleSourceFile given+ let r = rangeFromAbsolutePath path+ parens ("at" <> prettyTCM r)+ ]+ else pwords "The module" ++ [ pure dGiven ] , pwords "should probably be named" , [ pure dExpected ] ]- where- canon = CaseInsens.mk . P.render- dGiven = P.pretty given- dExpected = P.pretty expected ModuleNameHashCollision raw raw' -> fwords $ case raw' of Nothing ->@@ -876,7 +896,7 @@ " and " ++ prettyShow raw' ++ " (you may want to consider " ++ "renaming one of these modules)" - ModuleNameDoesntMatchFileName given files -> vcat+ ModuleNameDoesntMatchFileName given dirs -> vcat [ fsep $ concat [ [ "The" ] , [ "inferred" | moduleNameInferred given ]@@ -886,7 +906,7 @@ , pwords "does not match the file name." , pwords "A such named module should be defined in one of the following files:" ]- , nest 2 (vcat $ map (text . filePath) files)+ , prettyPossibleFilesForModule given dirs , if moduleNameInferred given then fsep $ pwords "(Hint: no module header was found in this file; adding one might fix this error.)" else empty@@ -915,7 +935,30 @@ -- using the warning version to avoid code duplication prettyWarning $ NotInScopeW x - NoSuchModule x -> fsep $ pwords "No module" ++ [pretty x] ++ pwords "in scope"+ NoSuchModule x -> do+ -- Andreas, 2025-10-18, issue #8144+ -- In the situation+ -- @+ -- mutual+ -- record R : Set where ...+ -- open R+ -- @+ -- which desugars to+ -- @+ -- record R : Set+ -- open R+ -- record R where ...+ -- @+ -- we want to give some hint that while record R is defined,+ -- its module R is not defined yet.+ hint <- do+ runExceptT (tryResolveName (someKindsOfNames [DataName, RecName]) Nothing x) >>= \case+ Right (DefinedName _ (AbsName y DataName _ _) _) -> do+ return "---but a data type of that name is in scope whose data module is either not defined yet or hidden"+ Right (DefinedName _ (AbsName y RecName _ _) _) -> do+ return "---but a record type of that name is in scope whose record module is either not defined yet or hidden (note that records defined in a `mutual' block cannot be opened in the same block)"+ _ -> return ""+ fsep $ pwords "No module" ++ [pretty x] ++ pwords ("in scope" ++ hint) AmbiguousName x reason -> vcat [ fsep $ pwords "Ambiguous name" ++ [pretty x <> "."] ++@@ -931,7 +974,7 @@ , fwords "(hint: Use C-c C-w (in Emacs) if you want to know why)" ] where- help :: MonadPretty m => ModuleName -> m Doc+ help :: ModuleName -> m Doc help m = do anno <- caseMaybeM (isDatatypeModule m) (return empty) $ \case IsDataModule -> return $ "(datatype module)"@@ -942,24 +985,40 @@ hsep [ "Ambiguity: the field", prettyTCM field, "appears in the following modules:" ] : map prettyTCM (List2.toList modules) - ClashingDefinition x y suggestion -> fsep $- pwords "Multiple definitions of" ++ [pretty x <> "."] ++- pwords "Previous definition at"- ++ [prettyTCM $ nameBindingSite $ qnameName y] ++- caseMaybe suggestion [] (\d ->- [ "Perhaps you meant to write "- $$ nest 2 ("'" <> pretty (notSoNiceDeclarations d) <> "'")- $$ ("at" <+> (pretty . envRange =<< askTC)) <> "?"- $$ "In data definitions separate from data declaration, the ':' and type must be omitted."- ])+ ClashingDefinition x y suggestion -> vcat+ [ fsep $ pwords "Multiple definitions of" ++ [ pretty x <> "." ] ++ clashingWith y+ , fromMaybe empty $ fmap hint suggestion+ ]+ where+ clashingWith = \case+ ClashingAbstractName y -> do+ pwords "Previous definition" ++ [explainWhyInScope $ whyInScopeDataFromAbstractName x y]+ ClashingQName y ->+ pwords "Previous definition at" ++ [prettyTCM $ nameBindingSite y]+ hint d = do+ let dataOrRecord = case d of+ NiceDataDef{} -> "data"+ NiceRecDef{} -> "record"+ _ -> __IMPOSSIBLE__+ vcat+ [ "Perhaps you meant to write"+ , nest 2 ("'" <> pretty (notSoNiceDeclarations d) <> "'")+ , ("at" <+> (pretty . view eRange =<< askTC)) <> "?"+ , fsep $ concat+ [ [ "In", dataOrRecord ]+ , pwords "definitions separate from their"+ , [ dataOrRecord ]+ , pwords "declaration, the ':' and type must be omitted"+ ] ] ClashingModule m1 m2 -> fsep $ pwords "The modules" ++ [prettyTCM m1, "and", prettyTCM m2] ++ pwords "clash." - DuplicateImports m xs -> fsep $- pwords "Ambiguous imports from module" ++ [pretty m] ++ pwords "for" ++- punctuate comma (fmap pretty xs)+ DuplicateImports m xs ->+ fsep (pwords "Ambiguous imports from module" ++ [pretty m] ++ pwords "for identifiers:")+ <?> fsep (punctuate ";" $ fmap pretty xs)+ -- Andreas, 2026-02-14 punctuate with semicolon since xs may contain "module M" or even "," DefinitionInDifferentModule _x -> fsep $ pwords "Definition in different module than its type signature"@@ -981,13 +1040,13 @@ RepeatedVariablesInPattern xs -> fsep $ pwords "Repeated variables in pattern:" ++ map pretty (List1.toList xs) - RepeatedNamesInImportDirective yss -> fsep- [ fsep $ concat+ RepeatedNamesInImportDirective yss ->+ (fsep . concat) [ [ "Repeated" , pluralS yss "name" ] , pwords "in import directive:" ]- , fsep $ punctuate comma $ fmap (prettyTCM . List2.head) yss- ]+ <?> fsep (punctuate ";" $ fmap (prettyTCM . List2.head) yss)+ -- Andreas, 2026-02-14 punctuate with semicolon since list may contain "module M" or even "," DeclarationsAfterTopLevelModule -> fwords $ "No declarations allowed after top-level module." @@ -1014,16 +1073,16 @@ pwords "Could mean any one of:" ) $$ nest 2 (vcat $ fmap pretty' es') where- pretty_es :: MonadPretty m => m Doc+ pretty_es :: m Doc pretty_es = pretty $ C.RawApp noRange es - pretty' :: MonadPretty m => C.Expr -> m Doc+ pretty' :: C.Expr -> m Doc pretty' e = do p1 <- pretty_es p2 <- pretty e if render p1 == render p2 then unambiguous e else return p2 - unambiguous :: MonadPretty m => C.Expr -> m Doc+ unambiguous :: C.Expr -> m Doc unambiguous e@(C.OpApp r op _ xs) | all (isOrdinary . namedArg) xs = pretty $@@ -1064,8 +1123,8 @@ ] where (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+ prDef (x, (A.PatternSynDefn xs p)) = prettyA (A.PatternSynDef x (map (fmap BindName) xs) p) <?> ("at" <+> pretty r)+ where r = nameBindingSite x IllegalInstanceVariableInPatternSynonym x -> fsep $ concat [ pwords "Variable is bound as instance in pattern synonym,"@@ -1081,7 +1140,7 @@ , [ pretty kind ] , pwords "defined at:" ]- , pretty $ nameBindingSite $ qnameName $ anameName y+ , pretty $ nameBindingSite y ] UnusedVariableInPatternSynonym x -> fsep $@@ -1113,7 +1172,7 @@ ++ map (nest 2 . pretty' d) (List2.toList ps) where- pretty' :: MonadPretty m => Doc -> C.Pattern -> m Doc+ pretty' :: Doc -> C.Pattern -> m Doc pretty' d1 p' = do d2 <- pretty p' if render d1 == render d2 then pretty $ unambiguousP p' else return d2@@ -1129,14 +1188,14 @@ unambiguousP (C.OpAppP r op _ xs) = foldl C.AppP (C.IdentP True op) xs unambiguousP e = e - OperatorInformation sects err ->+ OperatorInformation sects (OpScope _ globals locals) err -> prettyTCM err $+$ fsep (pwords "Operators used in the grammar:") $$ nest 2 (if null sects then "None" else- vcat (map text $+ vcat (map (text . rtrim) $ lines $ Boxes.render $ (\(col1, col2, col3) ->@@ -1145,8 +1204,25 @@ unzip3 $ map prettySect $ sortBy (compare `on` prettyShow . notaName . sectNotation) $- filter (not . closedWithoutHoles) sects))+ properSects))+ $$+ if null relevantSimpleNames then empty else do+ fsep (pwords "Identifiers used in the grammar that overlap with the operators:")+ $$+ nest 2 (fsep (map text relevantSimpleNames))+ where+ -- Andreas, 2025-12-17, issue #3677+ -- Prepare a list of names in scope that might clash with the operators.+ -- For now, disregard qualified names.+ relevantSimpleNames = List.sort $ filter (hasElem operatorParts) simpleNames+ simpleNames =+ mapMaybe (C.isSimpleName <=< C.isUnqualified) (Map.keys globals) +++ mapMaybe C.isSimpleName (AssocList.keys locals)+ operatorParts = concatMap (stringParts . notation . sectNotation) properSects++ properSects = filter (not . closedWithoutHoles) sects+ trimLeft = dropWhile isAHole trimRight = dropWhileEnd isAHole @@ -1234,12 +1310,6 @@ ) $$ nest 2 (vcat $ map pretty ps) -} -{- UNUSED- IncompletePatternMatching v args -> fsep $- pwords "Incomplete pattern matching for" ++ [prettyTCM v <> "."] ++- pwords "No match for" ++ map prettyTCM args--}- SplitError e -> prettyTCM e ImpossibleConstructor c neg -> fsep $@@ -1250,12 +1320,6 @@ DatatypeIndexPolarity -> fsep $ pwords "Cannot annotate datatype indices with polarity other than @mixed" - RecursiveRecordNeedsInductivity q -> fsep $ concat- [ pwords "Recursive record"- , [ prettyTCM q ]- , pwords "needs to be declared as either inductive or coinductive"- ]- InstanceNoCandidate t errs -> vcat $ [ fsep $ pwords "No instance of type" ++ [prettyTCM t] ++ pwords "was found in scope." , vcat $ map prCand errs ]@@ -1279,6 +1343,12 @@ nameCxt (x : xs) = ExtendTel (defaultDom (El __DUMMY_SORT__ $ I.var 0)) $ NoAbs (P.prettyShow x) $ nameCxt xs + MissingBindingsForTelescopeVariables xs -> vcat+ [ fsep [ "Missing", pluralS xs "binding", "for", "telescope", pluralS xs "variable" <> colon ]+ <?> (fsep (fmap (text . Text.unpack) xs))+ , "All variables in the clause telescope must be bound in the left-hand side."+ ]+ NeedOptionAllowExec -> fsep $ pwords "Option --allow-exec needed to call external commands from macros" @@ -1286,17 +1356,21 @@ pwords "Option --copatterns needed to enable destructor patterns" NeedOptionCubical cubical reason -> fsep $ concat- [ [ "Option" ], opt, [ "required" ]+ [ [ "Option" ], [ opt ], [ "required" ] , pwords reason ] where opt = case cubical of- CFull -> [ "--cubical" ]- CErased -> pwords $ "--cubical or --erased-cubical"+ CFull -> "--cubical[=full]"+ CErased -> "--cubical[={full,erased}]"+ CWithoutGlue -> "--cubical[={full,erased,no-glue}]" NeedOptionPatternMatching -> fsep $ pwords "Pattern matching is disabled (use option --pattern-matching to enable it)" + NeedOptionIrrelevance -> fsep $+ pwords "Irrelevance modality is disabled (use options --irrelevance and --no-irrelevance to enable/disable irrelevance)"+ NeedOptionProp -> fsep $ pwords "Universe Prop is disabled (use options --prop and --no-prop to enable/disable Prop)" @@ -1312,6 +1386,9 @@ NeedOptionUniversePolymorphism -> fsep $ pwords "Universe polymorphism is disabled (use option --universe-polymorphism to allow level arguments to sorts)" + CannotGeneralizeEtaExpandable x metaType ->+ ("Cannot generalize over" <+> prettyTCM x <+> "of eta-expandable type") <?> prettyTCM metaType+ GeneralizeNotSupportedHere x -> fsep $ pwords $ "Generalizable variable " ++ prettyShow x ++ " is not supported here" @@ -1327,7 +1404,7 @@ , vcat $ fmap f xs ] where- f (x, fs) = (pretty x <> ": ") <+> fsep (fmap pretty fs)+ f (x, fs) = (pretty x <> ": ") <+> fsep (fmap (pretty . PrintRange) fs) MultiplePolarityPragmas xs -> fsep $ pwords "Multiple polarity pragmas for" ++ map pretty (List1.toList xs)@@ -1340,8 +1417,8 @@ pwords "missing" CannotQuoteHidden -> pwords "implicit"- CannotQuoteAmbiguous (List2 x y zs) ->- pwords "ambiguous:" ++ [ pretty $ AmbQ $ x :| y : zs ]+ CannotQuoteAmbiguous xs ->+ pwords "ambiguous:" ++ [ pretty xs ] CannotQuoteExpression e -> case e of -- These expression can be quoted: A.Def' _ NoSuffix -> __IMPOSSIBLE__@@ -1432,36 +1509,49 @@ ReferencesFutureVariables term (disallowed :| _) lock leftmost | disallowed == leftmost- -> fsep $ pwords "The lock variable"- ++ pure (prettyTCM =<< nameOfBV disallowed)- ++ pwords "can not appear simultaneously in the \"later\" term"- ++ pure (prettyTCM term)- ++ pwords "and in the lock term"- ++ pure (prettyTCM lock <> ".")+ -> fsep $ concat+ [ pwords "The lock variable"+ , [ prettyTCM =<< nameOfBV disallowed ]+ , pwords "can not appear simultaneously in the \"later\" term"+ , [ prettyTCM term ]+ , pwords "and in the lock term"+ , [ prettyTCM lock ]+ ] ReferencesFutureVariables term (disallowed :| rest) lock leftmost -> do- explain <- (/=) <$> prettyTCM lock <*> (prettyTCM =<< nameOfBV leftmost) let name = prettyTCM =<< nameOfBV leftmost+ lck = prettyTCM lock mod = case getLock lock of IsLock LockOLock -> "@lock" IsLock LockOTick -> "@tick"- _ -> __IMPOSSIBLE__+ IsNotLock -> __IMPOSSIBLE__+ explain <- liftA2 (/=) lck name vcat $ concat- [ pure . fsep $ concat- [ pwords "The variable", pure (prettyTCM =<< nameOfBV disallowed), pwords "can not be mentioned here,"- , pwords "since it was not introduced before the variable", pure (name <> ".")+ [ [ fsep $ concat+ [ pwords "The variable"+ , [ prettyTCM =<< nameOfBV disallowed ]+ , pwords "can not be mentioned here,"+ , pwords "since it was not introduced before the variable"+ , [ name <> "." ]+ ] ]- , [ fsep ( pwords "Variables introduced after"- ++ pure name- ++ pwords "can not be used, since that is the leftmost" ++ pure mod ++ pwords "variable in the locking term"- ++ pure (prettyTCM lock <> "."))+ , [ fsep $ concat+ [ pwords "Variables introduced after"+ , [ name ]+ , pwords "can not be used, since that is the leftmost"+ , [ mod ]+ , pwords "variable in the locking term"+ , [ lck <> "." ]+ ] | explain ]- , [ fsep ( pwords "The following"- ++ P.singPlural rest (pwords "variable is") (pwords "variables are")- ++ pwords "not allowed here, either:"- ++ punctuate comma (map (prettyTCM <=< nameOfBV) rest))+ , [ (fsep . concat)+ [ pwords "The following"+ , P.singPlural rest (pwords "variable is") (pwords "variables are")+ , pwords "not allowed here, either:"+ ]+ <?> fsep (map (prettyTCM <=< nameOfBV) rest) | not (null rest) ] ]@@ -1510,13 +1600,18 @@ NamedWhereModuleInRefinedContext args names -> do let pr x v = text (x ++ " =") <+> prettyTCM v vcat- [ fsep (pwords $ "Named where-modules are not allowed when module parameters have been refined by pattern matching. " ++- "See https://github.com/agda/agda/issues/2897.")+ [ fsep $ pwords $ "Named where-modules are not allowed when module parameters have been refined by pattern matching."+ , "(See" <+> (githubIssue 2897 <> ".)") , text $ "In this case the module parameter" ++ (if not (null args) then "s have" else " has") ++ " been refined to"- , nest 2 $ vcat (zipWith pr names args) ]+ , nest 2 $ vcat $ zipWith pr names args+ ] + NamedWhereModuleUnderWith -> fsep $+ pwords "Named `where` modules are disallowed under `with` or `rewrite` since Agda 2.9.0"+ ++ [ parens $ "see" <+> githubIssue 8698 ]+ CannotGenerateHCompClause ty -> fsep $ concat [ pwords "Cannot generate hcomp clause at type" , [ prettyTCM ty ]@@ -1530,6 +1625,10 @@ , "and thus can not be transported" ] + CannotGenerateTransportLocalRewrite f -> vcat+ [ "Could not generate a transport function for" <+> prettyTCM f+ , "because there is a local rewrite rule in its telescope"]+ CubicalNotErasure q -> prettySigCubicalNotErasure q CubicalPrimitiveNotFullyApplied c ->@@ -1565,6 +1664,8 @@ ComatchingDisabledForRecord recName -> "Copattern matching is disabled for record" <+> prettyTCM recName + IlltypedRewriteRule d -> return d+ IncorrectTypeForRewriteRelation v reason -> case reason of ShouldAcceptAtLeastTwoArguments -> sep [ prettyTCM v <+> " does not have the right type for a rewriting relation"@@ -1583,8 +1684,9 @@ UnexpectedParameter par -> do text "Unexpected parameter" <+> prettyA par - NoParameterOfName x -> do+ NoParameterOfName x xs -> fsep $ text ("No parameter of name " ++ x)+ : [ parens $ fsep $ text "possible parameters:" : map text xs | not (null xs) ] UnexpectedModalityAnnotationInParameter par -> do text "Unexpected modality/relevance annotation in" <+> prettyA par@@ -1611,6 +1713,11 @@ UnexpectedTypeSignatureForParameter xs -> do fsep (pwords "Unexpected type signature for" ++ [ pluralS xs "parameter" ]) <+> sep (fmap prettyA xs) + UnguardedEtaRecord name -> vcat+ [ fsep $ pwords "Recursive occurrence of this record in its definition is unguarded, so eta-equality for this record might lead to non-termination in the type checker."+ , fsep $ pwords "To suppress this error, use pragma" ++ [ "{-# ETA_EQUALITY #-}" ]+ ]+ UnusableAtModality why mod t -> do compatible <- cubicalCompatibleOption cubical <- isJust <$> cubicalOption@@ -1693,13 +1800,13 @@ | n > 0 && not (null args) = parens | otherwise = id - prettyArg :: MonadPretty m => Arg (I.Pattern' a) -> m Doc+ prettyArg :: Arg (I.Pattern' a) -> m Doc prettyArg (Arg info x) = case getHiding info of Hidden -> braces $ prettyPat 0 x Instance{} -> dbraces $ prettyPat 0 x NotHidden -> prettyPat 1 x - prettyPat :: MonadPretty m => Integer -> (I.Pattern' a) -> m Doc+ prettyPat :: Integer -> (I.Pattern' a) -> m Doc prettyPat _ (I.VarP _ _) = "_" prettyPat _ (I.DotP _ _) = "._" prettyPat n (I.ConP c _ args) =@@ -1712,7 +1819,63 @@ prettyPat _ (I.ProjP _ p) = "." <> prettyTCM p prettyPat _ (I.IApplyP _ _ _ _) = "_" +{-# SPECIALIZE prettyPossibleFilesForModule :: TopLevelModuleName -> List1 AbsolutePath -> TCM Doc #-}+prettyPossibleFilesForModule :: MonadPretty m => TopLevelModuleName -> List1 AbsolutePath -> m Doc+prettyPossibleFilesForModule m dirs = vcat+ [ nest 2 $ vcat $ map text $+ [ filePath dir </> moduleNameToFileName m ".AGDA"+ | dir <- List1.toList dirs+ ]+ , "where .AGDA denotes a legal extension for an Agda file"+ , parens $ fsep $ pwords "i.e., one of" ++ map text agdaFileExtensions+ ] +-- | Pretty-print error 'ShadowedModule' and return the range of the shadowed module.+{-# SPECIALIZE prettyShadowedModule :: C.Name -> List1 A.ModuleName -> TCM (TCM Doc, Range) #-}+prettyShadowedModule :: MonadPretty m => C.Name -> List1 A.ModuleName -> m (m Doc, Range)+prettyShadowedModule x ms@(m0 :| _) = do+ -- Clash! Concrete module name x already points to the abstract names ms.+ (r, m) <- do+ -- Andreas, 2017-07-28, issue #719.+ -- First, we try to find whether one of the abstract names @ms@ points back to @x@+ scope <- getScope+ -- Get all pairs (y,m) such that y points to some m ∈ ms.+ let xms0 = concat $ ms <&> \ m -> map (,m) $ inverseScopeLookupModule m scope+ reportSLn "scope.clash.error" 30 $ "candidates = " ++ prettyShow xms0++ -- Try to find x (which will have a different Range, if it has one (#2649)).+ let xms = filter ((\ y -> not (null $ getRange y) && y == C.QName x) . fst) xms0+ reportSLn "scope.class.error" 30 $ "filtered candidates = " ++ prettyShow xms++ -- If we found a copy of x with non-empty range, great!+ ifJust (listToMaybe xms) (\ (x', m) -> return (getRange x', m)) $ {-else-} do++ -- If that failed, we pick the first m from ms which has a nameBindingSite.+ let rms = concat $ ms <&> \ m -> map (,m) $+ filter (noRange /=) $ map nameBindingSite $ reverse $ mnameToList m+ -- Andreas, 2017-07-25, issue #2649+ -- Take the first nameBindingSite we can get hold of.+ reportSLn "scope.class.error" 30 $ "rangeful clashing modules = " ++ prettyShow rms++ -- If even this fails, we pick the first m and give no range.+ return $ fromMaybe (noRange, m0) $ listToMaybe rms++ return . (,r) . fsep $+ pwords "Duplicate definition of module" ++ [prettyTCM x <> "."] +++ pwords "Previous definition of" ++ [help m] ++ pwords "module" ++ [prettyTCM x] +++ pwords "at" ++ [prettyTCM r]+ where+ help :: MonadPretty m => ModuleName -> m Doc+ help m = caseMaybeM (isDatatypeModule m) empty $ \case+ IsDataModule -> "(datatype)"+ IsRecordModule -> "(record)"++instance PrettyTCM TopLevelModuleNameWithSourceFile where+ prettyTCM (TopLevelModuleNameWithSourceFile x file) = do+ path <- srcFilePath file+ let x' = setRange (rangeFromAbsolutePath path) x+ pretty (PrintRange x')+ instance PrettyTCM ExecError where prettyTCM = \case @@ -1859,11 +2022,15 @@ pwords ("Use " ++ def ++ " instead of " ++ con ++ " for non-constructor") ++ [prettyTCM x] + EscapingVariable v -> enterClosure v \ v ->+ hcat ["Local variable '", prettyTCM (var 0), "' escaping in result of extendContext:"]+ <?> prettyTCM v+ MissingDeclaration x -> fsep $ pwords "Missing declaration for" ++ [ prettyTCM x ] - MissingDefinition x -> fsep $- pwords "Missing definition for" ++ [ prettyTCM x ]+ MissingDefinition xs -> fsep $+ pwords "Missing definition for" ++ punctuate comma (fmap prettyTCM xs) NakedUnquote -> fwords "`unquote' must be applied to a term" @@ -1897,61 +2064,7 @@ notCmp :: MonadPretty m => Comparison -> m Doc notCmp cmp = "!" <> prettyTCM cmp --- | Print two terms that are supposedly unequal.--- If they print to the same identifier, add some explanation--- why they are different nevertheless.-prettyInEqual :: MonadPretty m => Term -> Term -> m (Doc, Doc, Doc)-prettyInEqual t1 t2 = do- d1 <- prettyTCM t1- d2 <- prettyTCM t2- (d1, d2,) <$> do- -- if printed differently, no extra explanation needed- if P.render d1 /= P.render d2 then empty else do- (v1, v2) <- instantiate (t1, t2)- case (v1, v2) of- (I.Var i1 _, I.Var i2 _)- | i1 == i2 -> generic -- possible, see issue 1826- | otherwise -> varVar i1 i2- (I.Def{}, I.Con{}) -> __IMPOSSIBLE__ -- ambiguous identifiers- (I.Con{}, I.Def{}) -> __IMPOSSIBLE__- (I.Var{}, I.Def{}) -> varDef- (I.Def{}, I.Var{}) -> varDef- (I.Var{}, I.Con{}) -> varCon- (I.Con{}, I.Var{}) -> varCon- (I.Def x _, I.Def y _)- | isExtendedLambdaName x, isExtendedLambdaName y -> extLamExtLam x y- _ -> empty- where- varDef, varCon, generic :: MonadPretty m => m Doc- varDef = parens $ fwords "because one is a variable and one a defined identifier"- varCon = parens $ fwords "because one is a variable and one a constructor"- generic = parens $ fwords $ "although these terms are looking the same, " ++- "they contain different but identically rendered identifiers somewhere"- varVar :: MonadPretty m => Int -> Int -> m Doc- varVar i j = parens $ fwords $- "because one has de Bruijn index " ++ show i- ++ " and the other " ++ show j - extLamExtLam :: MonadPretty m => QName -> QName -> m Doc- extLamExtLam a b = vcat- [ fwords "Because they are distinct extended lambdas: one is defined at"- , " " <+> pretty (nameBindingSite (qnameName a))- , fwords "and the other at"- , " " <+> (pretty (nameBindingSite (qnameName b)) <> ",")- , fwords "so they have different internal representations."- ]--class PrettyUnequal a where- prettyUnequal :: MonadPretty m => a -> m Doc -> a -> m Doc--instance PrettyUnequal Term where- prettyUnequal t1 ncmp t2 = do- (d1, d2, d) <- prettyInEqual t1 t2- fsep $ return d1 : ncmp : return d2 : return d : []--instance PrettyUnequal I.Type where- prettyUnequal t1 ncmp t2 = prettyUnequal (unEl t1) ncmp (unEl t2)- instance PrettyTCM SplitError where prettyTCM :: forall m. MonadPretty m => SplitError -> m Doc prettyTCM err = case err of@@ -1965,12 +2078,19 @@ pwords "Cannot branch on erased argument of datatype" ++ [prettyTCM t] ++ case reason of- NoErasedMatches ->- pwords "because the option --erased-matches is not active"- NoK ->- pwords "because the K rule is turned off"+ ErasedMatchesDisabledEmpty ->+ explanation "empty"+ ErasedMatchesDisabledNonDependent ->+ explanation "non-dependent"+ ErasedMatchesDisabledDependent ->+ explanation "unrestricted" SeveralConstructors -> []+ where+ explanation arg =+ pwords "because the option" +++ pwords ("--erased-matches=" ++ arg) +++ pwords "is not active" CoinductiveDatatype t -> enterClosure t $ \ t -> fsep $ pwords "Cannot pattern match on the coinductive type" ++ [prettyTCM t]@@ -2004,9 +2124,6 @@ prEq cIx gIx = addContext tel $ nest 2 $ hsep [ pr cIx , "≟" , pr gIx ] pr arg = prettyRelevance arg . prettyHiding arg id <$> prettyTCM (unArg arg) - CosplitCatchall -> fsep $- pwords "Cannot split into projections because not all clauses have a projection copattern"- CosplitNoTarget -> fsep $ pwords "Cannot split into projections because target type is unknown" @@ -2069,8 +2186,17 @@ , text $ verbalize $ getQuantity mod ] ++ pwords "modality" + UnifyVarInRewrite tel a i u -> addContext tel $ fsep $+ pwords "Cannot solve variable " ++ [prettyTCM (var i)] +++ pwords "of type " ++ [prettyTCM a] +++ pwords "with solution " ++ [prettyTCM u] +++ pwords "because the variable occurs in a local rewrite rule." + UnifyVarInRewriteEta tel i -> addContext tel $ fsep $+ pwords "Cannot eta-expand variable " ++ [prettyTCM (var i)] +++ pwords "because the variable occurs in a local rewrite rule." + 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@@ -2120,13 +2246,13 @@ <+> text (prettyShow $ anameName a) , nest 2 $ "brought into scope by" ] $$- nest 2 (pWhy (nameBindingSite $ qnameName $ anameName a) (anameLineage a))+ nest 2 (pWhy (nameBindingSite 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))+ nest 2 (pWhy (nameBindingSite a) (amodLineage a)) pWhy :: Range -> WhyInScope -> m Doc pWhy r Defined = "- its definition at" <+> prettyTCM r@@ -2174,6 +2300,7 @@ verbalize = \case Flat -> "flat" Continuous -> "continuous"+ Sharp -> "sharp" Squash -> "squashed" instance Verbalize ModalPolarity where@@ -2197,7 +2324,7 @@ [ verbalize pol | pol /= defaultPolarity , pol /= modPolarity defaultCheckModality ] -- | Indefinite article.-data Indefinite a = Indefinite a+newtype Indefinite a = Indefinite a instance Verbalize a => Verbalize (Indefinite a) where verbalize (Indefinite a) =@@ -2206,3 +2333,12 @@ w@(c:cs) | c `elem` ['a','e','i','o'] -> "an " ++ w | otherwise -> "a " ++ w -- Aarne Ranta would whip me if he saw this.++-- | Number rendered as an ordinal (@1st@, @2nd@, etc)+newtype Ordinal = Ordinal Int+instance Verbalize Ordinal where+ verbalize (Ordinal n) = case n `mod` 10 of+ 1 -> show n <> "st"+ 2 -> show n <> "nd"+ 3 -> show n <> "rd"+ _ -> show n <> "th"
src/full/Agda/TypeChecking/Errors.hs-boot view
@@ -2,7 +2,7 @@ module Agda.TypeChecking.Errors where -import Agda.Syntax.Common (Cohesion, PolarityModality, Relevance)+import Agda.Syntax.Common (Cohesion, PolarityModality, Relevance, Hiding, Quantity) import Agda.Syntax.Abstract.Name import Agda.TypeChecking.Monad.Base@@ -23,4 +23,12 @@ instance Verbalize Relevance instance Verbalize Cohesion+instance Verbalize Hiding+instance Verbalize Quantity instance Verbalize PolarityModality++newtype Indefinite a = Indefinite a+instance Verbalize a => Verbalize (Indefinite a)++newtype Ordinal = Ordinal Int+instance Verbalize Ordinal
src/full/Agda/TypeChecking/Errors/Names.hs view
@@ -4,6 +4,7 @@ import Agda.Syntax.Concrete.Definitions.Errors as N (DeclarationException'(..)) import Agda.TypeChecking.Monad.Base as MB+import Agda.TypeChecking.Conversion.Errors import Agda.Interaction.Options.Errors -- | Print the name of a 'TypeError'.@@ -34,12 +35,14 @@ NotAValidLetExpression what -> NotAValidLetExpression_ what PatternSynonymArgumentShadows what _ _ -> PatternSynonymArgumentShadows_ what -- Wrappers- OperatorInformation _ err -> typeErrorName err+ OperatorInformation _ _ err -> typeErrorName err+ ConversionError_ ConversionError{convErrTys = cmp} -> case cmp of+ FailAsTypes{} -> UnequalTypes_+ FailAsTermsOf{} -> UnequalTerms_ -- Generic errors (alphabetically) CompilationError {} -> CompilationError_ CustomBackendError {} -> CustomBackendError_- GenericError {} -> GenericError_- GenericDocError {} -> GenericDocError_+ UserError {} -> UserError_ InternalError {} -> InternalError_ LibraryError {} -> LibraryError_ NonFatalErrors {} -> NonFatalErrors_@@ -73,8 +76,10 @@ CannotApply {} -> CannotApply_ CannotEliminateWithPattern {} -> CannotEliminateWithPattern_ CannotEliminateWithProjection {} -> CannotEliminateWithProjection_+ CannotGeneralizeEtaExpandable {} -> CannotGeneralizeEtaExpandable_ CannotGenerateHCompClause {} -> CannotGenerateHCompClause_ CannotGenerateTransportClause {} -> CannotGenerateTransportClause_+ CannotGenerateTransportLocalRewrite {} -> CannotGenerateTransportLocalRewrite_ CannotResolveAmbiguousPatternSynonym {} -> CannotResolveAmbiguousPatternSynonym_ CannotRewriteByNonEquation {} -> CannotRewriteByNonEquation_ CannotSolveSizeConstraints {} -> CannotSolveSizeConstraints_@@ -107,6 +112,7 @@ DuplicateOverlapPragma {} -> DuplicateOverlapPragma_ DuplicatePrimitiveBinding {} -> DuplicatePrimitiveBinding_ EmptyTypeOfSizes {} -> EmptyTypeOfSizes_+ EtaPragmaVsNoEtaEquality {} -> EtaPragmaVsNoEtaEquality_ ExpectedBindingForParameter {} -> ExpectedBindingForParameter_ ExpectedIntervalLiteral {} -> ExpectedIntervalLiteral_ FieldOutsideRecord {} -> FieldOutsideRecord_@@ -115,6 +121,10 @@ FileNotFound {} -> FileNotFound_ ForcedConstructorNotInstantiated {} -> ForcedConstructorNotInstantiated_ FunctionTypeInSizeUniv {} -> FunctionTypeInSizeUniv_+ GeneralizationFailed {} -> GeneralizationFailed_+ GeneralizationPrepruneErrorRefinedContext {} -> GeneralizationPrepruneErrorRefinedContext_+ GeneralizationPrepruneErrorCyclicDependencies {} -> GeneralizationPrepruneErrorCyclicDependencies_+ GeneralizationPrepruneErrorFailedToInstantiate {} -> GeneralizationPrepruneErrorFailedToInstantiate_ GeneralizeCyclicDependency {} -> GeneralizeCyclicDependency_ GeneralizeNotSupportedHere {} -> GeneralizeNotSupportedHere_ GeneralizedVarInLetOpenedModule {} -> GeneralizedVarInLetOpenedModule_@@ -123,8 +133,8 @@ InvalidBuiltin {} -> InvalidBuiltin_ InvalidDottedExpression {} -> InvalidDottedExpression_ IllTypedPatternAfterWithAbstraction {} -> IllTypedPatternAfterWithAbstraction_+ IlltypedRewriteRule {} -> IlltypedRewriteRule_ IllegalDeclarationBeforeTopLevelModule {} -> IllegalDeclarationBeforeTopLevelModule_- IllegalDeclarationInDataDefinition {} -> IllegalDeclarationInDataDefinition_ IllegalHidingInPostfixProjection {} -> IllegalHidingInPostfixProjection_ IllegalInstanceVariableInPatternSynonym {} -> IllegalInstanceVariableInPatternSynonym_ IllegalLetInTelescope {} -> IllegalLetInTelescope_@@ -147,6 +157,7 @@ MetaErasedSolution {} -> MetaErasedSolution_ MetaIrrelevantSolution {} -> MetaIrrelevantSolution_ MismatchedProjectionsError {} -> MismatchedProjectionsError_+ MissingBindingsForTelescopeVariables {} -> MissingBindingsForTelescopeVariables_ ModuleArityMismatch {} -> ModuleArityMismatch_ ModuleDefinedInOtherFile {} -> ModuleDefinedInOtherFile_ ModuleNameDoesntMatchFileName {} -> ModuleNameDoesntMatchFileName_@@ -156,10 +167,12 @@ MultiplePolarityPragmas {} -> MultiplePolarityPragmas_ ExplicitPolarityVsPragma {} -> ExplicitPolarityVsPragma_ NamedWhereModuleInRefinedContext {} -> NamedWhereModuleInRefinedContext_+ NamedWhereModuleUnderWith {} -> NamedWhereModuleUnderWith_ NeedOptionAllowExec {} -> NeedOptionAllowExec_ NeedOptionCopatterns {} -> NeedOptionCopatterns_ NeedOptionCubical {} -> NeedOptionCubical_ NeedOptionPatternMatching {} -> NeedOptionPatternMatching_+ NeedOptionIrrelevance {} -> NeedOptionIrrelevance_ NeedOptionProp {} -> NeedOptionProp_ NeedOptionRewriting {} -> NeedOptionRewriting_ NeedOptionSizedTypes {} -> NeedOptionSizedTypes_@@ -189,7 +202,6 @@ QualifiedLocalModule {} -> QualifiedLocalModule_ QuantityMismatch {} -> QuantityMismatch_ RecordIsErased {} -> RecordIsErased_- RecursiveRecordNeedsInductivity {} -> RecursiveRecordNeedsInductivity_ ReferencesFutureVariables {} -> ReferencesFutureVariables_ RelevanceMismatch {} -> RelevanceMismatch_ RepeatedNamesInImportDirective {} -> RepeatedNamesInImportDirective_@@ -222,21 +234,15 @@ TooManyFields {} -> TooManyFields_ TooManyPatternsInWithClause {} -> TooManyPatternsInWithClause_ TriedToCopyConstrainedPrim {} -> TriedToCopyConstrainedPrim_+ TrustedBuiltin {} -> TrustedBuiltin_+ TrustedPrimitive {} -> TrustedPrimitive_ InvalidInstanceHeadType {} -> InvalidInstanceHeadType_ UnboundVariablesInPatternSynonym {} -> UnboundVariablesInPatternSynonym_- UnequalCohesion {} -> UnequalCohesion_- UnequalFiniteness {} -> UnequalFiniteness_- UnequalHiding {} -> UnequalHiding_- UnequalLevel {} -> UnequalLevel_- UnequalQuantity {} -> UnequalQuantity_- UnequalRelevance {} -> UnequalRelevance_- UnequalPolarity {} -> UnequalPolarity_- UnequalSorts {} -> UnequalSorts_- UnequalTerms {} -> UnequalTerms_ UnexpectedModalityAnnotationInParameter {} -> UnexpectedModalityAnnotationInParameter_ UnexpectedParameter {} -> UnexpectedParameter_ UnexpectedTypeSignatureForParameter {} -> UnexpectedTypeSignatureForParameter_ UnexpectedWithPatterns {} -> UnexpectedWithPatterns_+ UnguardedEtaRecord {} -> UnguardedEtaRecord_ UnknownBackend {} -> UnknownBackend_ UnusableAtModality {} -> UnusableAtModality_ UnusedVariableInPatternSynonym {} -> UnusedVariableInPatternSynonym_@@ -256,6 +262,7 @@ WrongHidingInProjection {} -> WrongHidingInProjection_ WrongIrrelevanceInLambda {} -> WrongIrrelevanceInLambda_ WrongNamedArgument {} -> WrongNamedArgument_+ WrongNamedArgumentInLHS {} -> WrongNamedArgumentInLHS_ WrongNumberOfConstructorArguments {} -> WrongNumberOfConstructorArguments_ WrongQuantityInLambda {} -> WrongQuantityInLambda_ WrongSharpArity {} -> WrongSharpArity_@@ -332,7 +339,6 @@ BlockedType {} -> BlockedType_ CannotCreateMissingClause {} -> CannotCreateMissingClause_ CoinductiveDatatype {} -> CoinductiveDatatype_- CosplitCatchall {} -> CosplitCatchall_ CosplitNoRecordType {} -> CosplitNoRecordType_ CosplitNoTarget {} -> CosplitNoTarget_ NotADatatype {} -> NotADatatype_@@ -354,6 +360,7 @@ ConInsteadOfDef {} -> ConInsteadOfDef_ DefineDataNotData {} -> DefineDataNotData_ DefInsteadOfCon {} -> DefInsteadOfCon_+ EscapingVariable {} -> EscapingVariable_ MissingDeclaration {} -> MissingDeclaration_ MissingDefinition {} -> MissingDefinition_ NakedUnquote {} -> NakedUnquote_
src/full/Agda/TypeChecking/EtaContract.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wunused-imports #-}+-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-all -dno-suppress-type-signatures -ddump-to-file -dno-typeable-binds #-} -- | Compute eta short normal forms. module Agda.TypeChecking.EtaContract where@@ -15,7 +16,7 @@ import {-# SOURCE #-} Agda.TypeChecking.Datatypes import Agda.Utils.Monad-import Agda.Utils.List (initLast)+import Agda.Utils.List (initLast') import Agda.Utils.Impossible @@ -28,7 +29,7 @@ Var i xs -> appE (Var i) xs Def c xs -> appE (Def c) xs -- Andreas, 2013-09-17: do not eta-contract when body is (record) constructor- -- like in \ x -> s , x! (See interaction/DoNotEtaContractFunIntoRecord)+ -- like in \ x -> s , x! (See Interaction/DoNotEtaContractFunIntoRecord) -- (Cf. also issue 889 (fixed differently).) -- At least record constructors should be fully applied where possible! -- TODO: also for ordinary constructors (\ x -> suc x vs. suc)?@@ -47,18 +48,18 @@ Dummy{} -> __IMPOSSIBLE__ where noApp = NoApp t- appE f es0 | Just (es, Apply v) <- initLast es0 = App (f es) v+ appE f es0 | Just (es, Apply v) <- initLast' es0 = App (f es) v appE _ _ = noApp -- | Contracts all eta-redexes it sees without reducing. {-# SPECIALIZE etaContract :: TermLike a => a -> TCM a #-} {-# SPECIALIZE etaContract :: TermLike a => a -> ReduceM a #-}-etaContract :: (MonadTCEnv m, HasConstInfo m, HasOptions m, TermLike a) => a -> m a+etaContract :: (HasConstInfo m, TermLike a) => a -> m a etaContract = traverseTermM etaOnce {-# SPECIALIZE etaOnce :: Term -> TCM Term #-} {-# SPECIALIZE etaOnce :: Term -> ReduceM Term #-}-etaOnce :: (MonadTCEnv m, HasConstInfo m, HasOptions m) => Term -> m Term+etaOnce :: (HasConstInfo m) => Term -> m Term etaOnce = \case -- Andreas, 2012-11-18: this call to reportSDoc seems to cost me 2% -- performance on the std-lib@@ -72,8 +73,9 @@ v -> return v +{-# INLINE etaCon #-} -- | If record constructor, call eta-contraction function.-etaCon :: (MonadTCEnv m, HasConstInfo m, HasOptions m)+etaCon :: (HasConstInfo m) => ConHead -- ^ Constructor name @c@. -> ConInfo -- ^ Constructor info @ci@. -> Elims -- ^ Constructor arguments @args@.@@ -89,8 +91,9 @@ let Just args = allApplyElims es cont r c ci args +{-# INLINE etaLam #-} -- | Try to contract a lambda-abstraction @Lam i (Abs x b)@.-etaLam :: (MonadTCEnv m, HasConstInfo m, HasOptions m)+etaLam :: (MonadTCEnv m, HasOptions m) => ArgInfo -- ^ Info @i@ of the 'Lam'. -> ArgName -- ^ Name @x@ of the abstraction. -> Term -- ^ Body ('Term') @b@ of the 'Abs'.@@ -108,7 +111,7 @@ && sameHiding i info && sameModality i info && not (freeIn 0 u)- then return $ strengthen impossible u+ then return $! strengthen impossible u else fallback _ -> fallback where
+ src/full/Agda/TypeChecking/EtaContract.hs-boot view
@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.TypeChecking.EtaContract where++import Agda.Syntax.Internal.Generic (TermLike)+import {-# SOURCE #-} Agda.TypeChecking.Monad.Signature (HasConstInfo)++etaContract :: (HasConstInfo m, TermLike a) => a -> m a
src/full/Agda/TypeChecking/Free.hs view
@@ -1,286 +1,493 @@-{-# LANGUAGE UndecidableInstances #-} -- Due to underdetermined var in IsVarSet multi-param typeclass+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# OPTIONS_GHC -Wunused-imports #-}+#if __GLASGOW_HASKELL__ > 902+{-# OPTIONS_GHC -fworker-wrapper-cbv #-}+#endif --- | Computing the free variables of a term.------ The distinction between rigid and strongly rigid occurrences comes from:--- Jason C. Reed, PhD thesis, 2009, page 96 (see also his LFMTP 2009 paper)------ The main idea is that x = t(x) is unsolvable if x occurs strongly rigidly--- in t. It might have a solution if the occurrence is not strongly rigid, e.g.------ x = \f -> suc (f (x (\ y -> k))) has x = \f -> suc (f (suc k))------ [Jason C. Reed, PhD thesis, page 106]------ Under coinductive constructors, occurrences are never strongly rigid.--- Also, function types and lambdas do not establish strong rigidity.--- Only inductive constructors do so.--- (See issue 1271).------ If you need the occurrence information for all free variables, you can use--- @freeVars@ which has amoungst others this instance--- @--- freeVars :: Term -> VarMap--- @--- From @VarMap@, specific information can be extracted, e.g.,--- @--- relevantVars :: VarMap -> VarSet--- relevantVars = filterVarMap isRelevant--- @------ To just check the status of a single free variable, there are more--- efficient methods, e.g.,--- @--- freeIn :: Nat -> Term -> Bool--- @------ Tailored optimized variable checks can be implemented as semimodules to 'VarOcc',--- see, for example, 'VarCounts' or 'SingleFlexRig'.+{- |+Computing the free variables of a term. +The distinction between rigid and strongly rigid occurrences comes from: Jason C. Reed, PhD thesis,+2009, page 96 (see also his LFMTP 2009 paper)++The main idea is that x = t(x) is unsolvable if x occurs strongly rigidly in t. It might have a+solution if the occurrence is not strongly rigid, e.g.++ x = \f -> suc (f (x (\ y -> k))) has x = \f -> suc (f (suc k))++[Jason C. Reed, PhD thesis, page 106]++The most general function here is 'freeVarMap', which returns returns occurrence information about+every free variable. It is also a legacy function in the sense that it used to be the only function+for computing free occurrences, and it came with various functions for taking views of the resulting+'VarMap'. You can find these under the "Legacy API" here.++There are also also a bunch of specialized and optimized implementations of traversals here.++If you want to write a new function for computing free occurrence information, your task is+essentially to write a 'ComputeFree' instance and invoke 'freeVars'. These together implement a+generic traversal which has a good chance of being converted to decent code by GHC. You can look at+examples here and also look at the comments at 'ComputeFree'.+-}+ module Agda.TypeChecking.Free- ( VarCounts(..)- , Free- , IsVarSet(..)+ (+ FlexRig+ , FlexRig'(..)+ , Free(..) , IgnoreSorts(..)- , freeVars, freeVars', filterVarMap, filterVarMapToList- , runFree, rigidVars, stronglyRigidVars, unguardedVars, allVars+ , LensFlexRig(..)+ , VarCounts(..)+ , VarMap+ , VarMap'(..)+ , VarOcc+ , VarOcc'(..)+ , composeFlexRig+ , lookupVarMap+ , mapVarMap+ -- * Legacy API+ , allVars+ , filterVarMap+ , filterVarMapToList , flexibleVars- , allFreeVars- , allRelevantVars, allRelevantVarsIgnoring- , freeVarsIgnore- , freeIn, freeInIgnoringSorts, isBinderUsed- , relevantIn, relevantInIgnoringSortAnn- , FlexRig'(..), FlexRig- , LensFlexRig(..), isFlexible, isUnguarded, isStronglyRigid, isWeaklyRigid- , VarOcc'(..), VarOcc- , varOccurrenceIn- , flexRigOccurrenceIn+ , freeVarMap+ , isFlexible+ , isStronglyRigid+ , isUnguarded+ , isWeaklyRigid+ , rigidVars+ , stronglyRigidVars+ , unguardedVars++ -- * MetaSet+ , MetaSet(..)+ , foldrMetaSet+ , insertMetaSet+ , metaSetToBlocker++ -- * Specialized traversals+ , allFreeVar+ , allFreeVarIgnoreAll+ , anyFreeVar+ , anyFreeVarIgnoreAll , closed- , MetaSet- , insertMetaSet, foldrMetaSet, metaSetToBlocker+ , varOccurrenceIn+ , freeIn+ , freeInIgnoringSorts+ , freeVarCounts+ , freeVarList+ , freeVarMapIgnoreAnn+ , freeVarSet+ , isBinderUsed+ , relevantInIgnoringSortAnn+ , setRelInIgnoring+ , flexRigToBlocker+ , inRewVars, theRewVars ) where import Prelude hiding (null)+import GHC.Exts (Int(..), Int#, (-#), oneShot) -import Data.Semigroup ( Semigroup, (<>), Any(..), All(..) )-import Data.IntSet (IntSet)-import qualified Data.IntSet as IntSet+import Data.Semigroup (Any(..), All(..)) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap -import qualified Agda.Benchmarking as Bench- import Agda.Syntax.Common hiding (Arg, NamedArg) import Agda.Syntax.Internal -import Agda.TypeChecking.Free.Lazy- -- ( Free(..) , FreeEnv(..), initFreeEnv- -- , FlexRig, FlexRig'(..)- -- , VarOcc(..), topVarOcc, TheVarMap, theVarMap, IgnoreSorts(..), Variable, SingleVar- -- , MetaSet, insertMetaSet, foldrMetaSet- -- , IsVarSet(..), runFreeM- -- )+import Agda.TypeChecking.Free.Base+import Agda.TypeChecking.Free.Generic -import Agda.Utils.Singleton+import Agda.Utils.VarSet (VarSet)+import Agda.Utils.VarSet qualified as VarSet+import Agda.Utils.StrictReader+import Agda.Utils.StrictFlipEndo+import Agda.Utils.StrictEndo qualified as NonFlip+import Agda.Utils.ExpandCase+import Agda.Utils.Impossible (__IMPOSSIBLE__)+import Agda.Utils.Maybe (fromMaybe)+import Agda.Utils.Size (size) ------------------------------------------------------------------------------- * Simple variable set implementations.+-- ** All free variables together with information about their occurrence.+-------------------------------------------------------------------------------- -type VarSet = IntSet+data FreeVarMap = FreeVarMap !Int {-# UNPACK #-} !VarOcc --- In most cases we don't care about the VarOcc.+instance LensFlexRig FreeVarMap MetaSet where+ {-# INLINE lensFlexRig #-}+ lensFlexRig f (FreeVarMap x occ) = FreeVarMap x <$> lensFlexRig f occ -instance IsVarSet () VarSet where withVarOcc _ = id-instance IsVarSet () [Int] where withVarOcc _ = id-instance IsVarSet () Any where withVarOcc _ = id-instance IsVarSet () All where withVarOcc _ = id+instance LensModality FreeVarMap where+ {-# INLINE getModality #-}+ getModality (FreeVarMap _ occ) = getModality occ+ {-# INLINE mapModality #-}+ mapModality f (FreeVarMap x occ) = FreeVarMap x (mapModality f occ) ------------------------------------------------------------------------------- * Plain variable occurrence counting.+instance LensRelevance FreeVarMap -newtype VarCounts = VarCounts { varCounts :: IntMap Int }+instance ComputeFree FreeVarMap where+ type Collect FreeVarMap = Endo (IntMap VarOcc)+ {-# INLINE underBinders' #-}+ underBinders' n (FreeVarMap x occ) = FreeVarMap (n + x) occ+ {-# INLINE variable' #-}+ variable' x' (FreeVarMap x occ) = Endo \vars ->+ if x' < x then vars+ else IntMap.insertWith (<>) (x' - x) occ vars+ underConstructor' = defaultUnderConstructor; {-# INLINE underConstructor' #-}+ underFlexRig' = defaultUnderFlexRig; {-# INLINE underFlexRig' #-}+ underModality' = defaultUnderModality; {-# INLINE underModality' #-}+ underRelevance' = defaultUnderRelevance; {-# INLINE underRelevance' #-} -instance Semigroup VarCounts where- VarCounts fv1 <> VarCounts fv2 = VarCounts (IntMap.unionWith (+) fv1 fv2)+{-# SPECIALIZE freeVarMap :: Term -> VarMap #-}+{-# SPECIALIZE freeVarMap :: Type -> VarMap #-}+-- | Return information about every free variable.+freeVarMap :: Free t => t -> VarMap+freeVarMap t =+ VarMap (appEndo (runReader (freeVars t) (FreeVarMap 0 oneVarOcc)) mempty) -instance Monoid VarCounts where- mempty = VarCounts IntMap.empty- mappend = (<>)+-------------------------------------------------------------------------------- -instance IsVarSet () VarCounts where- withVarOcc _ = id+newtype FreeVarMapIgnoreAnn = FreeVarMapIgnoreAnn FreeVarMap+ deriving LensModality -instance Singleton Variable VarCounts where- singleton i = VarCounts $ IntMap.singleton i 1+instance LensFlexRig FreeVarMapIgnoreAnn MetaSet where+ {-# INLINE lensFlexRig #-}+ lensFlexRig f (FreeVarMapIgnoreAnn x) = FreeVarMapIgnoreAnn <$> lensFlexRig f x ------------------------------------------------------------------------------- * Collecting free variables (generic).+instance LensRelevance FreeVarMapIgnoreAnn --- | Collect all free variables together with information about their occurrence.------ Doesn't go inside solved metas, but collects the variables from a--- metavariable application @X ts@ as @flexibleVars@.-{-# SPECIALIZE freeVars :: Free a => a -> VarMap #-}-freeVars :: (IsVarSet a c, Singleton Variable c, Free t) => t -> c-freeVars = freeVarsIgnore IgnoreNot+instance ComputeFree FreeVarMapIgnoreAnn where+ type Collect FreeVarMapIgnoreAnn = Endo (IntMap VarOcc)+ {-# INLINE underBinders' #-}+ underBinders' n (FreeVarMapIgnoreAnn x) = FreeVarMapIgnoreAnn (underBinders' n x)+ {-# INLINE variable' #-}+ variable' x' (FreeVarMapIgnoreAnn x) = variable' x' x+ ignoreSorts' = IgnoreInAnnotations; {-# INLINE ignoreSorts' #-}+ underConstructor' = defaultUnderConstructor; {-# INLINE underConstructor' #-}+ underFlexRig' = defaultUnderFlexRig; {-# INLINE underFlexRig' #-}+ underModality' = defaultUnderModality; {-# INLINE underModality' #-}+ underRelevance' = defaultUnderRelevance; {-# INLINE underRelevance' #-} -freeVarsIgnore :: (IsVarSet a c, Singleton Variable c, Free t) =>- IgnoreSorts -> t -> c-freeVarsIgnore = runFree singleton+{-# SPECIALIZE freeVarMapIgnoreAnn :: Term -> VarMap #-}+{-# SPECIALIZE freeVarMapIgnoreAnn :: (Term,Type) -> VarMap #-}+-- | Return information about every free variable, but ignore occurrences+-- in sorts of types.+freeVarMapIgnoreAnn :: Free t => t -> VarMap+freeVarMapIgnoreAnn t =+ VarMap (appEndo (runReader (freeVars t)+ (FreeVarMapIgnoreAnn (FreeVarMap 0 oneVarOcc))) mempty) --- Specialization to typical monoids-{-# SPECIALIZE runFree :: Free a => SingleVar Any -> IgnoreSorts -> a -> Any #-}--- Specialization to Term-{-# SPECIALIZE runFree :: SingleVar Any -> IgnoreSorts -> Term -> Any #-}+-------------------------------------------------------------------------------- --- | Compute free variables.-runFree :: (IsVarSet a c, Free t) => SingleVar c -> IgnoreSorts -> t -> c-runFree single i t = -- bench $ -- Benchmarking is expensive (4% on std-lib)- runFreeM single i (freeVars' t)- where- bench = Bench.billToPure [ Bench.Typing , Bench.Free ]+newtype FreeVarCounts = FreeVarCounts Int ------------------------------------------------------------------------------- * Occurrence computation for a single variable.+instance ComputeFree FreeVarCounts where+ type Collect FreeVarCounts = Endo (IntMap Int)+ {-# INLINE underBinders' #-}+ underBinders' n (FreeVarCounts x) = FreeVarCounts (n + x)+ {-# INLINE variable' #-}+ variable' x' (FreeVarCounts x) = Endo \counts ->+ if x' < x then counts else IntMap.insertWith (+) (x' - x) 1 counts --- ** Full free occurrence info for a single variable.+{-# SPECIALIZE freeVarCounts :: Term -> VarCounts #-}+-- | Return how many times each free variable occurs.+freeVarCounts :: Free t => t -> VarCounts+freeVarCounts t =+ VarCounts (appEndo (runReader (freeVars t) (FreeVarCounts 0)) mempty) --- | Get the full occurrence information of a free variable.-varOccurrenceIn :: Free a => Nat -> a -> Maybe VarOcc-varOccurrenceIn = varOccurrenceIn' IgnoreNot+-- ** Testing that a predicate holds on any free variable+-------------------------------------------------------------------------------- -varOccurrenceIn' :: Free a => IgnoreSorts -> Nat -> a -> Maybe VarOcc-varOccurrenceIn' ig x t = theSingleVarOcc $ runFree sg ig t- where- sg y = if x == y then oneSingleVarOcc else mempty+data AnyFreeVar = AnyFreeVar !Int !(Int# -> Bool) --- | "Collection" just keeping track of the occurrence of a single variable.--- 'Nothing' means variable does not occur freely.-newtype SingleVarOcc = SingleVarOcc { theSingleVarOcc :: Maybe VarOcc }+instance ComputeFree AnyFreeVar where+ type Collect AnyFreeVar = Any+ {-# INLINE underBinders' #-}+ underBinders' n (AnyFreeVar x f) = AnyFreeVar (n + x) f+ {-# INLINE variable' #-}+ variable' (I# x') (AnyFreeVar (I# x) f) = if I# x' < I# x then mempty else Any (f (x' -# x)) -oneSingleVarOcc :: SingleVarOcc-oneSingleVarOcc = SingleVarOcc $ Just $ oneVarOcc+{-# SPECIALIZE anyFreeVar# :: (Int# -> Bool) -> Dom' Term Type -> Bool #-}+anyFreeVar# :: Free t => (Int# -> Bool) -> t -> Bool+anyFreeVar# f t = getAny (runReader (freeVars t) (AnyFreeVar 0 f)) --- | Hereditary Semigroup instance for 'Maybe'.--- (The default instance for 'Maybe' may not be the hereditary one.)-instance Semigroup SingleVarOcc where- SingleVarOcc Nothing <> s = s- s <> SingleVarOcc Nothing = s- SingleVarOcc (Just o) <> SingleVarOcc (Just o') = SingleVarOcc $ Just $ o <> o'+{-# INLINE anyFreeVar #-}+-- | Compute the disjunction of a predicate on free variables.+anyFreeVar :: Free t => (Int -> Bool) -> t -> Bool+anyFreeVar f = anyFreeVar# (\n -> f (I# n)) -instance Monoid SingleVarOcc where- mempty = SingleVarOcc Nothing- mappend = (<>)+{-# SPECIALIZE allFreeVar# :: (Int# -> Bool) -> Dom' Term Type -> Bool #-}+allFreeVar# :: Free t => (Int# -> Bool) -> t -> Bool+allFreeVar# f t = not (getAny (runReader (freeVars t) (AnyFreeVar 0 (\n -> not (f n))))) -instance IsVarSet MetaSet SingleVarOcc where- withVarOcc o = SingleVarOcc . fmap (composeVarOcc o) . theSingleVarOcc+{-# INLINE allFreeVar #-}+-- | Compute the conjunction of a predicate on free variables.+allFreeVar :: Free t => (Int -> Bool) -> t -> Bool+allFreeVar f = allFreeVar# (\n -> f (I# n)) --- ** Flexible /rigid occurrence info for a single variable.+data AnyFreeVarIgnoreAll = AnyFreeVarIgnoreAll !Int !(Int# -> Bool) --- | Get the full occurrence information of a free variable.-flexRigOccurrenceIn :: Free a => Nat -> a -> Maybe FlexRig-flexRigOccurrenceIn = flexRigOccurrenceIn' IgnoreNot+instance ComputeFree AnyFreeVarIgnoreAll where+ type Collect AnyFreeVarIgnoreAll = Any+ {-# INLINE underBinders' #-}+ underBinders' n (AnyFreeVarIgnoreAll x f) = AnyFreeVarIgnoreAll (n + x) f+ {-# INLINE variable' #-}+ variable' (I# x') (AnyFreeVarIgnoreAll (I# x) f) =+ if I# x' < I# x then mempty else Any (f (x' -# x))+ {-# INLINE ignoreSorts' #-}+ ignoreSorts' = IgnoreAll -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+{-# SPECIALIZE anyFreeVarIgnoreAll# :: (Int# -> Bool) -> Term -> Bool #-}+anyFreeVarIgnoreAll# :: Free t => (Int# -> Bool) -> t -> Bool+anyFreeVarIgnoreAll# f t = getAny (runReader (freeVars t) (AnyFreeVarIgnoreAll 0 f)) --- | "Collection" just keeping track of the occurrence of a single variable.--- 'Nothing' means variable does not occur freely.-newtype SingleFlexRig = SingleFlexRig { theSingleFlexRig :: Maybe FlexRig }+{-# INLINE anyFreeVarIgnoreAll #-}+-- | Same as 'anyFreeVar' except occurrences in sorts of types are ignored.+anyFreeVarIgnoreAll :: (Int -> Bool) -> Term -> Bool+anyFreeVarIgnoreAll f = anyFreeVarIgnoreAll# (\n -> f (I# n)) -oneSingleFlexRig :: SingleFlexRig-oneSingleFlexRig = SingleFlexRig $ Just $ oneFlexRig+-- SPECIALIZED to TCM.Constraint in SizedTypes.Solve+allFreeVarIgnoreAll# :: Free t => (Int# -> Bool) -> t -> Bool+allFreeVarIgnoreAll# f t =+ not (getAny (runReader (freeVars t) (AnyFreeVarIgnoreAll 0 (\n -> not (f n))))) --- | Hereditary Semigroup instance for 'Maybe'.--- (The default instance for 'Maybe' may not be the hereditary one.)-instance Semigroup SingleFlexRig where- SingleFlexRig Nothing <> s = s- s <> SingleFlexRig Nothing = s- SingleFlexRig (Just o) <> SingleFlexRig (Just o') = SingleFlexRig $ Just $ addFlexRig o o'+{-# INLINE allFreeVarIgnoreAll #-}+-- | Same as 'allFreeVar' except occurrences in sorts of types are ignored.+allFreeVarIgnoreAll :: Free t => (Int -> Bool) -> t -> Bool+allFreeVarIgnoreAll f = allFreeVarIgnoreAll# (\n -> f (I# n)) -instance Monoid SingleFlexRig where- mempty = SingleFlexRig Nothing- mappend = (<>)+-- ** Flex-rigid occurrence for a single variable+-------------------------------------------------------------------------------- -instance IsVarSet MetaSet SingleFlexRig where- withVarOcc o = SingleFlexRig . fmap (composeFlexRig $ varFlexRig o) . theSingleFlexRig+data SingleVarOcc = SingleVarOcc !Int !VarOcc --- ** Plain free occurrence.+instance LensFlexRig SingleVarOcc MetaSet where+ {-# INLINE lensFlexRig #-}+ lensFlexRig f (SingleVarOcc x occ) = SingleVarOcc x <$> lensFlexRig f occ --- | Check if a variable is free, possibly ignoring sorts.-freeIn' :: Free a => IgnoreSorts -> Nat -> a -> Bool-freeIn' ig x t = getAny $ runFree (Any . (x ==)) ig t+data CollectSingleVarOcc = CSVarOccNothing | CSVarOccJust !VarOcc +instance LensRelevance SingleVarOcc where++instance LensModality SingleVarOcc where+ {-# INLINE getModality #-}+ getModality (SingleVarOcc _ occ) = getModality occ+ {-# INLINE mapModality #-}+ mapModality f (SingleVarOcc x occ) = SingleVarOcc x (mapModality f occ)++instance Semigroup CollectSingleVarOcc where+ CSVarOccJust occ <> CSVarOccJust occ' = CSVarOccJust (occ <> occ')+ CSVarOccNothing <> s = s+ s <> CSVarOccNothing = s++instance ComputeFree SingleVarOcc where+ type Collect SingleVarOcc = Endo CollectSingleVarOcc+ {-# INLINE underBinders' #-}+ underBinders' n (SingleVarOcc x occ) = SingleVarOcc (n + x) occ+ {-# INLINE variable' #-}+ variable' x' (SingleVarOcc x occ) = Endo \acc -> if x == x' then acc <> CSVarOccJust occ else acc+ underConstructor' = defaultUnderConstructor; {-# INLINE underConstructor' #-}+ underFlexRig' = defaultUnderFlexRig; {-# INLINE underFlexRig' #-}+ underModality' = defaultUnderModality; {-# INLINE underModality' #-}+ underRelevance' = defaultUnderRelevance; {-# INLINE underRelevance' #-}++{-# SPECIALIZE varOccurrenceIn :: Nat -> Term -> Maybe VarOcc #-}+{-# SPECIALIZE varOccurrenceIn :: Nat -> Sort' Term -> Maybe VarOcc #-}+-- | Compute 'VarOcc' for a single variable.+varOccurrenceIn :: Free a => Nat -> a -> Maybe VarOcc+varOccurrenceIn x a = case appEndo (runReader (freeVars a) (SingleVarOcc x oneVarOcc)) CSVarOccNothing of+ CSVarOccNothing -> Nothing+ CSVarOccJust occ -> Just occ++-- ** Plain free occurrence+--------------------------------------------------------------------------------++newtype FreeIn = FreeIn Int++instance ComputeFree FreeIn where+ type Collect FreeIn = Any+ underBinders' n (FreeIn x) = FreeIn (n + x); {-# INLINE underBinders' #-}+ variable' x' (FreeIn x) = Any (x == x'); {-# INLINE variable' #-}+ {-# SPECIALIZE freeIn :: Nat -> Term -> Bool #-}-freeIn :: Free a => Nat -> a -> Bool-freeIn = freeIn' IgnoreNot+{-# SPECIALIZE freeIn :: Nat -> Type -> Bool #-}+-- | Check if single variable occurs freely.+freeIn :: Free t => Nat -> t -> Bool+freeIn x a = getAny (runReader (freeVars a) (FreeIn x)) -freeInIgnoringSorts :: Free a => Nat -> a -> Bool-freeInIgnoringSorts = freeIn' IgnoreAll+newtype FreeInIgnoringSorts = FreeInIgnoringSorts Int --- UNUSED Liang-Ting Chen 2019-07-16---freeInIgnoringSortAnn :: Free a => Nat -> a -> Bool---freeInIgnoringSortAnn = freeIn' IgnoreInAnnotations+instance ComputeFree FreeInIgnoringSorts where+ type Collect FreeInIgnoringSorts = Any+ underBinders' n (FreeInIgnoringSorts x) = FreeInIgnoringSorts (n + x); {-# INLINE underBinders' #-}+ variable' x' (FreeInIgnoringSorts x) = Any (x == x'); {-# INLINE variable' #-}+ ignoreSorts' = IgnoreAll; {-# INLINE ignoreSorts' #-} +{-# SPECIALIZE freeInIgnoringSorts :: Nat -> Term -> Bool #-}+{-# SPECIALIZE freeInIgnoringSorts :: Nat -> Type -> Bool #-}+-- | Check if a single variable occurs freely outside of sorts of types.+freeInIgnoringSorts :: Free a => Nat -> a -> Bool+freeInIgnoringSorts x a = getAny (runReader (freeVars a) (FreeInIgnoringSorts x))++{-# INLINE isBinderUsed #-} -- | Is the variable bound by the abstraction actually used? isBinderUsed :: Free a => Abs a -> Bool isBinderUsed NoAbs{} = False isBinderUsed (Abs _ x) = 0 `freeIn` x -- ** Relevant free occurrence.+-------------------------------------------------------------------------------- -newtype RelevantIn c = RelevantIn {getRelevantIn :: c}- deriving (Semigroup, Monoid)+data RelevantInIgnoringSortAnn = RelevantInIgnoringSortAnn !Int !Relevance -instance IsVarSet a c => IsVarSet a (RelevantIn c) where -- UndecidableInstances- withVarOcc o x- | isIrrelevant o = mempty- | otherwise = RelevantIn $ withVarOcc o $ getRelevantIn x+instance LensRelevance RelevantInIgnoringSortAnn where+ getRelevance (RelevantInIgnoringSortAnn _ r) = r+ mapRelevance f (RelevantInIgnoringSortAnn x r) = RelevantInIgnoringSortAnn x (f r) -relevantIn' :: Free t => IgnoreSorts -> Nat -> t -> Bool-relevantIn' ig x t = getAny . getRelevantIn $ runFree (RelevantIn . Any . (x ==)) ig t+instance ComputeFree RelevantInIgnoringSortAnn where+ type Collect RelevantInIgnoringSortAnn = Any+ {-# INLINE underBinders' #-}+ underBinders' n (RelevantInIgnoringSortAnn x r) =+ RelevantInIgnoringSortAnn (n + x) r+ {-# INLINE variable' #-}+ variable' x' (RelevantInIgnoringSortAnn x r) = Any (x' == x && not (isIrrelevant r))+ ignoreSorts' = IgnoreInAnnotations; {-# INLINE ignoreSorts' #-}+ {-# INLINE underModality' #-}+ underModality' = Just \m (RelevantInIgnoringSortAnn x r) ->+ RelevantInIgnoringSortAnn x (composeRelevance (getRelevance m) r)+ underRelevance' = defaultUnderRelevance; {-# INLINE underRelevance' #-} +{-# SPECIALIZE relevantInIgnoringSortAnn :: Nat -> Term -> Bool #-}+{-# SPECIALIZE relevantInIgnoringSortAnn :: Nat -> Type -> Bool #-}+{-# SPECIALIZE relevantInIgnoringSortAnn :: Nat -> Dom' Term Type -> Bool #-}+-- | Does a variable occur relevantly and outside of sorts of types? relevantInIgnoringSortAnn :: Free t => Nat -> t -> Bool-relevantInIgnoringSortAnn = relevantIn' IgnoreInAnnotations--relevantIn :: Free t => Nat -> t -> Bool-relevantIn = relevantIn' IgnoreAll+relevantInIgnoringSortAnn x t =+ getAny (runReader (freeVars t) (RelevantInIgnoringSortAnn x unitRelevance)) +-- ** Closed objects ------------------------------------------------------------------------------ * Occurrences of all free variables. --- | Is the term entirely closed (no free variables)?+newtype Closed = Closed Int -- ^ Local scope size.++instance ComputeFree Closed where+ type Collect Closed = All+ underBinders' n (Closed x) = Closed (n + x); {-# INLINE underBinders' #-}+ variable' x' (Closed x) = All (x' < x); {-# INLINE variable' #-}++{-# SPECIALIZE closed :: Term -> Bool #-}+{-# SPECIALIZE closed :: Dom' Term Type -> Bool #-}+-- | Is a term closed? closed :: Free t => t -> Bool-closed t = getAll $ runFree (const $ All False) IgnoreNot t+closed t = getAll (runReader (freeVars t) (Closed 0)) --- | Collect all free variables.-allFreeVars :: Free t => t -> VarSet-allFreeVars = runFree IntSet.singleton IgnoreNot+-- ** Test free occurrence for a set of variables+-------------------------------------------------------------------------------- --- | Collect all relevant free variables, possibly ignoring sorts.-allRelevantVarsIgnoring :: Free t => IgnoreSorts -> t -> VarSet-allRelevantVarsIgnoring ig = getRelevantIn . runFree (RelevantIn . IntSet.singleton) ig+data SetRelInIgnoring = SetRelInIgnoring !Int !Relevance --- | Collect all relevant free variables, excluding the "unused" ones.-allRelevantVars :: Free t => t -> VarSet-allRelevantVars = allRelevantVarsIgnoring IgnoreNot+instance LensRelevance SetRelInIgnoring where+ getRelevance (SetRelInIgnoring _ r) = r+ mapRelevance f (SetRelInIgnoring x r) = SetRelInIgnoring x (f r) +newtype CollectSFII = CollectSFII {appCSFII :: VarSet -> VarSet}++instance Semigroup CollectSFII where+ {-# INLINE (<>) #-}+ CollectSFII f <> CollectSFII g = CollectSFII (oneShot \xs -> case f xs of+ xs -> if VarSet.null xs then xs else g xs)++instance Monoid CollectSFII where+ {-# INLINE mempty #-}+ mempty = CollectSFII \xs -> xs++instance ExpandCase CollectSFII where+ type Result CollectSFII = VarSet+ {-# INLINE expand #-}+ expand k = CollectSFII (oneShot \a -> k (oneShot \act -> appCSFII act a))++instance ComputeFree SetRelInIgnoring where+ type Collect SetRelInIgnoring = CollectSFII+ {-# INLINE underBinders' #-}+ underBinders' n (SetRelInIgnoring x r) = SetRelInIgnoring (n + x) r+ {-# INLINE variable' #-}+ variable' x' (SetRelInIgnoring x r) = CollectSFII \xs ->+ if x' >= x && not (isIrrelevant r)+ then VarSet.delete (x' - x) xs+ else xs+ ignoreSorts' = IgnoreInAnnotations; {-# INLINE ignoreSorts' #-}+ underModality' = Just \m (SetRelInIgnoring x r) ->+ SetRelInIgnoring x (composeRelevance (getRelevance m) r)+ underRelevance' = defaultUnderRelevance; {-# INLINE underRelevance' #-}++{-# SPECIALIZE NOINLINE setRelInIgnoring :: VarSet -> Dom Type -> VarSet #-}+{-# SPECIALIZE NOINLINE setRelInIgnoring :: VarSet -> Type -> VarSet #-}+-- | Test for a set of variables whether each variable occurs relevantly and outside of sort annotations.+-- Return the set of variables that __don't__ occur.+setRelInIgnoring :: Free t => VarSet -> t -> VarSet+setRelInIgnoring xs t+ | VarSet.null xs = xs+ | otherwise = appCSFII (runReader (freeVars t) (SetRelInIgnoring 0 unitRelevance)) xs+++-- ** Collect free variables+--------------------------------------------------------------------------------++newtype FreeVarSet = FreeVarSet Int++instance ComputeFree FreeVarSet where+ type Collect FreeVarSet = Endo VarSet+ {-# INLINE underBinders' #-}+ underBinders' n (FreeVarSet x) = FreeVarSet (n + x)+ {-# INLINE variable' #-}+ variable' x' (FreeVarSet x) = Endo \xs -> if x' < x then xs else VarSet.insert (x' - x) xs++{-# SPECIALIZE freeVarSet :: Term -> VarSet #-}+{-# SPECIALIZE freeVarSet :: Dom' Term Type -> VarSet #-}+-- | Compute the set of free variables.+freeVarSet :: Free t => t -> VarSet+freeVarSet t = appEndo (runReader (freeVars t) (FreeVarSet 0)) mempty++newtype FreeVarList = FreeVarList Int++instance ComputeFree FreeVarList where+ -- Need the non-flipped endo to get left-right element order+ type Collect FreeVarList = NonFlip.Endo [Int]+ {-# INLINE underBinders' #-}+ underBinders' n (FreeVarList x) = FreeVarList (n + x)+ {-# INLINE variable' #-}+ variable' x' (FreeVarList x) = NonFlip.Endo \xs ->+ if x' < x then xs else let !v = x' - x in v : xs++{-# SPECIALIZE freeVarList :: Term -> [Int] #-}+{-# SPECIALIZE freeVarList :: Maybe Term -> [Int] #-}+-- | Compute a (possibly non-unique) list of free variables, in preorder traversal order.+freeVarList :: Free t => t -> [Int]+freeVarList t = NonFlip.appEndo (runReader (freeVars t) (FreeVarList 0)) []++-- ** Backwards-compatible interface, for extracting information from a 'VarMap'. ------------------------------------------------------------------------------ * Backwards-compatible interface to 'freeVars'. +{-# INLINE filterVarMap #-} filterVarMap :: (VarOcc -> Bool) -> VarMap -> VarSet-filterVarMap f = IntMap.keysSet . IntMap.filter f . theVarMap+filterVarMap f = \(VarMap m) ->+ IntMap.foldlWithKey'+ (\acc k v -> if f v then VarSet.insert k acc else acc)+ mempty m -filterVarMapToList :: (VarOcc -> Bool) -> VarMap -> [Variable]-filterVarMapToList f = map fst . filter (f . snd) . IntMap.toList . theVarMap+{-# INLINE filterVarMapToList #-}+filterVarMapToList :: (VarOcc -> Bool) -> VarMap -> [Int]+filterVarMapToList f = \(VarMap m) ->+ IntMap.foldrWithKey'+ (\k v acc -> if f v then k:acc else acc)+ [] m -- | Variables under only and at least one inductive constructor(s). stronglyRigidVars :: VarMap -> VarSet stronglyRigidVars = filterVarMap $ \case VarOcc StronglyRigid _ -> True- _ -> False+ _ -> False -- | Variables at top or only under inductive record constructors -- λs and Πs.@@ -290,32 +497,45 @@ unguardedVars :: VarMap -> VarSet unguardedVars = filterVarMap $ \case VarOcc Unguarded _ -> True- _ -> False---- UNUSED Liang-Ting Chen 2019-07-16----- | Ordinary rigid variables, e.g., in arguments of variables or functions.---weaklyRigidVars :: VarMap -> VarSet---weaklyRigidVars = filterVarMap $ \case--- VarOcc WeaklyRigid _ -> True--- _ -> False+ _ -> False -- | Rigid variables: either strongly rigid, unguarded, or weakly rigid. rigidVars :: VarMap -> VarSet rigidVars = filterVarMap $ \case- VarOcc o _ -> o `elem` [ WeaklyRigid, Unguarded, StronglyRigid ]+ VarOcc o _ -> case o of+ WeaklyRigid -> True+ Unguarded -> True+ StronglyRigid -> True+ _ -> False -- | Variables occuring in arguments of metas. -- These are only potentially free, depending how the meta variable is instantiated. -- The set contains the id's of the meta variables that this variable is an argument to. flexibleVars :: VarMap -> IntMap MetaSet-flexibleVars (VarMap m) = (`IntMap.mapMaybe` m) $ \case+flexibleVars (VarMap m) = flip IntMap.mapMaybe m $ \case VarOcc (Flexible ms) _ -> Just ms- _ -> Nothing------ | Variables in irrelevant arguments and under a @DontCare@, i.e.,----- in irrelevant positions.---irrelevantVars :: VarMap -> VarSet---irrelevantVars = filterVarMap isIrrelevant+ _ -> Nothing allVars :: VarMap -> VarSet-allVars = IntMap.keysSet . theVarMap+allVars = filterVarMap (\_ -> True)++-- | Returns the variables that correspond to local rewrite rules.+theRewVars :: Telescope -> VarSet+theRewVars = fst . allRewVars++-- | Returns all variables that occur in local rewrite rules.+inRewVars :: Telescope -> VarSet+inRewVars = snd . allRewVars++-- | Returns two sets of variables: the first set contains all variables+-- corresponding to local rewrite rules, and the second set includes all+-- variables which occur in those rewrite rules.+allRewVars :: Telescope -> (VarSet, VarSet)+allRewVars EmptyTel = (VarSet.empty, VarSet.empty)+allRewVars (ExtendTel a b) =+ fromMaybe (VarSet.empty, VarSet.empty)+ (go . fromMaybe __IMPOSSIBLE__ . rewDomRew <$> rewDom a)+ <> (allRewVars $ unAbs b)+ where+ go r =+ (VarSet.singleton $ size b, VarSet.weaken (size b + 1) $ freeVarSet r)
+ src/full/Agda/TypeChecking/Free/Base.hs view
@@ -0,0 +1,317 @@++module Agda.TypeChecking.Free.Base where++import Control.Applicative hiding (empty)+import Control.Monad.Reader ( MonadReader(..), asks, ReaderT, Reader, runReader )++import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet+import Data.Set (Set)+import qualified Data.Set as Set++import Agda.Syntax.Common.Pretty+import Agda.Syntax.Common+import Agda.Syntax.Internal++import Agda.Utils.Functor+import Agda.Utils.Lens+import Agda.Utils.List1 (List1)+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.Semigroup+import Agda.Utils.Singleton+import Agda.Utils.Size++---------------------------------------------------------------------------+-- * Set of meta variables.++-- | A set of meta variables. Forms a monoid under union.++newtype MetaSet = MetaSet { theMetaSet :: HashSet MetaId }+ deriving (Eq, Show, Null, Semigroup, Monoid)++instance Singleton MetaId MetaSet where+ singleton = MetaSet . singleton++insertMetaSet :: MetaId -> MetaSet -> MetaSet+insertMetaSet m (MetaSet ms) = MetaSet $ HashSet.insert m ms++foldrMetaSet :: (MetaId -> a -> a) -> a -> MetaSet -> a+foldrMetaSet f e ms = HashSet.foldr f e $ theMetaSet ms++metaSetToBlocker :: MetaSet -> Blocker+metaSetToBlocker ms = unblockOnAny $ foldrMetaSet (Set.insert . unblockOnMeta) Set.empty ms++instance Pretty MetaSet where+ pretty = pretty . Set.fromList . HashSet.toList . theMetaSet++---------------------------------------------------------------------------+-- * Flexible and rigid occurrences (semigroup)++-- | Depending on the surrounding context of a variable,+-- it's occurrence can be classified as flexible or rigid,+-- with finer distinctions.+--+-- The constructors are listed in increasing order (wrt. information content).+data FlexRig' a+ = Flexible !a -- ^ In arguments of metas.+ -- The set of metas is used by ''Agda.TypeChecking.Rewriting.NonLinMatch''+ -- to generate the right blocking information.+ -- The semantics is that the status of a variable occurrence may change+ -- if one of the metas in the set gets solved. We may say the occurrence+ -- is tainted by the meta variables in the set.+ | WeaklyRigid -- ^ In arguments to variables and definitions.+ | Unguarded -- ^ In top position, or only under inductive record constructors (unit).+ | StronglyRigid -- ^ Under at least one and only inductive constructors.+ deriving (Eq, Show, Functor, Foldable)++type FlexRig = FlexRig' MetaSet++class LensFlexRig o a | o -> a where+ lensFlexRig :: Lens' o (FlexRig' a)++instance LensFlexRig (FlexRig' a) a where+ lensFlexRig = id++isFlexible :: LensFlexRig o a => o -> Bool+isFlexible o = case o ^. lensFlexRig of+ Flexible {} -> True+ _ -> False++isUnguarded :: LensFlexRig o a => o -> Bool+isUnguarded o = case o ^. lensFlexRig of+ Unguarded -> True+ _ -> False++isWeaklyRigid :: LensFlexRig o a => o -> Bool+isWeaklyRigid o = case o ^. lensFlexRig of+ WeaklyRigid -> True+ _ -> False++isStronglyRigid :: LensFlexRig o a => o -> Bool+isStronglyRigid o = case o ^. lensFlexRig of+ StronglyRigid -> True+ _ -> False++-- | 'FlexRig' aggregation (additive operation of the semiring).+-- For combining occurrences of the same variable in subterms.+-- This is a refinement of the 'max' operation for 'FlexRig'+-- which would work if 'Flexible' did not have the 'MetaSet' as an argument.+-- Now, to aggregate two 'Flexible' occurrences, we union the involved 'MetaSet's.++addFlexRig :: Semigroup a => FlexRig' a -> FlexRig' a -> FlexRig' a+addFlexRig = curry $ \case+ -- StronglyRigid is dominant+ (StronglyRigid, _) -> StronglyRigid+ (_, StronglyRigid) -> StronglyRigid+ -- Next is Unguarded+ (Unguarded, _) -> Unguarded+ (_, Unguarded) -> Unguarded+ -- Then WeaklyRigid+ (WeaklyRigid, _) -> WeaklyRigid+ (_, WeaklyRigid) -> WeaklyRigid+ -- Least is Flexible. We union the meta sets, as the variable+ -- is tainted by all of the involved meta variable.+ (Flexible ms1, Flexible ms2) -> Flexible $ ms1 <> ms2+{-# SPECIALIZE NOINLINE addFlexRig :: FlexRig' MetaSet -> FlexRig' MetaSet -> FlexRig' MetaSet #-}+{-# SPECIALIZE NOINLINE addFlexRig :: FlexRig' () -> FlexRig' () -> FlexRig' () #-}++-- | Unit for 'addFlexRig'.+zeroFlexRig :: Monoid a => FlexRig' a+zeroFlexRig = Flexible mempty++-- | Absorptive for 'addFlexRig'.+omegaFlexRig :: FlexRig' a+omegaFlexRig = StronglyRigid++-- | 'FlexRig' composition (multiplicative operation of the semiring).+-- For accumulating the context of a variable.+--+-- 'Flexible' is dominant. Once we are under a meta, we are flexible+-- regardless what else comes. We taint all variable occurrences+-- under a meta by this meta.+--+-- 'WeaklyRigid' is next in strength. Destroys strong rigidity.+--+-- 'StronglyRigid' is still dominant over 'Unguarded'.+--+-- 'Unguarded' is the unit. It is the top (identity) context.+--+composeFlexRig :: Semigroup a => FlexRig' a -> FlexRig' a -> FlexRig' a+composeFlexRig = curry $ \case+ (Flexible ms1, Flexible ms2) -> Flexible $ ms1 <> ms2+ (Flexible ms1, _) -> Flexible ms1+ (_, Flexible ms2) -> Flexible ms2+ (WeaklyRigid, _) -> WeaklyRigid+ (_, WeaklyRigid) -> WeaklyRigid+ (StronglyRigid, _) -> StronglyRigid+ (_, StronglyRigid) -> StronglyRigid+ (Unguarded, Unguarded) -> Unguarded+{-# SPECIALIZE NOINLINE composeFlexRig :: FlexRig' MetaSet -> FlexRig' MetaSet -> FlexRig' MetaSet #-}+{-# SPECIALIZE NOINLINE composeFlexRig :: FlexRig' () -> FlexRig' () -> FlexRig' () #-}++-- | Unit for 'composeFlexRig'.+oneFlexRig :: FlexRig' a+oneFlexRig = Unguarded++-- | Extract a blocker from an occurrence+flexRigToBlocker :: FlexRig -> Blocker+flexRigToBlocker (Flexible ms) = metaSetToBlocker ms+flexRigToBlocker _ = neverUnblock++instance Pretty a => Pretty (FlexRig' a) where+ pretty = \case+ Flexible a -> "FL" <> parens (pretty a)+ WeaklyRigid -> "WR"+ StronglyRigid -> "SR"+ Unguarded -> empty++---------------------------------------------------------------------------+-- * Multi-dimensional feature vector for variable occurrence (semigroup)++-- | Occurrence of free variables is classified by several dimensions.+-- Currently, we have 'FlexRig' and 'Modality'.+data VarOcc' a = VarOcc+ { varFlexRig :: !(FlexRig' a)+ , varModality :: {-# UNPACK #-} !Modality+ }+ deriving (Show)+type VarOcc = VarOcc' MetaSet++-- | Equality up to origin.+instance Eq a => Eq (VarOcc' a) where+ VarOcc fr m == VarOcc fr' m' = fr == fr' && sameModality m m'++instance LensModality (VarOcc' a) where+ getModality = varModality+ mapModality f (VarOcc x r) = VarOcc x $ f r++instance LensRelevance (VarOcc' a) where+instance LensQuantity (VarOcc' a) where++-- | Access to 'varFlexRig' in 'VarOcc'.+instance LensFlexRig (VarOcc' a) a where+ lensFlexRig f (VarOcc fr m) = f fr <&> \ fr' -> VarOcc fr' m+-- lensFlexRig :: Lens' (VarOcc' a) (FlexRig' a)+-- lensFlexRig f (VarOcc fr m) = f fr <&> \ fr' -> VarOcc fr' m+++-- | The default way of aggregating free variable info from subterms is by adding+-- the variable occurrences. For instance, if we have a pair @(t₁,t₂)@ then+-- and @t₁@ has @o₁@ the occurrences of a variable @x@+-- and @t₂@ has @o₂@ the occurrences of the same variable, then+-- @(t₁,t₂)@ has @mappend o₁ o₂@ occurrences of that variable.+--+-- From counting 'Quantity', we extrapolate this to 'FlexRig' and 'Relevance':+-- we care most about about 'StronglyRigid' 'Relevant' occurrences.+-- E.g., if @t₁@ has a 'StronglyRigid' occurrence and @t₂@ a 'Flexible' occurrence,+-- then @(t₁,t₂)@ still has a 'StronglyRigid' occurrence.+-- Analogously, @Relevant@ occurrences count most, as we wish e.g. to forbid+-- relevant occurrences of variables that are declared to be irrelevant.+--+-- 'VarOcc' forms a semiring, and this monoid is the addition of the semiring.++instance Semigroup a => Semigroup (VarOcc' a) where+ VarOcc o m <> VarOcc o' m' = VarOcc (addFlexRig o o') (addModality m m')++-- | The neutral element for variable occurrence aggregation is least serious+-- occurrence: flexible, irrelevant.+-- This is also the absorptive element for 'composeVarOcc', if we ignore+-- the 'MetaSet' in 'Flexible'.+instance (Monoid a) => Monoid (VarOcc' a) where+ mempty = VarOcc (Flexible mempty) zeroModality+ mappend = (<>)++-- | The absorptive element of variable occurrence under aggregation:+-- strongly rigid, relevant.+topVarOcc :: VarOcc' a+topVarOcc = VarOcc StronglyRigid topModality++-- | First argument is the outer occurrence (context) and second is the inner.+-- This multiplicative operation is to modify an occurrence under a context.+composeVarOcc :: Semigroup a => VarOcc' a -> VarOcc' a -> VarOcc' a+composeVarOcc (VarOcc o m) (VarOcc o' m') = VarOcc (composeFlexRig o o') (composeModality m m')+ -- We use the multipicative modality monoid (composition).++oneVarOcc :: VarOcc' a+oneVarOcc = VarOcc Unguarded unitModality++-- | What's the rigidity of a constructor?+constructorFlexRig :: ConHead -> Elims -> FlexRig' a+constructorFlexRig (ConHead _ _ i hit fs) es+ | hit == YesHIT = WeaklyRigid+ | otherwise = case i of++ -- Coinductive (record) constructors admit infinite cycles:+ CoInductive -> WeaklyRigid+ -- Inductive constructors do not admit infinite cycles:+ Inductive | size es == size fs -> StronglyRigid+ | otherwise -> WeaklyRigid+ -- Jesper, 2020-10-22: Issue #4995: treat occurrences in non-fully+ -- applied constructors as weakly rigid.+ -- Ulf, 2019-10-18: Now the termination checker treats inductive recursive records+ -- the same as datatypes, so absense of infinite cycles can be proven in Agda, and thus+ -- the unifier is allowed to do it too. Test case: test/Succeed/Issue1271a.agda+ -- WAS:+ -- -- Inductive record constructors do not admit infinite cycles,+ -- -- but this cannot be proven inside Agda.+ -- -- Thus, unification should not prove it either.++instance Pretty a => Pretty (VarOcc' a) where+ pretty (VarOcc a b) = pretty a <+> pretty b++-- | Representation of a variable set as map from de Bruijn indices+-- to 'VarOcc'.+type TheVarMap' a = IntMap (VarOcc' a)+newtype VarMap' a = VarMap { theVarMap :: TheVarMap' a }+ deriving (Eq, Show)++type TheVarMap = TheVarMap' MetaSet+type VarMap = VarMap' MetaSet++-- | A "set"-style 'Singleton' instance with default/initial variable occurrence.+instance Singleton Variable (VarMap' a) where+ singleton i = VarMap $ IntMap.singleton i oneVarOcc++mapVarMap :: (TheVarMap' a -> TheVarMap' b) -> VarMap' a -> VarMap' b+mapVarMap f = VarMap . f . theVarMap++lookupVarMap :: Variable -> VarMap' a -> Maybe (VarOcc' a)+lookupVarMap i = IntMap.lookup i . theVarMap++-- Andreas & Jesper, 2018-05-11, issue #3052:++-- | Proper monoid instance for @VarMap@ rather than inheriting the broken one from IntMap.+-- We combine two occurrences of a variable using 'mappend'.+instance Semigroup a => Semigroup (VarMap' a) where+ VarMap m <> VarMap m' = VarMap $ IntMap.unionWith (<>) m m'++instance Semigroup a => Monoid (VarMap' a) where+ mempty = VarMap IntMap.empty+ mappend = (<>)+ mconcat = VarMap . IntMap.unionsWith (<>) . map theVarMap+ -- mconcat = VarMap . IntMap.unionsWith mappend . coerce -- ghc 8.6.5 does not seem to like this coerce++---------------------------------------------------------------------------+-- * Plain variable occurrence counting.++newtype VarCounts = VarCounts { varCounts :: IntMap Int }+ deriving (Eq, Show)++instance Semigroup VarCounts where+ VarCounts fv1 <> VarCounts fv2 = VarCounts (IntMap.unionWith (+) fv1 fv2)++instance Monoid VarCounts where+ mempty = VarCounts IntMap.empty+ mappend = (<>)++-- | Where should we skip sorts in free variable analysis?+data IgnoreSorts+ = IgnoreNot -- ^ Do not skip.+ | IgnoreInAnnotations -- ^ Skip when annotation to a type.+ | IgnoreAll -- ^ Skip unconditionally.+ deriving (Eq, Show)++type Variable = Int
+ src/full/Agda/TypeChecking/Free/Generic.hs view
@@ -0,0 +1,356 @@+{-# LANGUAGE AllowAmbiguousTypes, CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}++#if __GLASGOW_HASKELL__ > 902+{-# OPTIONS_GHC -fworker-wrapper-cbv #-}+#endif++{- |+Computing free variables of a term generically. Different queries can be specialized to the+appropriate short-circuiting behavior and to only pass around the necessary data. A query can be+written as an instance to the 'ComputeFree' class which bundles all parameters of the generic+traversal. The traversal itself is defined in the instance of the 'Free' class. See+Agda.TypeChecking.Free for examples of queries.++Background notes:++The distinction between rigid and strongly rigid occurrences comes from: Jason C. Reed, PhD thesis,+ 2009, page 96 (see also his LFMTP 2009 paper)++The main idea is that x = t(x) is unsolvable if x occurs strongly rigidly in t. It might have a+solution if the occurrence is not strongly rigid, e.g.++ x = \f -> suc (f (x (\ y -> k))) has x = \f -> suc (f (suc k))++[Jason C. Reed, PhD thesis, page 106]++Under coinductive constructors, occurrences are never strongly rigid. Also, function types and+lambdas do not establish strong rigidity. Only inductive constructors do so. (See issue 1271).++For further reading on semirings and semimodules for variable occurrence, see e.g. Conor McBrides "I+got plenty of nuttin'" (Wadlerfest 2016). There, he treats the "quantity" dimension of variable+occurrences.++The semiring has an additive operation for combining occurrences of subterms, and a+multiplicative operation of representing function composition. E.g. if variable @x@ appears @o@+in term @u@, but @u@ appears in context @q@ in term @t@ then occurrence of variable @x@ coming+from @u@ is accounted for as @q o@ in @t@.++Consider the example @(λ{ x → (x,x)}) y@:++ * Variable @x@ occurs once unguarded in @x@.++ * It occurs twice unguarded in the aggregation @x@ @x@++ * Inductive constructor @,@ turns this into two strictly rigid occurrences.++ If @,@ is a record constructor, then we stay unguarded.++ * The function @({λ x → (x,x)})@ provides a context for variable @y@.+ This context can be described as weakly rigid with quantity two.++ * The final occurrence of @y@ is obtained as composing the context with+ the occurrence of @y@ in itself (which is the unit for composition).+ Thus, @y@ occurs weakly rigid with quantity two.++It is not a given that the context can be described in the same way as the variable occurrence.+However, for the purpose of quantity it is the case and we obtain a semiring of occurrences with 0,+1, and even ω, which is an absorptive element for addition.+-}++module Agda.TypeChecking.Free.Generic where++import Agda.Syntax.Common+import Agda.Syntax.Internal+import Agda.TypeChecking.Free.Base++import Agda.Utils.ExpandCase+import Agda.Utils.Lens+import Agda.Utils.List1 (List1, pattern (:|))+import Agda.Utils.Monad+import Agda.Utils.Singleton+import Agda.Utils.Size+import Agda.Utils.StrictReader++--------------------------------------------------------------------------------++-- | Instances of 'ComputeFree' are inputs to the generic traveral implemented by 'Free' instances.+-- The @r@ type parameter denotes the 'Reader' environment of the traversal.+class (ExpandCase (Collect r), Monoid (Collect r)) => ComputeFree r where+ type Collect r+ -- ^ The result type of the traversal. Most commonly, this is either a newtype wrapper on 'Bool'+ -- or some instantiation of 'StrictEndo' from 'Agda.Utils.StrictEndo'. The latter is used to+ -- efficiently accummulate sets or maps.+ underBinders' :: Int -> r -> r+ -- ^ Update the environment when going under some number of binders.+ underConstructor' :: ConHead -> Elims -> r -> r+ -- ^ Update the environment when descending into the spine of a constructor.+ underModality' :: Maybe (Modality -> r -> r)+ -- ^ Update the environment when going under a modality. 'Nothing' has the identity action.+ underFlexRig' :: Maybe (FlexRig -> r -> r)+ -- ^ Update the environment when the rigidity of the current position changes, e.g. we switch to+ -- flexible mode when going into the spine of an unsolved metavariable. See the 'Free' instances+ -- for details. 'Nothing' has the identity action. NOTE: since 'Modality' contains 'FlexRig'+ -- information, if you implement a non-trivial 'FlexRig' update, you must also implement a+ -- non-trivial modality update, in order to handle the 'FlexRig'-s there!+ underRelevance' :: Maybe (Relevance -> r -> r)+ -- ^ Update the environment with relevance information. 'Nothing' has the identity action. NOTE:+ -- since 'Modality' contains relevances, if you implement non-trivial 'Relevance' update, you+ -- must also implement a non-trivial modality update, to handle the relevances there!+ variable' :: Int -> r -> Collect r+ -- ^ Evaluating a single variable. NOTE: you have to disambiguate bound and free variables yourself!+ -- For example, when we collect all free variables in a set, we need to store an 'Int' in the reader+ -- environment to keep track of the size of the local scope, which allows us to distinguish bound and+ -- free vars.+ ignoreSorts' :: IgnoreSorts+ -- ^ Do we want to skip over sorts of types?++ ignoreSorts' = IgnoreNot; {-# INLINE ignoreSorts' #-}+ underConstructor' _ _ r = r; {-# INLINE underConstructor' #-}+ underModality' = Nothing; {-# INLINE underModality' #-}+ underFlexRig' = Nothing; {-# INLINE underFlexRig' #-}+ underRelevance' = Nothing; {-# INLINE underRelevance' #-}++{-# INLINE underBinders #-}+underBinders :: ComputeFree r => Int -> Reader r (Collect r) -> Reader r (Collect r)+underBinders = local . underBinders'++{-# INLINE underBinder #-}+underBinder :: ComputeFree r => Reader r (Collect r) -> Reader r (Collect r)+underBinder = underBinders 1++{-# INLINE underConstructor #-}+underConstructor :: ComputeFree r => ConHead -> Elims -> Reader r (Collect r) -> Reader r (Collect r)+underConstructor hd es = local (underConstructor' hd es)++{-# INLINE underModality #-}+underModality :: ComputeFree r => Modality -> Reader r (Collect r) -> Reader r (Collect r)+underModality m act = case underModality' of+ Nothing -> act+ Just f -> local (f m) act++{-# INLINE underRelevance #-}+underRelevance :: ComputeFree r => Relevance -> Reader r (Collect r) -> Reader r (Collect r)+underRelevance rel act = case underRelevance' of+ Nothing -> act+ Just f -> local (f rel) act++{-# INLINE underFlexRig #-}+underFlexRig :: ComputeFree r => FlexRig -> Reader r (Collect r) -> Reader r (Collect r)+underFlexRig fr act = case underFlexRig' of+ Nothing -> act+ Just f -> local (f fr) act++{-# INLINE variable #-}+variable :: ComputeFree r => Int -> Reader r (Collect r)+variable x = variable' x <$!> ask++--------------------------------------------------------------------------------++class Free t where+ freeVars :: ComputeFree r => t -> Reader r (Collect r)++--------------------------------------------------------------------------------++instance Free Term where+ freeVars :: forall r. ComputeFree r => Term -> Reader r (Collect r)+ freeVars t = expand \ret ->++ let t' = case (underModality' @r, underFlexRig' @r) of+ (Nothing, Nothing) -> t+ _ -> unSpine t+ in case t' of+ Var n ts -> ret (variable n <> underFlexRig WeaklyRigid (freeVars ts))+ Def _ ts -> ret (underFlexRig WeaklyRigid $ freeVars ts)+ MetaV m ts -> ret (underFlexRig (Flexible (singleton m)) $ freeVars ts)++ -- λ is not considered guarding, as+ -- we cannot prove that x ≡ λy.x is impossible.+ Lam _ t -> ret (underFlexRig WeaklyRigid $ freeVars t)+ Lit _ -> ret mempty++ -- Because we are not in TCM+ -- we cannot query whether we are dealing with a data/record (strongly r.)+ -- or a definition by pattern matching (weakly rigid)+ -- thus, we approximate, losing that x = List x is unsolvable+ Con c _ ts -> ret (underConstructor c ts $ freeVars ts)+ -- Pi is not guarding, since we cannot prove that A ≡ B → A is impossible.+ -- Even as we do not permit infinite type expressions,+ -- we cannot prove their absence (as Set is not inductive).+ -- Also, this is incompatible with univalence (HoTT).++ -- András 2026-01-22: the above comment is wrong if we use occurrence computation in RHS unification+ Pi a b -> ret $ freeVars (a, b)+ Sort s -> ret $ underRelevance shapeIrrelevant (freeVars s)+ Level l -> ret $ freeVars l+ DontCare mt -> ret $ underModality (Modality irrelevant unitQuantity unitCohesion unitPolarity) $ freeVars mt+ Dummy{} -> ret $ mempty++instance Free t => Free (Elim' t) where+ freeVars e = expand \ret -> case e of+ Apply t -> ret $ freeVars t+ Proj{} -> ret $ mempty+ IApply x y r -> ret $ freeVars (x,y,r)++instance Free t => Free (Type' t) where+ freeVars :: forall r. ComputeFree r => Type' t -> Reader r (Collect r)+ freeVars ty = expand \ret -> case ty of+ El s t -> case ignoreSorts' @r of+ IgnoreNot -> ret $ freeVars (s, t)+ _ -> ret $ freeVars t++instance Free Sort where+ freeVars :: forall r. ComputeFree r => Sort -> Reader r (Collect r)+ freeVars s = expand \ret ->+ case ignoreSorts' @r of+ IgnoreAll -> ret mempty+ _ -> case s of+ Univ _ a -> ret $ freeVars a+ Inf _ _ -> ret $ mempty+ SizeUniv -> ret $ mempty+ LockUniv -> ret $ mempty+ LevelUniv -> ret $ mempty+ IntervalUniv -> ret $ mempty+ PiSort _c a s1 s2 -> ret $+ -- We ignore variables in the blocked dependency check+ underFlexRig (Flexible mempty) (freeVars $ unDom a) <>+ underFlexRig WeaklyRigid (freeVars (s1, s2))+ FunSort s1 s2 -> ret $ freeVars s1 <> freeVars s2+ UnivSort s -> ret $ underFlexRig WeaklyRigid $ freeVars s+ MetaS x es -> ret $ underFlexRig (Flexible $ singleton x) $ freeVars es+ DefS _ es -> ret $ underFlexRig WeaklyRigid $ freeVars es+ DummyS{} -> ret $ mempty++instance Free t => Free (Maybe t) where+ freeVars mt = expand \ret -> case mt of+ Nothing -> ret mempty+ Just t -> ret $ freeVars t++instance Free t => Free [t] where+ freeVars ts = expand \ret -> case ts of+ [] -> ret mempty+ t:ts -> ret $ freeVars t <> freeVars ts++instance Free t => Free (List1 t) where+ freeVars ts = expand \ret -> case ts of+ t :| ts -> ret $ freeVars t <> freeVars ts++instance (Free a, Free b) => Free (a, b) where+ {-# INLINE freeVars #-}+ freeVars ab = expand \ret -> case ab of (a, b) -> ret $ freeVars a <> freeVars b++instance (Free a, Free b, Free c) => Free (a, b, c) where+ {-# INLINE freeVars #-}+ freeVars abc = expand \ret -> case abc of (a, b, c) -> ret $ freeVars a <> freeVars b <> freeVars c++instance (Free a, Free b, Free c, Free d) => Free (a, b, c, d) where+ {-# INLINE freeVars #-}+ freeVars abc = expand \ret -> case abc of+ (a, b, c, d) -> ret $ freeVars a <> freeVars b <> freeVars c <> freeVars d++instance (Free a, Free b, Free c, Free d, Free e) => Free (a, b, c, d, e) where+ {-# INLINE freeVars #-}+ freeVars abc = expand \ret -> case abc of+ (a, b, c, d, e) -> ret $ freeVars a <> freeVars b <> freeVars c <> freeVars d <> freeVars e++instance Free Level where+ {-# INLINE freeVars #-}+ freeVars l = expand \ret -> case l of Max _ as -> ret $ freeVars as++instance Free t => Free (PlusLevel' t) where+ {-# INLINE freeVars #-}+ freeVars pl = expand \ret -> case pl of Plus _ l -> ret $ freeVars l++instance Free t => Free (Arg t) where+ {-# INLINE freeVars #-}+ freeVars t = expand \ret ->+ ret $ underModality (getModality t) $ freeVars $ unArg t++instance Free t => Free (Dom t) where+ {-# INLINE freeVars #-}+ freeVars d = expand \ret -> ret $ freeVars (domTactic d, unDom d)++instance Free t => Free (Abs t) where+ freeVars t = expand \ret -> case t of+ Abs _ b -> ret $ underBinder $ freeVars b+ NoAbs _ b -> ret $ freeVars b++instance Free t => Free (Tele t) where+ freeVars tel = expand \ret -> case tel of+ EmptyTel -> ret $ mempty+ ExtendTel t tel -> ret $ freeVars (t, tel)++instance Free Clause where+ freeVars cl = expand \ret ->+ ret $ underBinders (size $ clauseTel cl) $ freeVars $ clauseBody cl++instance Free EqualityView where+ freeVars ev = expand \ret -> case ev of+ OtherType t -> ret $ freeVars t+ IdiomType t -> ret $ freeVars t+ EqualityType _r s _eq l t a b -> ret $ freeVars (s, l, (t, a, b))++-- | Only computes free variables that are not pattern variables (see+-- 'nlPatVars')+-- i.e., those in a 'PTerm' or 'PBoundVar's from the local context.+instance Free NLPat where+ freeVars p = expand \ret -> case p of+ PVar{} -> ret $ mempty+ PDef _ es -> ret $ freeVars es+ PLam _ u -> ret $ freeVars u+ PPi a b -> ret $ freeVars (a,b)+ PSort s -> ret $ freeVars s+ PBoundVar x es -> ret $ variable x <> freeVars es+ PTerm t -> ret $ freeVars t++instance Free NLPType where+ freeVars :: forall r. ComputeFree r => NLPType -> Reader r (Collect r)+ freeVars t = expand \ret -> case t of+ NLPType s a -> case ignoreSorts' @r of+ IgnoreAll -> ret $ freeVars a+ _ -> ret $ freeVars (s, a)++instance Free NLPSort where+ freeVars :: forall r. ComputeFree r => NLPSort -> Reader r (Collect r)+ freeVars s = expand \ret -> case ignoreSorts' @r of+ IgnoreAll -> ret mempty+ _ -> case s of+ PUniv _ l -> ret $ freeVars l+ PInf f n -> ret $ mempty+ PSizeUniv -> ret $ mempty+ PLockUniv -> ret $ mempty+ PLevelUniv -> ret $ mempty+ PIntervalUniv -> ret $ mempty++instance Free RewriteHead where+ freeVars h = expand \ret -> case h of+ RewDefHead f -> ret mempty+ RewVarHead x -> ret $ variable x++instance Free RewriteRule where+ freeVars rew = expand \ret -> case rew of+ RewriteRule gamma h ps rhs b -> ret $+ freeVars gamma <> freeVars h <>+ underBinders (size gamma) (freeVars ps <> freeVars rhs <> freeVars b)++instance Free LocalEquation where+ freeVars eq = expand \ret -> case eq of+ LocalEquation gamma lhs rhs b -> ret $+ freeVars gamma <>+ underBinders (size gamma) (freeVars lhs <> freeVars rhs <> freeVars b)++{-# INLINE defaultUnderConstructor #-}+defaultUnderConstructor :: (Semigroup a, LensFlexRig r a) => ConHead -> Elims -> r -> r+defaultUnderConstructor c h = over lensFlexRig (composeFlexRig (constructorFlexRig c h))++{-# INLINE defaultUnderFlexRig #-}+defaultUnderFlexRig :: (Semigroup a, LensFlexRig r a) => Maybe (FlexRig' a -> r -> r)+defaultUnderFlexRig = Just \fr -> over lensFlexRig (composeFlexRig fr)++{-# INLINE defaultUnderModality #-}+defaultUnderModality :: LensModality r => Maybe (Modality -> r -> r)+defaultUnderModality = Just \m -> mapModality (composeModality m)++{-# INLINE defaultUnderRelevance #-}+defaultUnderRelevance :: LensRelevance r => Maybe (Relevance -> r -> r)+defaultUnderRelevance = Just \rel -> mapRelevance (composeRelevance rel)
− src/full/Agda/TypeChecking/Free/Lazy.hs
@@ -1,613 +0,0 @@---- | Computing the free variables of a term lazily.------ We implement a reduce (traversal into monoid) over internal syntax--- for a generic collection (monoid with singletons). This should allow--- a more efficient test for the presence of a particular variable.------ Worst-case complexity does not change (i.e. the case when a variable--- does not occur), but best case-complexity does matter. For instance,--- see 'Agda.TypeChecking.Substitute.mkAbs': each time we construct--- a dependent function type, we check whether it is actually dependent.------ The distinction between rigid and strongly rigid occurrences comes from:--- Jason C. Reed, PhD thesis, 2009, page 96 (see also his LFMTP 2009 paper)------ The main idea is that x = t(x) is unsolvable if x occurs strongly rigidly--- in t. It might have a solution if the occurrence is not strongly rigid, e.g.------ x = \f -> suc (f (x (\ y -> k))) has x = \f -> suc (f (suc k))------ [Jason C. Reed, PhD thesis, page 106]------ Under coinductive constructors, occurrences are never strongly rigid.--- Also, function types and lambdas do not establish strong rigidity.--- Only inductive constructors do so.--- (See issue 1271).------ For further reading on semirings and semimodules for variable occurrence,--- see e.g. Conor McBrides "I got plenty of nuttin'" (Wadlerfest 2016).--- There, he treats the "quantity" dimension of variable occurrences.------ The semiring has an additive operation for combining occurrences of subterms,--- and a multiplicative operation of representing function composition. E.g.--- if variable @x@ appears @o@ in term @u@, but @u@ appears in context @q@ in--- term @t@ then occurrence of variable @x@ coming from @u@ is accounted for--- as @q o@ in @t@.------ Consider example @(λ{ x → (x,x)}) y@:------ * Variable @x@ occurs once unguarded in @x@.------ * It occurs twice unguarded in the aggregation @x@ @x@------ * Inductive constructor @,@ turns this into two strictly rigid occurrences.------ If @,@ is a record constructor, then we stay unguarded.------ * The function @({λ x → (x,x)})@ provides a context for variable @y@.--- This context can be described as weakly rigid with quantity two.------ * The final occurrence of @y@ is obtained as composing the context with--- the occurrence of @y@ in itself (which is the unit for composition).--- Thus, @y@ occurs weakly rigid with quantity two.------ It is not a given that the context can be described in the same way--- as the variable occurrence. However, for quantity it is the case--- and we obtain a semiring of occurrences with 0, 1, and even ω, which--- is an absorptive element for addition.--module Agda.TypeChecking.Free.Lazy where--import Control.Applicative hiding (empty)-import Control.Monad.Reader ( MonadReader(..), asks, ReaderT, Reader, runReader )--import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-import Data.HashSet (HashSet)-import qualified Data.HashSet as HashSet-import Data.Set (Set)-import qualified Data.Set as Set---import Agda.Syntax.Common-import Agda.Syntax.Internal--import Agda.Utils.Functor-import Agda.Utils.Lens-import Agda.Utils.List1 (List1)-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Semigroup-import Agda.Utils.Singleton-import Agda.Utils.Size-------------------------------------------------------------------------------- * Set of meta variables.---- | A set of meta variables. Forms a monoid under union.--newtype MetaSet = MetaSet { theMetaSet :: HashSet MetaId }- deriving (Eq, Show, Null, Semigroup, Monoid)--instance Singleton MetaId MetaSet where- singleton = MetaSet . singleton--insertMetaSet :: MetaId -> MetaSet -> MetaSet-insertMetaSet m (MetaSet ms) = MetaSet $ HashSet.insert m ms--foldrMetaSet :: (MetaId -> a -> a) -> a -> MetaSet -> a-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)---- | Depending on the surrounding context of a variable,--- it's occurrence can be classified as flexible or rigid,--- with finer distinctions.------ The constructors are listed in increasing order (wrt. information content).-data FlexRig' a- = Flexible a -- ^ In arguments of metas.- -- The set of metas is used by ''Agda.TypeChecking.Rewriting.NonLinMatch''- -- to generate the right blocking information.- -- The semantics is that the status of a variable occurrence may change- -- if one of the metas in the set gets solved. We may say the occurrence- -- is tainted by the meta variables in the set.- | WeaklyRigid -- ^ In arguments to variables and definitions.- | Unguarded -- ^ In top position, or only under inductive record constructors (unit).- | StronglyRigid -- ^ Under at least one and only inductive constructors.- deriving (Eq, Show, Functor, Foldable)--type FlexRig = FlexRig' MetaSet--class LensFlexRig o a | o -> a where- lensFlexRig :: Lens' o (FlexRig' a)--instance LensFlexRig (FlexRig' a) a where- lensFlexRig = id--isFlexible :: LensFlexRig o a => o -> Bool-isFlexible o = case o ^. lensFlexRig of- Flexible {} -> True- _ -> False--isUnguarded :: LensFlexRig o a => o -> Bool-isUnguarded o = case o ^. lensFlexRig of- Unguarded -> True- _ -> False--isWeaklyRigid :: LensFlexRig o a => o -> Bool-isWeaklyRigid o = case o ^. lensFlexRig of- WeaklyRigid -> True- _ -> False--isStronglyRigid :: LensFlexRig o a => o -> Bool-isStronglyRigid o = case o ^. lensFlexRig of- StronglyRigid -> True- _ -> False---- | 'FlexRig' aggregation (additive operation of the semiring).--- For combining occurrences of the same variable in subterms.--- This is a refinement of the 'max' operation for 'FlexRig'--- which would work if 'Flexible' did not have the 'MetaSet' as an argument.--- Now, to aggregate two 'Flexible' occurrences, we union the involved 'MetaSet's.--addFlexRig :: Semigroup a => FlexRig' a -> FlexRig' a -> FlexRig' a-addFlexRig = curry $ \case- -- StronglyRigid is dominant- (StronglyRigid, _) -> StronglyRigid- (_, StronglyRigid) -> StronglyRigid- -- Next is Unguarded- (Unguarded, _) -> Unguarded- (_, Unguarded) -> Unguarded- -- Then WeaklyRigid- (WeaklyRigid, _) -> WeaklyRigid- (_, WeaklyRigid) -> WeaklyRigid- -- Least is Flexible. We union the meta sets, as the variable- -- is tainted by all of the involved meta variable.- (Flexible ms1, Flexible ms2) -> Flexible $ ms1 <> ms2---- | Unit for 'addFlexRig'.-zeroFlexRig :: Monoid a => FlexRig' a-zeroFlexRig = Flexible mempty---- | Absorptive for 'addFlexRig'.-omegaFlexRig :: FlexRig' a-omegaFlexRig = StronglyRigid---- | 'FlexRig' composition (multiplicative operation of the semiring).--- For accumulating the context of a variable.------ 'Flexible' is dominant. Once we are under a meta, we are flexible--- regardless what else comes. We taint all variable occurrences--- under a meta by this meta.------ 'WeaklyRigid' is next in strength. Destroys strong rigidity.------ 'StronglyRigid' is still dominant over 'Unguarded'.------ 'Unguarded' is the unit. It is the top (identity) context.----composeFlexRig :: Semigroup a => FlexRig' a -> FlexRig' a -> FlexRig' a-composeFlexRig = curry $ \case- (Flexible ms1, Flexible ms2) -> Flexible $ ms1 <> ms2- (Flexible ms1, _) -> Flexible ms1- (_, Flexible ms2) -> Flexible ms2- (WeaklyRigid, _) -> WeaklyRigid- (_, WeaklyRigid) -> WeaklyRigid- (StronglyRigid, _) -> StronglyRigid- (_, StronglyRigid) -> StronglyRigid- (Unguarded, Unguarded) -> Unguarded---- | Unit for 'composeFlexRig'.-oneFlexRig :: FlexRig' a-oneFlexRig = Unguarded-------------------------------------------------------------------------------- * Multi-dimensional feature vector for variable occurrence (semigroup)---- | Occurrence of free variables is classified by several dimensions.--- Currently, we have 'FlexRig' and 'Modality'.-data VarOcc' a = VarOcc- { varFlexRig :: FlexRig' a- , varModality :: Modality- }- deriving (Show)-type VarOcc = VarOcc' MetaSet---- | Equality up to origin.-instance Eq a => Eq (VarOcc' a) where- VarOcc fr m == VarOcc fr' m' = fr == fr' && sameModality m m'--instance LensModality (VarOcc' a) where- getModality = varModality- mapModality f (VarOcc x r) = VarOcc x $ f r--instance LensRelevance (VarOcc' a) where-instance LensQuantity (VarOcc' a) where---- | Access to 'varFlexRig' in 'VarOcc'.-instance LensFlexRig (VarOcc' a) a where- lensFlexRig f (VarOcc fr m) = f fr <&> \ fr' -> VarOcc fr' m--- lensFlexRig :: Lens' (VarOcc' a) (FlexRig' a)--- lensFlexRig f (VarOcc fr m) = f fr <&> \ fr' -> VarOcc fr' m----- | The default way of aggregating free variable info from subterms is by adding--- the variable occurrences. For instance, if we have a pair @(t₁,t₂)@ then--- and @t₁@ has @o₁@ the occurrences of a variable @x@--- and @t₂@ has @o₂@ the occurrences of the same variable, then--- @(t₁,t₂)@ has @mappend o₁ o₂@ occurrences of that variable.------ From counting 'Quantity', we extrapolate this to 'FlexRig' and 'Relevance':--- we care most about about 'StronglyRigid' 'Relevant' occurrences.--- E.g., if @t₁@ has a 'StronglyRigid' occurrence and @t₂@ a 'Flexible' occurrence,--- then @(t₁,t₂)@ still has a 'StronglyRigid' occurrence.--- Analogously, @Relevant@ occurrences count most, as we wish e.g. to forbid--- relevant occurrences of variables that are declared to be irrelevant.------ 'VarOcc' forms a semiring, and this monoid is the addition of the semiring.--instance Semigroup a => Semigroup (VarOcc' a) where- VarOcc o m <> VarOcc o' m' = VarOcc (addFlexRig o o') (addModality m m')---- | The neutral element for variable occurrence aggregation is least serious--- occurrence: flexible, irrelevant.--- This is also the absorptive element for 'composeVarOcc', if we ignore--- the 'MetaSet' in 'Flexible'.-instance (Semigroup a, Monoid a) => Monoid (VarOcc' a) where- mempty = VarOcc (Flexible mempty) zeroModality- mappend = (<>)---- | The absorptive element of variable occurrence under aggregation:--- strongly rigid, relevant.-topVarOcc :: VarOcc' a-topVarOcc = VarOcc StronglyRigid topModality---- | First argument is the outer occurrence (context) and second is the inner.--- This multiplicative operation is to modify an occurrence under a context.-composeVarOcc :: Semigroup a => VarOcc' a -> VarOcc' a -> VarOcc' a-composeVarOcc (VarOcc o m) (VarOcc o' m') = VarOcc (composeFlexRig o o') (composeModality m m')- -- We use the multipicative modality monoid (composition).--oneVarOcc :: VarOcc' a-oneVarOcc = VarOcc Unguarded unitModality-------------------------------------------------------------------------------- * Storing variable occurrences (semimodule).---- | Any representation @c@ of a set of variables need to be able to be modified by--- a variable occurrence. This is to ensure that free variable analysis is--- compositional. For instance, it should be possible to compute `fv (v [u/x])`--- from `fv v` and `fv u`.------ In algebraic terminology, a variable set @a@ needs to be (almost) a left semimodule--- to the semiring 'VarOcc'.-class (Singleton MetaId a, Semigroup a, Monoid a, Semigroup c, Monoid c) => IsVarSet a c | c -> a where- -- | Laws- -- * Respects monoid operations:- -- ```- -- withVarOcc o mempty == mempty- -- withVarOcc o (x <> y) == withVarOcc o x <> withVarOcc o y- -- ```- -- * Respects VarOcc composition:- -- ```- -- withVarOcc oneVarOcc = id- -- withVarOcc (composeVarOcc o1 o2) = withVarOcc o1 . withVarOcc o2- -- ```- -- * Respects VarOcc aggregation:- -- ```- -- withVarOcc (o1 <> o2) x = withVarOcc o1 x <> withVarOcc o2 x- -- ```- -- Since the corresponding unit law may fail,- -- ```- -- withVarOcc mempty x = mempty- -- ```- -- it is not quite a semimodule.- withVarOcc :: VarOcc' a -> c -> c---- | Representation of a variable set as map from de Bruijn indices--- to 'VarOcc'.-type TheVarMap' a = IntMap (VarOcc' a)-newtype VarMap' a = VarMap { theVarMap :: TheVarMap' a }- deriving (Eq, Show)--type TheVarMap = TheVarMap' MetaSet-type VarMap = VarMap' MetaSet---- | A "set"-style 'Singleton' instance with default/initial variable occurrence.-instance Singleton Variable (VarMap' a) where- singleton i = VarMap $ IntMap.singleton i oneVarOcc--mapVarMap :: (TheVarMap' a -> TheVarMap' b) -> VarMap' a -> VarMap' b-mapVarMap f = VarMap . f . theVarMap--lookupVarMap :: Variable -> VarMap' a -> Maybe (VarOcc' a)-lookupVarMap i = IntMap.lookup i . theVarMap---- Andreas & Jesper, 2018-05-11, issue #3052:---- | Proper monoid instance for @VarMap@ rather than inheriting the broken one from IntMap.--- We combine two occurrences of a variable using 'mappend'.-instance Semigroup a => Semigroup (VarMap' a) where- VarMap m <> VarMap m' = VarMap $ IntMap.unionWith (<>) m m'--instance Semigroup a => Monoid (VarMap' a) where- mempty = VarMap IntMap.empty- mappend = (<>)- mconcat = VarMap . IntMap.unionsWith (<>) . map theVarMap- -- mconcat = VarMap . IntMap.unionsWith mappend . coerce -- ghc 8.6.5 does not seem to like this coerce--instance (Singleton MetaId a, Semigroup a, Monoid a) => IsVarSet a (VarMap' a) where- withVarOcc o = mapVarMap $ fmap $ composeVarOcc o--------------------------------------------------------------------------------- * Simple flexible/rigid variable collection.---- | Keep track of 'FlexRig' for every variable, but forget the involved meta vars.-type TheFlexRigMap = IntMap (FlexRig' ())-newtype FlexRigMap = FlexRigMap { theFlexRigMap :: TheFlexRigMap }- deriving (Show, Singleton (Variable, FlexRig' ()))--mapFlexRigMap :: (TheFlexRigMap -> TheFlexRigMap) -> FlexRigMap -> FlexRigMap-mapFlexRigMap f = FlexRigMap . f . theFlexRigMap--instance Semigroup FlexRigMap where- FlexRigMap m <> FlexRigMap m' = FlexRigMap $ IntMap.unionWith addFlexRig m m'--instance Monoid FlexRigMap where- mempty = FlexRigMap IntMap.empty- mappend = (<>)- mconcat = FlexRigMap . IntMap.unionsWith addFlexRig . map theFlexRigMap---- | Compose everything with the 'varFlexRig' part of the 'VarOcc'.-instance IsVarSet () FlexRigMap where- withVarOcc o = mapFlexRigMap $ fmap $ composeFlexRig $ () <$ varFlexRig o--instance Singleton MetaId () where- singleton _ = ()-------------------------------------------------------------------------------- * Environment for collecting free variables.---- | Where should we skip sorts in free variable analysis?--data IgnoreSorts- = IgnoreNot -- ^ Do not skip.- | IgnoreInAnnotations -- ^ Skip when annotation to a type.- | IgnoreAll -- ^ Skip unconditionally.- deriving (Eq, Show)---- | The current context.--data FreeEnv' a b c = FreeEnv- { feExtra :: !b- -- ^ Additional context, e.g., whether to ignore free variables in sorts.- , feFlexRig :: !(FlexRig' a)- -- ^ Are we flexible or rigid?- , feModality :: !Modality- -- ^ What is the current relevance and quantity?- , feSingleton :: Maybe Variable -> c- -- ^ Method to return a single variable.- }--type Variable = Int-type SingleVar c = Variable -> c--type FreeEnv c = FreeEnv' MetaSet IgnoreSorts c---- | Ignore free variables in sorts.-feIgnoreSorts :: FreeEnv' a IgnoreSorts c -> IgnoreSorts-feIgnoreSorts = feExtra--instance LensFlexRig (FreeEnv' a b c) a where- lensFlexRig f e = f (feFlexRig e) <&> \ fr -> e { feFlexRig = fr }--instance LensModality (FreeEnv' a b c) where- getModality = feModality- mapModality f e = e { feModality = f (feModality e) }--instance LensRelevance (FreeEnv' a b c) where-instance LensQuantity (FreeEnv' a b c) where---- | The initial context.--initFreeEnv :: Monoid c => b -> SingleVar c -> FreeEnv' a b c-initFreeEnv e sing = FreeEnv- { feExtra = e- , feFlexRig = Unguarded- , feModality = unitModality -- multiplicative monoid- , feSingleton = maybe mempty sing- }--type FreeT a b m c = ReaderT (FreeEnv' a b c) m c-type FreeM a c = Reader (FreeEnv' a IgnoreSorts c) c---- | Run function for FreeM.-runFreeM :: IsVarSet a c => SingleVar c -> IgnoreSorts -> FreeM a c -> c-runFreeM single i m = runReader m $ initFreeEnv i single--instance (Functor m, Applicative m, Monad m, Semigroup c, Monoid c) => Monoid (FreeT a b m c) where- mempty = pure mempty- mappend = (<>)- mconcat = mconcat <.> sequence---- | Base case: a variable.-variable :: (Monad m, IsVarSet a c) => Int -> FreeT a b m c-variable n = do- o <- asks feFlexRig- r <- asks feModality- s <- asks feSingleton- return $ withVarOcc (VarOcc o r) (s $ Just n)---- | Subtract, but return Nothing if result is negative.-subVar :: Int -> Maybe Variable -> Maybe Variable--- subVar n x = x >>= \ i -> (i - n) <$ guard (n <= i)-subVar n x = do- i <- x- guard $ i >= n- return $ i - n---- | Going under a binder.-underBinder :: MonadReader (FreeEnv' a b c) m => m z -> m z-underBinder = underBinder' 1---- | Going under @n@ binders.-underBinder' :: MonadReader (FreeEnv' a b c) m => Nat -> m z -> m z-underBinder' n = local $ \ e -> e { feSingleton = feSingleton e . subVar n }---- | Changing the 'Modality'.-underModality :: (MonadReader r m, LensModality r, LensModality o) => o -> m z -> m z-underModality = local . mapModality . composeModality . getModality---- | Changing the 'Relevance'.-underRelevance :: (MonadReader r m, LensRelevance r, LensRelevance o) => o -> m z -> m z-underRelevance = local . mapRelevance . composeRelevance . getRelevance---- | In the given computation the 'Quantity' is locally scaled using--- the 'Quantity' of the first argument.-underQuantity ::- (MonadReader r m, LensQuantity r, LensQuantity o) => o -> m a -> m a-underQuantity = local . mapQuantity . composeQuantity . getQuantity---- | Changing the 'FlexRig' context.-underFlexRig :: (MonadReader r m, LensFlexRig r a, Semigroup a, LensFlexRig o a) => o -> m z -> m z-underFlexRig = local . over lensFlexRig . composeFlexRig . view lensFlexRig---- | What happens to the variables occurring under a constructor?-underConstructor :: (MonadReader r m, LensFlexRig r a, Semigroup a) => ConHead -> Elims -> m z -> m z-underConstructor (ConHead _c _d i fs) es =- case i of- -- Coinductive (record) constructors admit infinite cycles:- CoInductive -> underFlexRig WeaklyRigid- -- Inductive constructors do not admit infinite cycles:- Inductive | natSize es == natSize fs -> underFlexRig StronglyRigid- | otherwise -> underFlexRig WeaklyRigid- -- Jesper, 2020-10-22: Issue #4995: treat occurrences in non-fully- -- applied constructors as weakly rigid.- -- Ulf, 2019-10-18: Now the termination checker treats inductive recursive records- -- the same as datatypes, so absense of infinite cycles can be proven in Agda, and thus- -- the unifier is allowed to do it too. Test case: test/Succeed/Issue1271a.agda- -- WAS:- -- -- Inductive record constructors do not admit infinite cycles,- -- -- but this cannot be proven inside Agda.- -- -- Thus, unification should not prove it either.-------------------------------------------------------------------------------- * Recursively collecting free variables.---- | Gather free variables in a collection.-class Free t where- -- Misplaced SPECIALIZE pragma:- -- {-# SPECIALIZE freeVars' :: a -> FreeM Any #-}- -- So you cannot specialize all instances in one go. :(- freeVars' :: IsVarSet a c => t -> FreeM a c-- default freeVars' :: (t ~ f b, Foldable f, Free b) => IsVarSet a c => t -> FreeM a c- freeVars' = foldMap freeVars'---instance Free Term where- -- SPECIALIZE instance does not work as well, see- -- https://ghc.haskell.org/trac/ghc/ticket/10434#ticket- -- {-# SPECIALIZE instance Free Term All #-}- -- {-# SPECIALIZE freeVars' :: Term -> FreeM Any #-}- -- {-# SPECIALIZE freeVars' :: Term -> FreeM All #-}- -- {-# SPECIALIZE freeVars' :: Term -> FreeM VarSet #-}- freeVars' t = case unSpine t of -- #4484: unSpine to avoid projected variables being treated as StronglyRigid- Var n ts -> variable n `mappend` do underFlexRig WeaklyRigid $ freeVars' ts- -- λ is not considered guarding, as- -- we cannot prove that x ≡ λy.x is impossible.- Lam _ t -> underFlexRig WeaklyRigid $ freeVars' t- Lit _ -> mempty- Def _ ts -> underFlexRig WeaklyRigid $ freeVars' ts -- because we are not in TCM- -- we cannot query whether we are dealing with a data/record (strongly r.)- -- or a definition by pattern matching (weakly rigid)- -- thus, we approximate, losing that x = List x is unsolvable- Con c _ ts -> underConstructor c ts $ freeVars' ts- -- Pi is not guarding, since we cannot prove that A ≡ B → A is impossible.- -- Even as we do not permit infinite type expressions,- -- we cannot prove their absence (as Set is not inductive).- -- Also, this is incompatible with univalence (HoTT).- Pi a b -> freeVars' (a,b)- Sort s -> freeVars' s- Level l -> freeVars' l- MetaV m ts -> underFlexRig (Flexible $ singleton m) $ freeVars' ts- DontCare mt -> underModality (Modality irrelevant unitQuantity unitCohesion unitPolarity) $ freeVars' mt- Dummy{} -> mempty--instance Free t => Free (Type' t) where- freeVars' (El s t) =- ifM (asks ((IgnoreNot ==) . feIgnoreSorts))- {- then -} (freeVars' (s, t))- {- else -} (freeVars' t)--instance Free Sort where- freeVars' s =- ifM (asks ((IgnoreAll ==) . feIgnoreSorts)) mempty $ {- else -}- case s of- Univ _ a -> freeVars' a- Inf _ _ -> mempty- SizeUniv -> mempty- LockUniv -> mempty- LevelUniv -> 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- UnivSort s -> underFlexRig WeaklyRigid $ freeVars' s- MetaS x es -> underFlexRig (Flexible $ singleton x) $ freeVars' es- DefS _ es -> underFlexRig WeaklyRigid $ freeVars' es- DummyS{} -> mempty--instance Free Level where- freeVars' (Max _ as) = freeVars' as--instance Free t => Free (PlusLevel' t) where- freeVars' (Plus _ l) = freeVars' l--instance Free t => Free [t]-instance Free t => Free (List1 t)-instance Free t => Free (Maybe t)-instance Free t => Free (WithHiding t)-instance Free t => Free (Named nm t)-instance Free t => Free (Ranged t)--instance (Free t, Free u) => Free (t, u) where- freeVars' (t, u) = freeVars' t `mappend` freeVars' u--instance (Free t, Free u, Free v) => Free (t, u, v) where- freeVars' (t, u, v) = freeVars' t `mappend` freeVars' u `mappend` freeVars' v--instance Free t => Free (Elim' t) where- freeVars' (Apply t) = freeVars' t- freeVars' (Proj{} ) = mempty- freeVars' (IApply x y r) = freeVars' (x,y,r)--instance Free t => Free (Arg t) where- freeVars' t = underModality (getModality t) $ freeVars' $ unArg t--instance Free t => Free (Dom t) where- freeVars' d = freeVars' (domTactic d, unDom d)--instance Free t => Free (Abs t) where- freeVars' (Abs _ b) = underBinder $ freeVars' b- freeVars' (NoAbs _ b) = freeVars' b--instance Free t => Free (Tele t) where- freeVars' EmptyTel = mempty- freeVars' (ExtendTel t tel) = freeVars' (t, tel)--instance Free Clause where- freeVars' cl = underBinder' (size $ clauseTel cl) $ freeVars' $ clauseBody cl--instance Free EqualityView where- freeVars' = \case- OtherType t -> freeVars' t- IdiomType t -> freeVars' t- EqualityType _r s _eq l t a b -> freeVars' (s, l, [t, a, b])
src/full/Agda/TypeChecking/Free/Precompute.hs view
@@ -1,12 +1,18 @@+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wunused-imports #-} +#if __GLASGOW_HASKELL__ > 902+{-# OPTIONS_GHC -fworker-wrapper-cbv #-}+#endif+ -- | Precompute free variables in a term (and store in 'ArgInfo'). module Agda.TypeChecking.Free.Precompute ( PrecomputeFreeVars, precomputeFreeVars , precomputedFreeVars, precomputeFreeVars_ ) where -import Control.Monad.Writer ( Writer, runWriter, censor, listen, tell )+import Agda.Utils.StrictWriter ( Writer, runWriter, censor, listen, tell ) +import Agda.Utils.Singleton import Agda.Utils.VarSet (VarSet) import qualified Agda.Utils.VarSet as VarSet @@ -50,14 +56,14 @@ instance PrecomputeFreeVars a => PrecomputeFreeVars (Abs a) where precomputeFreeVars (NoAbs x b) = NoAbs x <$> precomputeFreeVars b precomputeFreeVars (Abs x b) =- censor (VarSet.subtract 1 . VarSet.delete 0) $+ censor (VarSet.strengthen 1) $ Abs x <$> precomputeFreeVars b instance PrecomputeFreeVars Term where precomputeFreeVars t = case t of Var x es -> do- tell (VarSet.singleton x)+ tell (singleton x) Var x <$> precomputeFreeVars es Lam i b -> Lam i <$> precomputeFreeVars b Lit{} -> pure t@@ -81,7 +87,9 @@ LockUniv -> pure s LevelUniv -> pure s IntervalUniv -> pure s- PiSort a s1 s2 -> PiSort <$> precomputeFreeVars a <*> precomputeFreeVars s1 <*> precomputeFreeVars s2+ PiSort c a s1 s2 -> PiSort c <$>+ precomputeFreeVars a <*>+ precomputeFreeVars s1 <*> precomputeFreeVars s2 FunSort s1 s2 -> uncurry FunSort <$> precomputeFreeVars (s1, s2) UnivSort s -> UnivSort <$> precomputeFreeVars s MetaS x es -> MetaS x <$> precomputeFreeVars es
src/full/Agda/TypeChecking/Free/Reduce.hs view
@@ -1,23 +1,31 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE MagicHash #-} {-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wno-redundant-bang-patterns #-} +#if __GLASGOW_HASKELL__ > 902+{-# OPTIONS_GHC -fworker-wrapper-cbv #-}+#endif+ -- | Free variable check that reduces the subject to make certain variables not -- free. Used when pruning metavariables in Agda.TypeChecking.MetaVars.Occurs. module Agda.TypeChecking.Free.Reduce ( ForceNotFree , forceNotFree+ , forceNonDep+ , forceNonDepSort , reallyFree , IsFree(..)+ , nonFreeVars ) where import Prelude hiding (null) -import Control.Monad.Reader-import Control.Monad.State--import qualified Data.IntMap as IntMap-import Data.IntMap (IntMap)-import qualified Data.IntSet as IntSet-import Data.IntSet (IntSet)+import Data.Maybe+import qualified Data.IntMap.Strict as IntMap+import Data.IntMap.Strict (IntMap)+import GHC.Exts import Agda.Syntax.Common import Agda.Syntax.Internal@@ -25,97 +33,142 @@ import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Free+import Agda.TypeChecking.Free.Base (constructorFlexRig, addFlexRig, oneFlexRig) import Agda.TypeChecking.Free.Precompute -import Agda.Utils.Monad-import Agda.Utils.Null+import qualified Agda.Utils.VarSet as VarSet+import Agda.Utils.VarSet (VarSet)+import Agda.Utils.StrictState+import Agda.Utils.StrictReader+import Agda.Utils.ExpandCase+import Agda.Utils.Singleton+import Agda.Utils.Impossible + -- | A variable can either not occur (`NotFree`) or it does occur -- (`MaybeFree`). In the latter case, the occurrence may disappear -- depending on the instantiation of some set of metas. data IsFree- = MaybeFree MetaSet+ = MaybeFree FlexRig | NotFree deriving (Eq, Show) +-- local scope size, VarSet to enforce not occurring, FlexRig we're under, ReduceEnv+-- András, 2026-02-12: the ReduceEnv is put in the FREnv because I don't want to bother+-- fixing GHC code generation (i.e. not returning closures from case splits) for ReduceM.+data FREnv = FREnv Int VarSet FlexRig ReduceEnv++-- This is equivalent to IntMap IsFree, where the NotFree cases are factored out into+-- a VarSet for efficiency.+data FRState = FRState VarSet (IntMap FlexRig)+type FreeRed = StateT FRState (Reader FREnv)++{-# SPECIALIZE forceNotFree :: VarSet -> Term -> ReduceM (IntMap IsFree, Term) #-} -- | Try to enforce a set of variables not occurring in a given -- type. Returns a possibly reduced version of the type and for each -- of the given variables whether it is either not free, or -- maybe free depending on some metavariables.-forceNotFree :: (ForceNotFree a, Reduce a, MonadReduce m)- => IntSet -> a -> m (IntMap IsFree, a)-forceNotFree xs a = do- -- Initially, all variables are marked as `NotFree`. This is changed- -- to `MaybeFree` when we find an occurrence.- let mxs = IntMap.fromSet (const NotFree) xs- (a, mxs) <- runStateT (runReaderT (forceNotFreeR $ precomputeFreeVars_ a) mempty) mxs- return (mxs, a)+forceNotFree :: (ForceNotFree a, Reduce a) => VarSet -> a -> ReduceM (IntMap IsFree, a)+forceNotFree xs a = ReduceM \env ->+ let (a', FRState notfree mxs) =+ runReader (runStateT (forceNotFreeR $ precomputeFreeVars_ a) (FRState xs mempty))+ (FREnv 0 xs oneFlexRig env) in+ let mxs' = VarSet.foldl' (\k -> IntMap.insert k NotFree) (MaybeFree <$> mxs) notfree in+ (mxs', a') +{-# SPECIALIZE reallyFree :: VarSet -> Term -> ReduceM (Either Blocked_ (Maybe Term)) #-} -- | 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 :: (Reduce a, ForceNotFree a) => VarSet -> a -> ReduceM (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')-+ MaybeFree (Flexible ms) -> do+ let !blocker = metaSetToBlocker ms+ pure $ Left $ Blocked blocker ()+ MaybeFree _ -> pure $ Right Nothing+ NotFree -> pure $ 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 (MaybeFree ms1) (MaybeFree ms2) = MaybeFree $! (ms1 `addFlexRig` ms2)+ pickFree f1 NotFree = f1 pickFree NotFree f2 = f2 -type MonadFreeRed m =- ( MonadReader MetaSet m- , MonadState (IntMap IsFree) m- , MonadReduce m- )+-- | Try to force a thing to no longer depend on the zero variable+-- Returns a possibly reduced version of the thing and whether the dependency+-- was successfully removed (i.e. the zero variable is still free)+forceNonDep :: (Reduce a, ForceNotFree a)+ => a -> ReduceM (IsFree, a)+forceNonDep x = do+ (fvm, x) <- forceNotFree (singleton 0) x+ pure (fromMaybe __IMPOSSIBLE__ $! IntMap.lookup 0 fvm, x) +-- | András 2026-02-24: we specialize this, because TypeChecking.Reduce imports it via the hs-boot+-- file, and if it's not specialized there, it is __impossible__ to specialzie by GHC.+forceNonDepSort :: Sort -> ReduceM (IsFree, Sort)+forceNonDepSort x = forceNonDep x++-- | Get the set of 'NotFree' variables from a variable map.+nonFreeVars :: IntMap IsFree -> VarSet+nonFreeVars =+ IntMap.foldlWithKey'+ (\acc k v -> case v of+ NotFree -> VarSet.insert k acc+ _ -> acc)+ mempty++ class (PrecomputeFreeVars a, Subst a) => ForceNotFree a where -- Reduce the argument if necessary, to make as many as possible of -- the variables in the state not free. Updates the state, marking -- the variables that couldn't be make not free as `MaybeFree`. By -- updating the state as soon as a variable can not be reduced away, -- we avoid trying to get rid of it in other places.- forceNotFree' :: (MonadFreeRed m) => a -> m a+ forceNotFree' :: a -> FreeRed a --- Return the set of variables for which there is still hope that they--- may not occur.-varsToForceNotFree :: (MonadFreeRed m) => m IntSet-varsToForceNotFree = gets (IntMap.keysSet . (IntMap.filter (== NotFree)))+{-# NOINLINE notFreeInPrecomputedSlow #-}+notFreeInPrecomputedSlow :: Int# -> VarSet -> VarSet -> Bool+notFreeInPrecomputedSlow locals xs precomp =+ VarSet.disjoint xs (VarSet.strengthen (I# locals) precomp) +{-# INLINE noFreeInPrecomputed #-}+noFreeInPrecomputed :: Int -> VarSet -> VarSet -> Bool+noFreeInPrecomputed (I# locals) xs precomp = case (xs, precomp) of+ -- fast path+ (VarSet.VS# xs, VarSet.VS# precomp) ->+ isTrue# ((xs `and#` (precomp `shiftRL#` locals)) `eqWord#` 0##)+ -- rare slow path+ _ -> notFreeInPrecomputedSlow locals xs precomp++{-# INLINE reduceIfFreeVars #-} -- Reduce the argument if there are offending free variables. Doesn't call the -- continuation when no reduction is required.-reduceIfFreeVars :: (Reduce a, ForceNotFree a, MonadFreeRed m)- => (a -> m a) -> a -> m a-reduceIfFreeVars k a = do- xs <- varsToForceNotFree- let fvs = precomputedFreeVars a- notfree = IntSet.disjoint xs fvs- if notfree- then return a- else k . precomputeFreeVars_ =<< reduce a+reduceIfFreeVars :: (Reduce a, ForceNotFree a) => (a -> FreeRed a) -> a -> FreeRed a+reduceIfFreeVars k = \a -> do+ FRState notfrees _ <- get+ FREnv locals _ _ env <- ask+ let fvs = precomputedFreeVars a+ if noFreeInPrecomputed locals notfrees fvs+ then pure a+ else k $ precomputeFreeVars_ (unReduceM (reduce a) env) -- Careful not to define forceNotFree' = forceNotFreeR since that would loop.-forceNotFreeR :: (Reduce a, ForceNotFree a, MonadFreeRed m)- => a -> m a+forceNotFreeR :: (Reduce a, ForceNotFree a) => a -> FreeRed a forceNotFreeR = reduceIfFreeVars forceNotFree' +{-# INLINE underFlexRig #-}+underFlexRig :: FlexRig -> FreeRed a -> FreeRed a+underFlexRig fr' = local \(FREnv x nfs fr e) -> FREnv x nfs (composeFlexRig fr' fr) e++{-# INLINE underConstructor #-}+underConstructor :: ConHead -> Elims -> FreeRed a -> FreeRed a+underConstructor c es = underFlexRig (constructorFlexRig c es)+ instance (Reduce a, ForceNotFree a) => ForceNotFree (Arg a) where -- Precomputed free variables are stored in the Arg so reduceIf outside the -- traverse.@@ -126,64 +179,80 @@ instance (Reduce a, ForceNotFree a) => ForceNotFree (Abs a) where -- Reduction stops at abstractions (lambda/pi) so do reduceIf/forceNotFreeR here.- forceNotFree' a@NoAbs{} = traverse forceNotFreeR a- forceNotFree' a@Abs{} =- -- Shift variables up when going under the abstraction and back down when- -- coming out of it. Since we never add new indices to the state- -- there's no danger of getting negative indices.- reduceIfFreeVars (bracket_ (modify $ IntMap.mapKeys succ) (\ _ -> modify $ IntMap.mapKeys pred) .- traverse forceNotFree') a+ forceNotFree' abs = expand \ret -> case abs of+ a@NoAbs{} -> ret $ traverse forceNotFreeR a+ a@(Abs x _) -> ret do+ let updEnv :: ReduceEnv -> ReduceEnv+ updEnv e = extendReduceEnv x __DUMMY_DOM__ e+ reduceIfFreeVars+ (local (\(FREnv x nfs fr e) -> FREnv (x + 1) nfs fr (updEnv e)) . traverse forceNotFree')+ a instance ForceNotFree a => ForceNotFree [a] where- forceNotFree' = traverse forceNotFree'+ forceNotFree' as = expand \ret -> case as of+ [] -> ret $ pure []+ (a:as) -> ret $ (:) <$> forceNotFree' a <*> forceNotFree' as instance (Reduce a, ForceNotFree a) => ForceNotFree (Elim' a) where -- There's an Arg inside Elim' which stores precomputed free vars, so let's -- not skip over that.- forceNotFree' (Apply arg) = Apply <$> forceNotFree' arg- forceNotFree' e@Proj{} = return e- forceNotFree' (IApply x y r) = IApply <$> forceNotFreeR x <*> forceNotFreeR y <*> forceNotFreeR r+ forceNotFree' e = expand \ret -> case e of+ Apply arg -> ret $ Apply <$> forceNotFree' arg+ e@Proj{} -> ret $ pure e+ IApply x y r -> ret $ IApply <$> forceNotFreeR x <*> forceNotFreeR y <*> forceNotFreeR r instance ForceNotFree Type where- forceNotFree' (El s t) = El <$> forceNotFree' s <*> forceNotFree' t+ forceNotFree' a = expand \ret -> case a of+ El s t -> ret $ El <$> forceNotFree' s <*> forceNotFree' t instance ForceNotFree Term where- forceNotFree' = \case- Var x es -> do- metas <- ask- modify $ IntMap.adjust (const $ MaybeFree metas) x- Var x <$> forceNotFree' es- Def f es -> Def f <$> forceNotFree' es- Con c h es -> Con c h <$> forceNotFree' es- MetaV x es -> local (insertMetaSet x) $- MetaV x <$> forceNotFree' es- Lam h b -> Lam h <$> forceNotFree' b- Pi a b -> Pi <$> forceNotFree' a <*> forceNotFree' b -- Dom and Abs do reduceIf so not needed here- Sort s -> Sort <$> forceNotFree' s- Level l -> Level <$> forceNotFree' l- DontCare t -> DontCare <$> forceNotFreeR t -- Reduction stops at DontCare so reduceIf- t@Lit{} -> return t- t@Dummy{} -> return t+ forceNotFree' t = expand \ret -> case t of+ Var x es -> ret do+ FREnv locals wantToNotFree fr _ <- ask+ FRState xs frs <- get+ let x' = x - locals+ expand \ret -> if (x >= locals && VarSet.member x' wantToNotFree) then ret do+ put $! FRState (VarSet.delete x' xs) (IntMap.insert x' fr frs)+ Var x <$> underFlexRig WeaklyRigid (forceNotFree' es)+ else ret do+ Var x <$> underFlexRig WeaklyRigid (forceNotFree' es)+ Def f es -> ret $ Def f <$> underFlexRig WeaklyRigid (forceNotFree' es)+ Con c h es -> ret $ Con c h <$> underConstructor c es (forceNotFree' es)+ MetaV m es -> ret $ MetaV m <$> underFlexRig (Flexible (singleton m)) (forceNotFree' es)+ Lam h b -> ret $ Lam h <$> underFlexRig WeaklyRigid (forceNotFree' b)+ Pi a b -> ret $ Pi <$> forceNotFree' a <*> forceNotFree' b -- Dom and Abs do reduceIf so not needed here+ Sort s -> ret $ Sort <$> forceNotFree' s+ Level l -> ret $ Level <$> forceNotFree' l+ DontCare t -> ret $ DontCare <$> forceNotFreeR t -- Reduction stops at DontCare so reduceIf+ t@Lit{} -> ret $ pure t+ t@Dummy{} -> ret $ pure t instance ForceNotFree Level where+ {-# INLINE forceNotFree' #-} forceNotFree' (Max m as) = Max m <$> forceNotFree' as instance ForceNotFree PlusLevel where+ {-# INLINE forceNotFree' #-} forceNotFree' (Plus k a) = Plus k <$> forceNotFree' a instance ForceNotFree Sort where -- Reduce for sorts already goes under all sort constructors, so we can get -- away without forceNotFreeR here.- forceNotFree' = \case- Univ u l -> Univ u <$> forceNotFree' l- PiSort a b c -> PiSort <$> forceNotFree' a <*> forceNotFree' b <*> forceNotFree' c- FunSort a b -> FunSort <$> forceNotFree' a <*> forceNotFree' b- UnivSort s -> UnivSort <$> forceNotFree' s- MetaS x es -> MetaS x <$> forceNotFree' es- DefS d es -> DefS d <$> forceNotFree' es- s@(Inf _ _)-> return s- s@SizeUniv -> return s- s@LockUniv -> return s- s@LevelUniv -> return s- s@IntervalUniv -> return s- s@DummyS{} -> return s+ forceNotFree' s = expand \ret -> case s of+ Univ u l -> ret $ Univ u <$> forceNotFree' l+ PiSort c a s1 s2 -> ret do+ -- We ignore variables in the blocked dependency check+ a <- underFlexRig (Flexible mempty) (forceNotFree' a)+ (!s1, !s2) <- underFlexRig WeaklyRigid+ ((,) <$> forceNotFree' s1 <*> forceNotFree' s2)+ pure $ PiSort c a s1 s2+ FunSort a b -> ret $ FunSort <$> forceNotFree' a <*> forceNotFree' b+ UnivSort s -> ret $ UnivSort <$> underFlexRig WeaklyRigid (forceNotFree' s)+ MetaS x es -> ret $ MetaS x <$> underFlexRig (Flexible (singleton x)) (forceNotFree' es)+ DefS d es -> ret $ DefS d <$> underFlexRig WeaklyRigid (forceNotFree' es)+ s@(Inf _ _) -> ret $ pure s+ s@SizeUniv -> ret $ pure s+ s@LockUniv -> ret $ pure s+ s@LevelUniv -> ret $ pure s+ s@IntervalUniv -> ret $ pure s+ s@DummyS{} -> ret $ pure s
+ src/full/Agda/TypeChecking/Free/Reduce.hs-boot view
@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.TypeChecking.Free.Reduce where++import Agda.Syntax.Internal (Sort)+import Agda.TypeChecking.Free.Base (FlexRig)+import Agda.TypeChecking.Monad.Base (ReduceM)++data IsFree+ = MaybeFree !FlexRig+ | NotFree++forceNonDepSort :: Sort -> ReduceM (IsFree, Sort)
src/full/Agda/TypeChecking/Functions.hs view
@@ -5,8 +5,6 @@ , getDef ) where -import Control.Arrow ( first )- import Agda.Syntax.Common import Agda.Syntax.Internal @@ -25,10 +23,12 @@ import Agda.Syntax.Common.Pretty ( prettyShow ) import Agda.Utils.Monad import Agda.Utils.Size-+import Agda.Utils.List+import Agda.Utils.Tuple ( first ) --- | Expand a clause to the maximal arity, by inserting variable--- patterns and applying the body to variables.+{-# SPECIALIZE etaExpandClause :: Clause -> TCM (Int, Clause) #-}+-- | Expand a clause to the maximal arity, by inserting variable patterns and applying the body to+-- variables. Return the arity and the expanded clause. -- Fixes issue #2376. -- Replaces 'introHiddenLambdas'.@@ -37,11 +37,11 @@ -- This is used instead of special treatment of lambdas -- (which was unsound: Issue #121) -etaExpandClause :: PureTCM tcm => Clause -> tcm Clause+etaExpandClause :: PureTCM tcm => Clause -> tcm (Int, Clause) etaExpandClause clause = do case clause of- Clause _ _ ctel ps _ Nothing _ _ _ _ _ -> return clause- Clause _ _ ctel ps Nothing (Just t) _ _ _ _ _ -> return clause+ Clause _ _ ctel ps _ Nothing _ _ _ _ _ -> let !arity = length ps in pure (arity, clause)+ Clause _ _ ctel ps Nothing (Just t) _ _ _ _ _ -> let !arity = length ps in pure (arity, clause) Clause rl rf ctel ps (Just body) (Just t) catchall recursive unreachable ell wm -> do -- Get the telescope to expand the clause with.@@ -49,14 +49,14 @@ -- If the rhs has lambdas, harvest the names of the bound variables. let xs = peekLambdas body- let ltel = useNames xs $ telToList tel0+ let ltel = useNames xs $! telToList tel0 let tel = telFromList ltel let n = size tel unless (n == size tel0) __IMPOSSIBLE__ -- useNames should not drop anything -- Join with lhs telescope, extend patterns and apply body. -- NB: no need to raise ctel!- let ctel' = telFromList $ telToList ctel ++ ltel- ps' = raise n ps ++ teleNamedArgs tel+ let ctel' = telFromList $! telToList ctel ++! ltel+ ps' = raise n ps ++! teleNamedArgs tel body' = raise n body `apply` teleArgs tel reportSDoc "term.clause.expand" 30 $ inTopContext $ vcat [ "etaExpandClause"@@ -64,13 +64,14 @@ , " xs = " <+> text (prettyShow xs) , " new tel = " <+> prettyTCM ctel' ]- return $ Clause rl rf ctel' ps' (Just body') (Just (t $> t')) catchall recursive unreachable ell wm+ let !arity = length ps + size tel0+ pure (arity, Clause rl rf ctel' ps' (Just body') (Just (t $> t')) catchall recursive unreachable ell wm) where -- Get all initial lambdas of the body. peekLambdas :: Term -> [Arg ArgName] peekLambdas v = case v of- Lam info b -> Arg info (absName b) : peekLambdas (unAbs b)+ Lam info b -> (Arg info (absName b) :) $! peekLambdas (unAbs b) _ -> [] -- Use the names of the first argument, and set the Origin all other
src/full/Agda/TypeChecking/Generalize.hs view
@@ -19,9 +19,9 @@ generalisation should produce @{A : Set} {n : Nat} {xs : Vec A n} → SomeType xs@ for the type of @foo@. -The functions `generalizeType` and `generalizeTelescope` don't have access to the abstract syntax to+The functions 'generalizeType' and 'generalizeTelescope' don't have access to the abstract syntax to be type checked (@SomeType xs@ in the example). Instead they are provided a type checking action-that delivers a `Type` or a `Telescope`. The challenge is setting up a context in which @SomeType+that delivers a 'Type' or a 'Telescope'. The challenge is setting up a context in which @SomeType xs@ can be type checked successfully by this action, without knowing what the telescope of generalised variables will be. Once we have computed this telescope the result needs to be transformed into a well typed type abstracted over it.@@ -37,14 +37,14 @@ In more detail, generalisation proceeds as follows: -- Add a variable @genTel@ of an unknown type to the context (`withGenRecVar`).+- Add a variable @genTel@ of an unknown type to the context ('withGenRecVar'). @ (genTel : _GenTel) @ - Create metavariables for the generalisable variables appearing in the problem and their- dependencies (`createGenValues`). In the example this would be+ dependencies ('createGenValues'). In the example this would be @ (genTel : _GenTel) ⊢@@ -53,16 +53,16 @@ _xs : Vec _A _n @ -- Run the type checking action (`createMetasAndTypeCheck`), binding the mentioned generalisable+- Run the type checking action ('createMetasAndTypeCheck'), binding the mentioned generalisable variables to the corresponding newly created metavariables. This binding is stored in- `eGeneralizedVars` and picked up in `Agda.TypeChecking.Rules.Application.inferDef`+ 'eGeneralizedVars' and picked up in 'Agda.TypeChecking.Rules.Application.inferDef' @ (genTel : _GenTel) ⊢ SomeType (_xs genTel) @ -- Compute the telescope of generalised variables (`computeGeneralization`). This is done by taking- the unconstrained metavariables created by `createGenValues` or created during the type checking+- Compute the telescope of generalised variables ('computeGeneralization'). This is done by taking+ the unconstrained metavariables created by 'createGenValues' or created during the type checking action and sorting them into a well formed telescope. @@@ -70,7 +70,7 @@ @ - Create a record type @GeneralizeTel@ whose fields are the generalised variables and instantiate- the type of @genTel@ to it (`createGenRecordType`).+ the type of @genTel@ to it ('createGenRecordType'). @ record GeneralizeTel : Set₁ where@@ -89,7 +89,7 @@ _xs := λ genTel → genTel .xs @ -- Build the unpacking substitution (`unpackSub`) that maps terms in @(genTel : GeneralizeTel)@ to+- Build the unpacking substitution ('unpackSub') that maps terms in @(genTel : GeneralizeTel)@ to terms in the context of the generalised variables by substituting a record value for @genTel@. @@@ -104,8 +104,8 @@ {A : Set} {n : Nat} {xs : Vec A n} → SomeType xs @ -- In case of `generalizeType` return the resulting pi type.-- In case of `generalizeTelescope` enter the resulting context, applying the unpacking substitution+- In case of 'generalizeType' return the resulting pi type.+- In case of 'generalizeTelescope' enter the resulting context, applying the unpacking substitution to let bindings (TODO #6916: and also module applications!) created in the telescope, and call the continuation. @@ -120,13 +120,10 @@ import Control.Monad.Except ( MonadError(..) ) -import Data.Bifunctor (first)-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.Set qualified as Set+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map import Data.List (partition, sortBy) import Data.Monoid @@ -160,8 +157,7 @@ import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.Impossible-import Agda.Utils.Lens-import Agda.Utils.List (downFrom, hasElem)+import Agda.Utils.List import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad@@ -169,17 +165,23 @@ import qualified Agda.Utils.Set1 as Set1 import Agda.Utils.Size import Agda.Utils.Permutation+import qualified Agda.Utils.VarSet as VarSet -- | 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 generalizeTelescope vars typecheckAction ret | Map.null vars = typecheckAction (ret []) generalizeTelescope vars typecheckAction ret = billTo [Typing, Generalize] $ withGenRecVar $ \ genRecMeta -> do+ -- Andreas, May 2026, issue #6670:+ -- createMetasAndTypeCheck may add some new anonymous modules.+ anonymousModulesBefore <- viewTC eAnonymousModules let s = Map.keysSet vars- ((cxtNames, tel, letbinds), namedMetas, allmetas) <-+ ((cxtNames, tel, letbinds, anonymousModules), namedMetas, allmetas) <- createMetasAndTypeCheck s $ typecheckAction $ \ tel -> do- xs <- take (size tel) <$> getContextNames'+ xs <- take' (size tel) <$> getContextNames' lbs <- getLetBindings -- This gives let-bindings valid in the current context- return (xs, tel, lbs)+ anons <- viewTC eAnonymousModules+ return (xs, tel, lbs, anons)+ let newAnonymousModules = take' (length anonymousModules - length anonymousModulesBefore) anonymousModules reportSDoc "tc.generalize.metas" 60 $ vcat [ "open metas =" <+> (text . show . fmap ((miNameSuggestion &&& miGeneralizable) . mvInfo)) (openMetas $ allmetas)@@ -188,25 +190,24 @@ (genTel, genTelNames, sub) <- computeGeneralization genRecMeta namedMetas allmetas let boundVar q = fromMaybe __IMPOSSIBLE__ $ Map.lookup q vars- genTelVars = (map . fmap) boundVar genTelNames+ genTelVars = (map' . fmap) boundVar genTelNames tel' <- applySubst sub <$> instantiateFull tel -- This is not so nice. When changing the context from Γ (r : R) to Γ Δ we need to do this at the -- level of contexts (as a Context -> Context function), so we repeat the name logic here. Take -- care to preserve the name of named generalized variables.- let setName name d = first (const name) <$> d- cxtEntry (mname, dom) = do+ let cxtEntry (mname, dom) = do let s = fst $ unDom dom name <- maybe (setNotInScope <$> freshName_ s) return mname return $ CtxVar name (snd <$> dom)- dropCxt err = updateContext (strengthenS err 1) (drop 1)- genTelCxt <- dropCxt __IMPOSSIBLE__ $ mapM cxtEntry $ reverse $ zip genTelVars $ telToList genTel+ dropCxt err = updateContext (strengthenS err 1) (cxDrop 1)+ genTelCxt <- dropCxt __IMPOSSIBLE__ $ mapM cxtEntry $ reverse $ zip' genTelVars $ telToList genTel -- For the explicit module telescope we get the names from the typecheck -- action. let newTelCxt :: [ContextEntry]- newTelCxt = zipWith CtxVar cxtNames $ reverse $ map (fmap snd) $ telToList tel'+ newTelCxt = zipWith' CtxVar cxtNames $ reverse $ map' (fmap snd) $ telToList tel' -- We are in context Γ (r : R) and should call the continuation in context Γ Δ Θρ passing it Δ Θρ -- We have@@ -217,15 +218,16 @@ -- And we shouldn't forget about the let-bindings (#3470) -- Γ (r : R) Θ ⊢ letbinds -- Γ Δ Θρ ⊢ letbinds' = letbinds(lift |Θ| ρ)- -- And modules created in the telescope (#6916)- -- TODO letbinds' <- applySubst (liftS (size tel) sub) <$> instantiateFull letbinds- let addLet (x, LetBinding o v dom) = addLetBinding' o x v dom-- updateContext sub ((genTelCxt ++) . drop 1) $- updateContext (raiseS (size tel')) (newTelCxt ++) $- foldr addLet (ret genTelVars $ abstract genTel tel') letbinds'-+ -- And sections created by module applications in the telescope (#6916)+ -- Γ (r : R) ⊢ Σ Σ = sectionApps+ -- Γ Δ ⊢ Σρ+ let addLet (x, LetBinding isAxiom o v dom) = addLetBinding' isAxiom o x v dom+ updateContext sub (cxPrepend genTelCxt . cxDrop 1) $+ updateContext (raiseS (size tel')) (cxPrepend newTelCxt) $+ flip (foldr $ uncurry withAnonymousModule) newAnonymousModules $+ flip (foldr addLet) letbinds' $+ ret genTelVars $ abstract genTel tel' -- | Generalize a type over a set of (used) generalizable variables. generalizeType :: Set QName -> TCM Type -> TCM ([Maybe QName], Type)@@ -301,8 +303,8 @@ -- Pair metas with their metaInfo let mvs :: [(MetaId, MetaVariable)]- mvs = MapS.assocs (openMetas allmetas) ++- MapS.assocs (solvedMetas allmetas)+ mvs = Map.assocs (openMetas allmetas) +++ Map.assocs (solvedMetas allmetas) -- Issue 4727: filter out metavariables that were created before the -- current checkpoint, since they are too old to be generalized.@@ -316,12 +318,12 @@ cs <- (++) <$> useTC stAwakeConstraints <*> useTC stSleepingConstraints - reportSDoc "tc.generalize" 50 $ "current constraints:" <?> vcat (map prettyTCM cs)+ reportSDoc "tc.generalize" 50 $ "current constraints:" <?> vcat (map' prettyTCM cs) constrainedMetas <- Set.unions <$> mapM (constraintMetas . clValue . theConstraint) cs reportSDoc "tc.generalize" 30 $ nest 2 $- "constrainedMetas = " <+> prettyList_ (map prettyTCM $ Set.toList constrainedMetas)+ "constrainedMetas = " <+> prettyList_ (map' prettyTCM $ Set.toList constrainedMetas) let isConstrained x = Set.member x constrainedMetas -- Note: Always generalize named metas even if they are constrained. We@@ -337,12 +339,13 @@ let (generalizable, nongeneralizable) = partition isGeneralizable mvs (generalizableOpen', generalizableClosed) = partition isOpen generalizable (openSortMetas, generalizableOpen) = partition isSort generalizableOpen'- nongeneralizableOpen = filter isOpen nongeneralizable+ (nongeneralizableOpen, nongenClosed) = partition isOpen nongeneralizable reportSDoc "tc.generalize" 30 $ nest 2 $ vcat- [ "generalizable = " <+> prettyList_ (map (prettyTCM . fst) generalizable)- , "generalizableOpen = " <+> prettyList_ (map (prettyTCM . fst) generalizableOpen)- , "openSortMetas = " <+> prettyList_ (map (prettyTCM . fst) openSortMetas)+ [ "generalizable = " <+> prettyList_ (map' (prettyTCM . fst) generalizable)+ , "generalizableOpen = " <+> prettyList_ (map' (prettyTCM . fst) generalizableOpen)+ , "nongenClosed = " <+> prettyList_ (map' (prettyTCM . fst) nongenClosed)+ , "openSortMetas = " <+> prettyList_ (map' (prettyTCM . fst) openSortMetas) ] -- Issue 3301: We can't generalize over sorts@@ -389,36 +392,36 @@ instantiateFull (instBody inst) unless (null metas) do reportSDoc "tc.generalize" 40 $- hcat ["Inherited metas from ", prettyTCM x, ":"] <?> prettyList_ (map prettyTCM metas)+ hcat ["Inherited metas from ", prettyTCM x, ":"] <?> prettyList_ (map' prettyTCM metas) -- #4291: Override existing meta name suggestion. -- Don't suggest names for explicitly named generalizable metas. case filter (`Map.notMember` nameMap) metas of -- If we solved the parent with a new meta use the parent name for that. [m] | MetaV{} <- instBody inst -> setMetaNameSuggestion m parentName -- Otherwise suffix with a number.- ms -> zipWithM_ (\ i m -> setMetaNameSuggestion m (parentName ++ "." ++ show i)) [1..] ms+ ms -> zipWithM_ (\ i m -> setMetaNameSuggestion m (parentName ++! "." ++! show i)) [1..] ms return $ Set.fromList metas _ -> __IMPOSSIBLE__ - let (alsoGeneralize, reallyDontGeneralize) = partition (`Set.member` inherited) $ map fst nongeneralizableOpen- generalizeOver = map fst generalizableOpen ++ alsoGeneralize+ let (alsoGeneralize, reallyDontGeneralize) = partition (`Set.member` inherited) $ map' fst nongeneralizableOpen+ generalizeOver = map' fst generalizableOpen ++! alsoGeneralize shouldGeneralize = (generalizeOver `hasElem`) reportSDoc "tc.generalize" 30 $ nest 2 $ vcat- [ "alsoGeneralize = " <+> prettyList_ (map prettyTCM alsoGeneralize)- , "reallyDontGeneralize = " <+> prettyList_ (map prettyTCM reallyDontGeneralize)+ [ "alsoGeneralize = " <+> prettyList_ (map' prettyTCM alsoGeneralize)+ , "reallyDontGeneralize = " <+> prettyList_ (map' prettyTCM reallyDontGeneralize) ] - reportSDoc "tc.generalize" 10 $ "we're generalizing over" <+> prettyList_ (map prettyTCM generalizeOver)+ reportSDoc "tc.generalize" 10 $ "we're generalizing over" <+> prettyList_ (map' prettyTCM generalizeOver) -- Sort metas in dependency order. Include open metas that we are not -- generalizing over, since they will need to be pruned appropriately (see -- Issue 3672). allSortedMetas <- fromMaybeM (typeError GeneralizeCyclicDependency) $- dependencySortMetas (generalizeOver ++ reallyDontGeneralize ++ map fst openSortMetas)+ dependencySortMetas (generalizeOver ++! reallyDontGeneralize ++! map' fst openSortMetas) let sortedMetas = filter shouldGeneralize allSortedMetas - let dropCxt err = updateContext (strengthenS err 1) (drop 1)+ let dropCxt err = updateContext (strengthenS err 1) (cxDrop 1) -- Create the pre-record type (we don't yet know the types of the fields) (genRecName, genRecCon, genRecFields) <- dropCxt __IMPOSSIBLE__ $@@ -428,7 +431,7 @@ [ "created genRecordType" , nest 2 $ "genRecName = " <+> prettyTCM genRecName , nest 2 $ "genRecCon = " <+> prettyTCM genRecCon- , nest 2 $ "genRecFields = " <+> prettyList_ (map prettyTCM genRecFields)+ , nest 2 $ "genRecFields = " <+> prettyList_ (map' prettyTCM genRecFields) ] -- Solve the generalizable metas. Each generalizable meta is solved by projecting the@@ -445,7 +448,7 @@ zipWithM_ solve sortedMetas genRecFields -- Record the named variables in the telescope- let telNames = map (`Map.lookup` nameMap) sortedMetas+ let telNames = map' (`Map.lookup` nameMap) sortedMetas -- Build the telescope of generalized metas teleTypes <- do@@ -469,19 +472,27 @@ -- 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})- | MapS.member x (openMetas allmetas) ||- MapS.member x (solvedMetas allmetas) =+ | Map.member x (openMetas allmetas) ||+ Map.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+ ips :: Map MetaId InteractionId+ <- Map.fromDistinctAscList . mapMaybe inscope . fst . BiMap.toDistinctAscendingLists <$> useTC stInteractionPoints + -- Andreas, 2026-05-05, issue #4228, issue #5831+ -- Replace genTel also in context of solved interaction points so that showing the goal in context+ -- does not leak internals of the generalization machinery.+ let closedIPMetas = filter (`Map.member` ips) $ map fst nongenClosed++ pruneUnsolvedMetas genRecName genRecCon genTel genRecFields ips shouldGeneralize $+ allSortedMetas ++! closedIPMetas+ -- Fill in the missing details of the telescope record. dropCxt __IMPOSSIBLE__ $ fillInGenRecordDetails genRecName genRecCon genRecFields genRecMeta genTel -- Now abstract over the telescope. We need to apply the substitution that subsitutes a record -- value packing up the generalized variables for the genTel variable.- let sub = unpackSub genRecCon (map (argInfo . fst) teleTypes) (length teleTypes)+ let sub = unpackSub genRecCon (map' (argInfo . fst) teleTypes) (length teleTypes) -- Instantiate all fresh meta-variables to get rid of -- __DUMMY_TERM__.@@ -497,10 +508,11 @@ -- | Prune unsolved metas (#3672). The input includes also the generalized metas and is sorted in -- dependency order. The telescope is the generalized telescope. pruneUnsolvedMetas :: QName -> ConHead -> Telescope -> [QName] -> Map MetaId InteractionId -> (MetaId -> Bool) -> [MetaId] -> TCM ()-pruneUnsolvedMetas genRecName genRecCon genTel genRecFields interactionPoints isGeneralized metas- | all isGeneralized metas = return ()- | otherwise = prune [] genTel metas+pruneUnsolvedMetas genRecName genRecCon genTel genRecFields interactionPoints isGeneralized metas = do+ unless (all isGeneralized metas) $+ prune [] genTel metas where+ prune :: ListTel -> Telescope -> [MetaId] -> TCM () prune _ _ [] = return () prune cxt tel (x : xs) | not (isGeneralized x) = do -- If x is a blocked term we shouldn't instantiate it.@@ -512,31 +524,11 @@ where x = absName tel prune _ _ _ = __IMPOSSIBLE__ - sub = unpackSub genRecCon $ map getArgInfo $ telToList genTel-- prepruneErrorRefinedContext = prepruneError $- "Failed to generalize because some of the generalized variables depend on an " ++- "unsolved meta created in a refined context (not a simple extension of the context where " ++- "generalization happens)."-- prepruneErrorCyclicDependencies = prepruneError $- "Failed to generalize due to circular dependencies between the generalized " ++- "variables and an unsolved meta."-- prepruneErrorFailedToInstantiate = prepruneError $- "Failed to generalize because the generalized variables depend on an unsolved meta " ++- "that could not be lifted outside the generalization."-- prepruneError :: String -> MetaId -> TCM a- prepruneError msg x = do- r <- getMetaRange x- genericDocError =<<- (fwords (msg ++ " The problematic unsolved meta is") $$- nest 2 (prettyTCM (MetaV x []) <+> "at" <+> pretty r)- )+ sub = unpackSub genRecCon $ map' getArgInfo $ telToList genTel -- If one of the fields depend on this meta, we have to make sure that this meta doesn't depend -- on any variables introduced after the genRec. See test/Fail/Issue3672b.agda for a test case.+ prePrune :: MetaId -> TCM MetaId prePrune x = do cp <- viewTC eCurrentCheckpoint mv <- lookupLocalMeta x@@ -548,7 +540,7 @@ case δ of Wk n IdS -> return (n, _A) IdS -> return (0, _A)- _ -> prepruneErrorRefinedContext x+ _ -> typeError . GeneralizationPrepruneErrorRefinedContext =<< buildClosure x if i == 0 then return x else do reportSDoc "tc.generalize.prune.pre" 40 $ vcat [ "prepruning"@@ -561,11 +553,11 @@ -- and we need to get rid of the dependency on Δ. -- We can only do this if A does not depend on Δ, so check this first.- case IntSet.minView (allFreeVars _A) of- Just (j, _) | j < i -> prepruneErrorCyclicDependencies x+ case VarSet.minView (freeVarSet _A) of+ Just (j, _) | j < i -> typeError . GeneralizationPrepruneErrorCyclicDependencies =<< buildClosure x _ -> return () - -- If it doesn't we can strenghten it to the current context (this is done by+ -- If it doesn't we can strengthen it to the current context (this is done by -- newMetaFromOld). -- Γ (r : GenRec) ⊢ ρ : Γ (r : GenRec) Δ let ρ = strengthenS impossible i@@ -583,12 +575,14 @@ enterClosure mv $ \ _ -> do -- v is x applied to the context variables v <- case _A of- Nothing -> Sort . MetaS x . map Apply <$> getMetaContextArgs mv- Just{} -> MetaV x . map Apply <$> getMetaContextArgs mv- noConstraints (doPrune x mv _A v uρ') `catchError` \ _ -> prepruneErrorFailedToInstantiate x+ Nothing -> Sort . MetaS x . map' Apply <$> getMetaContextArgs mv+ Just{} -> MetaV x . map' Apply <$> getMetaContextArgs mv+ noConstraints (doPrune x mv _A v uρ') `catchError` \ _ ->+ typeError . GeneralizationPrepruneErrorFailedToInstantiate =<< buildClosure x setInteractionPoint x y return y + pruneMeta :: Telescope -> MetaId -> TCM () pruneMeta _Θ x = do cp <- viewTC eCurrentCheckpoint mv <- lookupLocalMeta x@@ -627,8 +621,8 @@ -- v is x applied to the context variables v <- case _A of- Nothing -> Sort . MetaS x . map Apply <$> getMetaContextArgs mv- Just{} -> MetaV x . map Apply <$> getMetaContextArgs mv+ Nothing -> Sort . MetaS x . map' Apply <$> getMetaContextArgs mv+ Just{} -> MetaV x . map' Apply <$> getMetaContextArgs mv -- Now ultimately we want to create the fresh meta in the context -- Γ Θγ Δσ where Γ ⊢ γ : Γ₀@@ -644,7 +638,7 @@ -- Γ Θγ Δσ ⊢ lift i σ : Γ (r : GenTel) Δ let ρ = liftS i σ -- We also need ρ⁻¹, which is a lot easier to construct.- ρ' = liftS i $ [ Var 0 [Proj ProjSystem fld] | fld <- reverse $ take (size _Θ) $ genRecFields ] ++# raiseS 1+ ρ' = liftS i $ [ Var 0 [Proj ProjSystem fld] | fld <- reverse $ take' (size _Θ) $ genRecFields ] ++# raiseS 1 reportSDoc "tc.generalize.prune" 30 $ nest 2 $ vcat [ "Γ =" <+> pretty _Γ@@ -663,13 +657,13 @@ -- When updating the context we also need to pick names for the variables. Get them from the -- current context and generate fresh ones for the generalized variables in Θ. (newCxt, rΘ) <- do- (rΔ, _ : rΓ) <- splitAt i <$> getContext- let setName dom@(Dom {unDom = (s,ty)}) = CtxVar <$> freshName_ s <*> (pure $ dom $> ty)+ (rΔ, CxExtend _ rΓ) <- cxSplitAt i <$> getContext+ let setName dom@(unDom -> (s,ty)) = CtxVar <$> freshName_ s <*> (pure $ dom $> ty) rΘ <- mapM setName $ reverse $ telToList _Θγ- let rΔσ = zipWith (\ name dom -> CtxVar name (snd <$> dom))- (map ctxEntryName rΔ)+ let rΔσ = zipWith' (\ name dom -> CtxVar name (snd <$> dom))+ (map' ctxEntryName rΔ) (reverse $ telToList _Δσ)- return (rΔσ ++ rΘ ++ rΓ, rΘ)+ return (cxPrepend rΔσ $ cxPrepend rΘ rΓ, rΘ) -- Now we can enter the new context and create our meta variable. (y, u) <- updateContext ρ (const newCxt) $ localScope $ do@@ -715,13 +709,14 @@ findGenRec mv = do cxt <- instantiateFull =<< getContext let n = length cxt- notPruned = IntSet.fromList $+ notPruned = VarSet.fromList $ permute (takeP n $ mvPermutation mv) $ downFrom n case [ i- | (i, CtxVar _ (Dom{unDom = (El _ (Def q _))})) <- zip [0..] cxt+ | (i, CtxVar _ ((unDom -> (El _ (Def q _))))) <-+ cxWithIndex (,) cxt , q == genRecName- , i `IntSet.member` notPruned+ , i `VarSet.member` notPruned ] of [] -> return Nothing _:_:_ -> __IMPOSSIBLE__@@ -740,6 +735,7 @@ (jComparison $ mvJudgement mv) _Aρ -- If x is a hole, update the hole to point to y instead.+ setInteractionPoint :: MetaId -> MetaId -> TCM () setInteractionPoint x y = whenJust (Map.lookup x interactionPoints) (`connectInteractionPoint` y) @@ -752,22 +748,23 @@ where isOpen = isOpenMeta $ mvInstantiation mv getArgs = \case- Sort (MetaS _ es) -> fromMaybe __IMPOSSIBLE__ $ allApplyElims es- MetaV _ es -> fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ Sort (MetaS _ es) -> mustAllApplyElims es+ MetaV _ es -> mustAllApplyElims es _ -> __IMPOSSIBLE__ unwrapSort (Sort s) = s unwrapSort _ = __IMPOSSIBLE__ + niceError :: MetaId -> Term -> TCErr -> TCM a niceError x u err = do u <- instantiateFull u let err' = case err of TypeError{tcErrClosErr = cl} -> -- Remove the 'when' part from the error since it's most like the same as ours.- err{ tcErrClosErr = cl{ clEnv = (clEnv cl) { envCall = Nothing } } }+ err { tcErrClosErr = cl{ clEnv = (clEnv cl) & eCall .~ Nothing }} _ -> err telList = telToList genTel- names = map (fst . unDom) telList- late = map (fst . unDom) $ filter (getAny . allMetas (Any . (== x))) telList+ names = map' (fst . unDom) telList+ late = map' (fst . unDom) $ filter (getAny . allMetas (Any . (== x))) telList projs (Proj _ q) | q `elem` genRecFields , Just y <- getGeneralizedFieldName q@@ -780,8 +777,8 @@ _ -> Set.empty commas [] = __IMPOSSIBLE__ commas [x] = x- commas [x, y] = x ++ ", and " ++ y- commas (x : xs) = x ++ ", " ++ commas xs+ commas [x, y] = x ++! ", and " ++! y+ commas (x : xs) = x ++! ", " ++! commas xs cause = "There were unsolved constraints that obscured the " ++ "dependencies between the generalized variables." solution = "The most reliable solution is to provide enough information to make the dependencies " ++@@ -794,7 +791,7 @@ , singPlural late (<> "s") id "depend" -- NB: this is a singular "s" , "on", commas $ Set.toList early ]- genericDocError =<< vcat+ typeError . GeneralizationFailed =<< vcat [ fwords $ "Variable generalization failed." , nest 2 $ sep ["- Probable cause", nest 4 $ fwords cause] , nest 2 $ sep ["- Suggestion", nest 4 $ fwords solution]@@ -804,10 +801,11 @@ [ nest 2 $ "-" <+> sep [ fwords "The dependency error is", prettyTCM err' ] ] ] + addNamedVariablesToScope :: [ContextEntry] -> TCM () addNamedVariablesToScope cxt = forM_ cxt $ \ (CtxVar x _) -> do -- Recognize named variables by lack of '.' (TODO: hacky!)- reportSLn "tc.generalize.eta.scope" 40 $ "Adding (or not) " ++ prettyShow (nameConcrete x) ++ " to the scope"+ reportSLn "tc.generalize.eta.scope" 40 $ "Adding (or not) " ++! prettyShow (nameConcrete x) ++! " to the scope" when ('.' `notElem` prettyShow (nameConcrete x)) $ do reportSLn "tc.generalize.eta.scope" 40 " (added)" bindVariable LambdaBound (nameConcrete x) x@@ -823,7 +821,7 @@ where ar = length infos appl info v = Apply (Arg info v)- recVal = Con con ConOSystem $ zipWith appl infos $ [var j | j <- [i - 1, i - 2..0]] ++ replicate (ar - i) __DUMMY_TERM__+ recVal = Con con ConOSystem $ zipWith' appl infos $ [var j | j <- [i - 1, i - 2..0]] ++! replicate (ar - i) __DUMMY_TERM__ -- want: Γ Δᵢ ⊢ recSub i : Γ (r : R) -- have:@@ -844,7 +842,7 @@ buildGeneralizeTel :: ConHead -> [(Arg MetaNameSuggestion, Type)] -> Telescope buildGeneralizeTel con xs = go 0 xs where- infos = map (argInfo . fst) xs+ infos = map' (argInfo . fst) xs recSub i = unpackSub con infos i go _ [] = EmptyTel go i ((name, ty) : xs) = ExtendTel (dom ty') $ Abs (unArg name) $ go (i + 1) xs@@ -885,7 +883,7 @@ TelV tel _ = telView' ty -- Generalizable variables are never explicit, so if they're given as -- explicit we default to hidden.- argTel = telFromList $ map hideExplicit $ take nGen $ telToList tel+ argTel = telFromList $ map' hideExplicit $ take' nGen $ telToList tel args <- newTelMeta argTel metaType <- piApplyM ty args@@ -901,12 +899,12 @@ mv { mvFrozen = Frozen } -- Set up names of arg metas- forM_ (zip3 [1..] (map unArg args) (telToList argTel)) $ \ case- (i, MetaV m _, Dom{unDom = (x, _)}) -> do+ forM_ (zip3 [1..] (map' unArg args) (telToList argTel)) $ \ case+ (i, MetaV m _, unDom -> (x, _)) -> do let suf "_" = show i suf "" = show i suf x = x- setMetaNameSuggestion m (name ++ "." ++ suf x)+ setMetaNameSuggestion m (name ++! "." ++! suf x) _ -> return () -- eta expanded -- Update the ArgInfos for the named meta. The argument metas are@@ -920,8 +918,8 @@ case term of MetaV{} -> return ()- _ -> genericDocError =<< ("Cannot generalize over" <+> prettyTCM x <+> "of eta-expandable type") <?>- prettyTCM metaType+ _ -> typeError $ CannotGeneralizeEtaExpandable x metaType+ return . (m,) $ GeneralizedValue { genvalCheckpoint = cp , genvalTerm = term@@ -941,16 +939,17 @@ let freshQName s = qualify current <$> freshName_ (s :: String) mkFieldName = freshQName . (generalizedFieldName ++) <=< getMetaNameSuggestion genRecFields <- mapM (defaultDom <.> mkFieldName) sortedMetas- genRecName <- freshQName "GeneralizeTel"- genRecCon <- freshQName "mkGeneralizeTel" <&> \ con -> ConHead+ genRecName <- freshQName generalizeRecordName+ genRecCon <- freshQName generalizeConstructorName <&> \ con -> ConHead { conName = con , conDataRecord= IsRecord CopatternMatching , conInductive = Inductive- , conFields = map argFromDom genRecFields+ , conIsHIT = NotHIT+ , conFields = map' argFromDom genRecFields } projIx <- succ . size <$> getContext erasure <- optErasure <$> pragmaOptions- inTopContext $ forM_ (zip sortedMetas genRecFields) $ \ (meta, fld) -> do+ inTopContext $ forM_ (zip' sortedMetas genRecFields) $ \ (meta, fld) -> do fieldTy <- getMetaType meta let field = unDom fld addConstant' field (getArgInfo fld) fieldTy $ FunctionDefn $@@ -971,6 +970,7 @@ , conSrcCon = genRecCon , conData = genRecName , conAbstr = ConcreteDef+ , conPathCons = PointCons , conComp = emptyCompKit , conProj = Nothing , conForced = []@@ -988,7 +988,8 @@ , recFields = genRecFields , recTel = dummyTel (length genRecFields) -- Filled in later , recMutual = Just []- , recEtaEquality' = Inferred YesEta+ , recPositivityCheck = NoPositivityCheck+ , recEtaEquality' = EtaEquality YesEta EtaFromPragma , recPatternMatching = CopatternMatching , recInduction = Nothing , recTerminates = Just True -- not recursive@@ -996,14 +997,14 @@ , recComp = emptyCompKit } reportSDoc "tc.generalize" 20 $ vcat- [ text "created genRec" <+> prettyList_ (map (text . prettyShow . unDom) genRecFields) ]+ [ text "created genRec" <+> prettyList_ (map' (text . prettyShow . unDom) genRecFields) ] reportSDoc "tc.generalize" 80 $ vcat [ text "created genRec" <+> text (prettyShow genRecFields) ] -- Solve the genRecMeta args <- getContextArgs- let genRecTy = El genRecSort $ Def genRecName $ map Apply args+ let genRecTy = El genRecSort $ Def genRecName $ map' Apply args noConstraints $ equalType genRecTy genRecMeta- return (genRecName, genRecCon, map unDom genRecFields)+ return (genRecName, genRecCon, map' unDom genRecFields) -- | Once we have the generalized telescope we can fill in the missing details of the record type. fillInGenRecordDetails :: QName -> ConHead -> [QName] -> Type -> Telescope -> TCM ()@@ -1020,7 +1021,7 @@ proj = Var 0 [Proj ProjSystem fld] mkFieldTypes _ _ = __IMPOSSIBLE__ let fieldTypes = mkFieldTypes fields (raise 1 fieldTel)- reportSDoc "tc.generalize" 40 $ text "Field types:" <+> inTopContext (nest 2 $ vcat $ map prettyTCM fieldTypes)+ reportSDoc "tc.generalize" 40 $ text "Field types:" <+> inTopContext (nest 2 $ vcat $ map' prettyTCM fieldTypes) zipWithM_ setType fields fieldTypes -- Constructor type let conType = fullTel `abstract` raise (size fieldTel) recTy@@ -1031,8 +1032,8 @@ -- #7380: Also add clauses to the field definitions let n = length fields cpi = noConPatternInfo- fldTys = map (fmap snd . argFromDom) $ telToList fieldTel- conPat = ConP con cpi [ fmap unnamed $ varP (DBPatVar "x" i) <$ arg | (i, arg) <- zip (downFrom n) fldTys ]+ fldTys = map' (fmap snd . argFromDom) $ telToList fieldTel+ conPat = ConP con cpi $! map' (\(i, arg) -> fmap unnamed $ varP (DBPatVar "x" i) <$ arg) (zip' (downFrom n) fldTys) forM_ (zip3 (downFrom n) fields fldTys) \ (i, fld, fldTy) -> do modifyFunClauses fld \ _ -> [Clause@@ -1043,7 +1044,7 @@ , clauseBody = Just $ var i , clauseType = Just $ raise (i + 1) fldTy , clauseCatchall = empty- , clauseRecursive = Just False+ , clauseRecursive = NotRecursive , clauseUnreachable = Just False , clauseEllipsis = NoEllipsis , clauseWhereModule = Nothing
src/full/Agda/TypeChecking/IApplyConfluence.hs view
@@ -26,8 +26,10 @@ import Agda.TypeChecking.Pretty import Agda.TypeChecking.Records import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Rules.LHS (buildLHSSubstitutions) import Agda.TypeChecking.Telescope.Path import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Conversion.Errors import Agda.TypeChecking.Conversion import Agda.TypeChecking.Substitute @@ -43,10 +45,10 @@ checkIApplyConfluence_ :: QName -> TCM () checkIApplyConfluence_ f = whenM (isJust <$> cubicalOption) $ do -- Andreas, 2019-03-27, iapply confluence should only be checked- -- when --cubical or --erased-cubical is active. See+ -- when --cubical[={full,erased}] is active. See -- test/Succeed/CheckIApplyConfluence.agda. -- We cannot reach the following crash point unless- -- --cubical/--erased-cubical is active.+ -- --cubical[={full,erased}] is active. __CRASH_WHEN__ "tc.cover.iapply.confluence.crash" 666 reportSDoc "tc.cover.iapply" 10 $ text "Checking IApply confluence of" <+> pretty f inConcreteOrAbstractMode f $ \ d -> do@@ -59,7 +61,7 @@ modifySignature $ updateDefinition f $ updateTheDef $ updateCovering (const []) - traceCall (CheckFunDefCall (getRange f) f [] False) $+ traceCall (CheckFunDefCall (getRange f) f False) $ forM_ cls $ checkIApplyConfluence f _ -> return () @@ -79,10 +81,13 @@ } -> setCurrentRange (clauseLHSRange cl) $ do let trhs = unArg t- oldCall <- asksTC envCall+ oldCall <- viewTC eCall reportSDoc "tc.cover.iapply" 40 $ "tel =" <+> prettyTCM clTel reportSDoc "tc.cover.iapply" 40 $ "ps =" <+> pretty ps- ps <- normaliseProjP ps+ ps <- normaliseProjP ps+ cxt <- getContext+ clCxt <- inTopContext $ addContext clTel $ getContext+ let (_, clSub) = buildLHSSubstitutions cxt ps NoWithFunction forM_ (iApplyVars ps) $ \ i -> do unview <- intervalUnview' let phi = unview $ IMax (argN $ unview (INeg $ argN $ var i)) $ argN $ var i@@ -120,7 +125,7 @@ -- But if the conversion checking failed really early, we drop the extra -- information. In that case, it's just noise. maybeDropCall e@(TypeError loc s err)- | UnequalTerms _ u' v' _ <- clValue err =+ | ConversionError_ (ConversionError _ _ u' v' _) <- clValue err = -- Issue #6725: restore the TC state from the -- error before dealing with the stored terms. withTCState (const s) $ enterClosure err $ \e' -> do@@ -132,7 +137,7 @@ -- “failure case” here is *at worst* accidentally reminding the user of how -- IApplyConfluence works. if (u_p == u' && v_p == v')- then localTC (\e -> e { envCall = oldCall }) $ typeError e'+ then localTC (set eCall oldCall) $ typeError e' else throwError e maybeDropCall x = throwError x @@ -142,7 +147,8 @@ -- instead of presenting a mysterious error. traceCall why (compareTerm cmp ty u v `catchError` maybeDropCall) - addContext clTel $ compareTermOnFace' k CmpEq phi trhs lhs body+ updateContext clSub (const clCxt) $+ compareTermOnFace' k CmpEq phi trhs lhs body -- | current context is of the form Γ.Δ unifyElims :: Args@@ -193,11 +199,11 @@ :: Substitution -> IntSet -- Support. -> Context -> Context- codomain s vs =+ codomain s vs = Context . mapMaybe (\(i, c) -> if i `IntSet.member` vs then Nothing else Just c) .- zipWith (\i c -> (i, dropS (i + 1) s `applySubst` c)) [0..]+ cxWithIndex (\i c -> (i, dropS (i + 1) s `applySubst` c)) -- | Like @unifyElims@ but @Γ@ is from the meta's @MetaInfo@ and -- the context extension @Δ@ is taken from the @Closure@.
src/full/Agda/TypeChecking/Implicit.hs view
@@ -4,12 +4,17 @@ -} module Agda.TypeChecking.Implicit where +import Prelude hiding (null)+ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class +import Data.Bifunctor (first)+ import Agda.Syntax.Position (HasRange, beginningOf, getRange) import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Syntax.Abstract (Binder, mkBinder_) import Agda.Syntax.Info ( MetaKind (InstanceMeta, UnificationMeta) ) import Agda.Syntax.Internal as I@@ -21,15 +26,21 @@ import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Pretty.Constraint () -- PrettyTCM Constraint instance only import Agda.TypeChecking.Telescope -import Agda.Utils.Function (applyWhen)+import Agda.Utils.Function (applyWhen, applyWhenJust) import Agda.Utils.Functor+import Agda.Utils.List+import Agda.Utils.List qualified as List import Agda.Utils.List1 (List1, pattern (:|))-import qualified Agda.Utils.List1 as List1+import Agda.Utils.List1 qualified as List1 import Agda.Utils.Maybe+import Agda.Utils.Null import Agda.Utils.Tuple +import Agda.Utils.Impossible+ -- Cut and paste from insertImplicitPatternsT: -- | Split a given Pi 'Type' until you reach the given named argument,@@ -48,9 +59,9 @@ -- Otherwise we try inserting implicit arguments. _ -> setCurrentRange narg case insertImplicit narg $ telToList tel of- BadImplicits -> typeError WrongHidingInLHS- NoSuchName x -> typeError WrongHidingInLHS- ImpInsert doms ->+ BadImplicits -> typeError WrongHidingInLHS+ NoSuchName x xs -> typeError $ WrongNamedArgumentInLHS (getHiding narg) x xs+ ImpInsert doms -> let (here, there) = splitTelescopeAt (length doms) tel in pure (here, abstract there ty0) @@ -58,67 +69,117 @@ -- metas (unbounded if @n<0@), as long as @t@ is a function type -- and @expand@ holds on the hiding info of its domain. -implicitArgs- :: (PureTCM m, MonadMetaSolver m, MonadTCM m)- => Int -- ^ @n@, the maximum number of implicts to be inserted.+implicitArgs ::+ Int -- ^ @n@, the maximum number of implicts to be inserted. -> (Hiding -> Bool) -- ^ @expand@, the predicate to test whether we should keep inserting. -> Type -- ^ The (function) type @t@ we are eliminating.- -> m (Args, Type) -- ^ The eliminating arguments and the remaining type.-implicitArgs n expand t = mapFst (map (fmap namedThing)) <$> do- implicitNamedArgs n (\ h x -> expand h) t+ -> TCM (Args, Type) -- ^ The eliminating arguments and the remaining type.+implicitArgs n expand t = first (map' (fmap namedThing)) <$> do+ implicitNamedArgs n (\ h _x -> expand h) t -- | @implicitNamedArgs n expand t@ generates up to @n@ named implicit arguments -- metas (unbounded if @n<0@), as long as @t@ is a function type -- and @expand@ holds on the hiding and name info of its domain. -implicitNamedArgs- :: (PureTCM m, MonadMetaSolver m, MonadTCM m)- => Int -- ^ @n@, the maximum number of implicts to be inserted.+implicitNamedArgs ::+ Int -- ^ @n@, the maximum number of implicts to be inserted. -> (Hiding -> ArgName -> Bool) -- ^ @expand@, the predicate to test whether we should keep inserting. -> Type -- ^ The (function) type @t@ we are eliminating.- -> m (NamedArgs, Type) -- ^ The eliminating arguments and the remaining type.-implicitNamedArgs 0 expand t0 = return ([], t0)+ -> TCM (NamedArgs, Type) -- ^ The eliminating arguments and the remaining type. implicitNamedArgs n expand t0 = do+ (ncas, t) <- implicitCheckedArgs n expand t0+ let (ns, cas) = List.unzipWith (\ (Named n ca) -> (n, ca)) ncas+ es <- liftTCM $ noHeadConstraints cas+ let nargs = zipWith' (\ n (Arg ai v) -> Arg ai (Named n v)) ns (mustAllApplyElims es)+ return (nargs, t)++-- | Make sure there are no head constraints attached to the eliminations+-- and just return the eliminations.+noHeadConstraints :: [CheckedArg] -> TCM [Elim]+noHeadConstraints = mapM noHeadConstraint++noHeadConstraint :: CheckedArg -> TCM Elim+noHeadConstraint (CheckedArg elim _ Nothing) = return elim+noHeadConstraint (CheckedArg _ range Just{} ) = do+ setCurrentRange range do+ typeError $ NotSupported $+ "Lock constraints are not (yet) supported in this position."++-- | @implicitCheckedArgs n expand t@ generates up to @n@ named implicit arguments+-- metas (unbounded if @n<0@), as long as @t@ is a function type+-- and @expand@ holds on the hiding and name info of its domain.++implicitCheckedArgs ::+ Int -- ^ @n@, the maximum number of implicts to be inserted.+ -> (Hiding -> ArgName -> Bool) -- ^ @expand@, the predicate to test whether we should keep inserting.+ -> Type -- ^ The (function) type @t@ we are eliminating.+ -> TCM ([Named_ CheckedArg], Type)-- ^ The eliminating arguments and the remaining type.+implicitCheckedArgs 0 expand t0 = return ([], t0)+implicitCheckedArgs n expand t0 = do t0' <- reduce t0- reportSDoc "tc.term.args" 30 $ "implicitNamedArgs" <+> prettyTCM t0'- reportSDoc "tc.term.args" 80 $ "implicitNamedArgs" <+> text (show t0')+ reportSDoc "tc.term.args" 30 $ "implicitCheckedArgs" <+> prettyTCM t0'+ reportSDoc "tc.term.args" 80 $ "implicitCheckedArgs" <+> text (show t0') case unEl t0' of- Pi dom@Dom{domInfo = info, domTactic = tac, unDom = a} b- | let x = bareNameWithDefault "_" dom, expand (getHiding info) x -> do- kind <- if hidden info then return UnificationMeta else do+ Pi dom@(unDom -> a) b+ -- Pi dom@Dom{domInfo = info, domTactic = mtac, unDom = a} b+ | let x = bareNameWithDefault "_" dom, expand (getHiding (dom ^. dInfo)) x -> do+ kind <- if hidden (dom ^. dInfo) then return UnificationMeta else do reportSDoc "tc.term.args.ifs" 15 $ "inserting instance meta for type" <+> prettyTCM a reportSDoc "tc.term.args.ifs" 40 $ nest 2 $ vcat [ "x = " <+> text (show x)- , "hiding = " <+> text (show $ getHiding info)+ , "hiding = " <+> text (show $ getHiding (dom ^. dInfo)) ] return InstanceMeta- (_, v) <- newMetaArg kind info x CmpLeq a- whenJust tac $ \ tac -> liftTCM $- applyModalityToContext info $ unquoteTactic tac v a- let narg = Arg info (Named (Just $ WithOrigin Inserted $ unranged x) v)- mapFst (narg :) <$> implicitNamedArgs (n-1) expand (absApp b v)+ (_, v) <- newMetaArg kind x CmpLeq dom+ whenJust (dom ^. dTactic) \ tac -> liftTCM do+ -- We don't need to do a full 'applyDomToContext' here.+ -- 'newMetaArg' already adds the local rewrite rule constraint+ applyModalityToContext dom $ unquoteTactic tac v a+ let name = Just $ WithOrigin Inserted $ unranged x+ mc <- liftTCM $ makeLockConstraint t0' v+ let carg = CheckedArg{ caElim = Apply (Arg (dom ^. dInfo) v), caRange = empty, caConstraint = mc }+ first (Named name carg :) <$> implicitCheckedArgs (n-1) expand (absApp b v) _ -> return ([], t0') +-- | @makeLockConstraint u funType@(El _ (Pi (Dom{ domInfo=info, unDom=a }) _))@+-- creates a @CheckLockedVars@ constraint for lock @u : a@+-- if @getLock info == IsLock _@.+--+-- Precondition: 'Type' is reduced.+makeLockConstraint :: Type -> Term -> TCM (Maybe (Abs Constraint))+makeLockConstraint funType u =+ case funType of+ El _ (Pi dom@(unDom -> a) _) -> do+ let+ x = maybe "t" prettyShow (dom ^. dName)+ mc = case getLock (dom ^. dInfo) of+ IsLock{} -> Just $ Abs x $+ CheckLockedVars (var 0) (raise 1 funType) (raise 1 $ Arg (dom ^. dInfo) u) (raise 1 a)+ IsNotLock -> Nothing+ whenJust mc \ c -> do+ reportSDoc "tc.term.lock" 40 do+ addContext (defaultDom $ funType) $ prettyTCM c+ return mc+ _ -> return Nothing+ -- | Create a metavariable of 'MetaKind'. -newMetaArg- :: (PureTCM m, MonadMetaSolver m)- => MetaKind -- ^ Kind of meta.- -> ArgInfo -- ^ Rrelevance of meta.- -> ArgName -- ^ Name suggestion for meta.- -> Comparison -- ^ Check (@CmpLeq@) or infer (@CmpEq@) the type.- -> Type -- ^ Type of meta.- -> m (MetaId, Term) -- ^ The created meta as id and as term.-newMetaArg kind info x cmp a = do+newMetaArg ::+ MetaKind -- ^ Kind of meta.+ -> ArgName -- ^ Name suggestion for meta.+ -> Comparison -- ^ Check (@CmpLeq@) or infer (@CmpEq@) the type.+ -> Dom Type -- ^ Type of meta plus relevance and local rewrite info.+ -> TCM (MetaId, Term) -- ^ The created meta as id and as term.+newMetaArg kind x cmp a = do prp <- runBlocked $ isPropM a let irrelevantIfProp = applyWhen (prp == Right True) $ applyRelevanceToContext irrelevant- applyModalityToContext info $ irrelevantIfProp $- newMeta (argNameToString x) kind a+ applyDomToContext a $ irrelevantIfProp $+ newMeta (argNameToString x) kind (unDom a) where- newMeta :: MonadMetaSolver m => String -> MetaKind -> Type -> m (MetaId, Term)+ newMeta :: String -> MetaKind -> Type -> TCM (MetaId, Term) newMeta n = \case InstanceMeta -> newInstanceMeta n UnificationMeta -> newNamedValueMeta RunMetaOccursCheck n cmp@@ -141,7 +202,10 @@ data ImplicitInsertion = ImpInsert [Dom ()] -- ^ Success: this many implicits have to be inserted (list can be empty). | BadImplicits -- ^ Error: hidden argument where there should have been a non-hidden argument.- | NoSuchName ArgName -- ^ Error: bad named argument.+ | NoSuchName ArgName [ArgName]+ -- ^ Error: bad named argument.+ -- The list contains the names of the hidden arguments+ -- (with the same hiding as the given argument) available at this point. deriving (Show) pattern NoInsertNeeded :: ImplicitInsertion@@ -173,11 +237,11 @@ insertImplicit' a ts -- If @a@ is visible, then take the non-visible prefix of @ts@.- | visible a = ImpInsert $ takeWhile notVisible $ map void ts+ | visible a = ImpInsert $! takeWhile' notVisible $ map' void ts -- If @a@ is named, take prefix of @ts@ until the name of @a@ (with correct hiding). -- If the name is not found, throw exception 'NoSuchName'.- | Just x <- bareNameOf a = maybe (NoSuchName x) ImpInsert $+ | Just x <- bareNameOf a = maybe (NoSuchName x candidates) ImpInsert $ takeHiddenUntil (\ t -> x == unDom t && sameHiding a t) ts -- If @a@ is neither visible nor named, take prefix of @ts@ with different hiding than @a@.@@ -185,6 +249,12 @@ takeHiddenUntil (sameHiding a) ts where+ -- The names of the hidden arguments of the right hiding+ -- before the next visible argument.+ candidates :: [ArgName]+ candidates =+ [ y | t <- takeWhile notVisible ts, sameHiding a t, let y = unDom t, y /= "_" ]+ -- @takeHiddenUntil p ts@ returns the 'getHiding' of the prefix of @ts@ -- until @p@ holds or a visible argument is encountered. -- If @p@ never holds, 'Nothing' is returned.@@ -194,6 +264,6 @@ takeHiddenUntil p ts = case ts2 of [] -> Nothing -- Predicate was never true- (t : _) -> if visible t then Nothing else Just $ map void ts1+ (t : _) -> if visible t then Nothing else Just $! map' void ts1 where- (ts1, ts2) = break (\ t -> p t || visible t) ts+ (!ts1, !ts2) = break' (\ t -> p t || visible t) ts
src/full/Agda/TypeChecking/Injectivity.hs view
@@ -42,15 +42,12 @@ import Control.Applicative import Control.Monad.Except ( MonadError )-import Control.Monad.State ( evalStateT, MonadState, gets, put )-import Control.Monad.Reader ( runReaderT, MonadReader, ask ) import Control.Monad.Trans.Maybe ( MaybeT(MaybeT), runMaybeT ) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Maybe import Data.Traversable hiding (for)-import Data.Semigroup ((<>)) import Data.Foldable (fold) import qualified Agda.Syntax.Abstract.Name as A@@ -58,6 +55,7 @@ import Agda.Syntax.Internal import Agda.Syntax.Internal.Pattern +import Agda.TypeChecking.Conversion.Errors (failConversion) import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Irrelevance (isIrrelevantOrPropM) import Agda.TypeChecking.Monad@@ -80,7 +78,9 @@ import Agda.Utils.Monad import Agda.Utils.Permutation import Agda.Syntax.Common.Pretty ( prettyShow )-import qualified Agda.Utils.ProfileOptions as Profile+import Agda.Interaction.Options.ProfileOptions qualified as Profile+import Agda.Utils.StrictReader+import Agda.Utils.StrictState import Agda.Utils.Impossible @@ -106,7 +106,7 @@ -- Don't treat axioms in the current mutual block -- as constructors (they might have definitions we -- don't know about yet).- caseMaybeM (asksTC envMutualBlock) yes $ \ mb -> do+ caseMaybeM (viewTC eMutualBlock) yes $ \ mb -> do fs <- mutualNames <$> lookupMutualBlock mb if Set.member f fs then no else yes Function{} -> no@@ -129,7 +129,7 @@ Level{} -> return Nothing MetaV{} -> return Nothing DontCare{} -> return Nothing- Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s+ Dummy s _ -> __IMPOSSIBLE_VERBOSE__ (show s) -- | Is this a matchable definition, or constructor, which reduces based -- on interval substitutions?@@ -178,13 +178,13 @@ Level{} -> return Nothing DontCare{} -> return Nothing MetaV{} -> __IMPOSSIBLE__- Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s+ Dummy s _ -> __IMPOSSIBLE_VERBOSE__ (show s) -- | Does deBruijn variable i correspond to a top-level argument, and if so -- which one (index from the left). topLevelArg :: Clause -> Int -> Maybe TermHead topLevelArg Clause{ namedClausePats = ps } i =- case [ n | (n, VarP _ (DBPatVar _ j)) <- zip [0..] $ map namedArg ps, i == j ] of+ case [ n | (n, VarP _ (DBPatVar _ j)) <- zip' [0..] $ map' namedArg ps, i == j ] of [] -> Nothing [n] -> Just (VarHead n) _:_:_ -> __IMPOSSIBLE__@@ -254,7 +254,7 @@ for (Map.toList hdMap) $ \ (h, uc) -> text (prettyShow h) <+> "-->" <+> case uc of- [c] -> prettyTCM $ map namedArg $ namedClausePats c+ [c] -> prettyTCM $ map' namedArg $ namedClausePats c _ -> "(multiple clauses)" return $ Inverse hdMap @@ -317,19 +317,25 @@ Def f es -> do inv <- defInverse <$> getConstInfo f cubical <- cubicalOption+ -- Local rewrite rules do not update definitional injectivity/invertibility+ -- so we check if any are present+ rewr <- getLocalRewriteRulesFor $ RewDefHead f case inv of NotInjective -> return NoInv- Inverse m -> maybe NoInv (Inv f es) <$> (traverse (checkOverapplication es) =<< instantiateVarHeads f es m)+ Inverse m | null rewr -> do+ 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)+ Inverse m -> return NoInv _ -> return NoInv data InvView = Inv QName [Elim] (InversionMap Clause) | NoInv -- | Precondition: The first term must be blocked on the given meta and the second must be neutral.-useInjectivity :: MonadConversion m => CompareDirection -> Blocker -> CompareAs -> Term -> Term -> m ()+useInjectivity :: CompareDirection -> Blocker -> CompareAs -> Term -> Term -> TCM () useInjectivity dir blocker ty blk neu = locallyTC eInjectivityDepth succ $ do inv <- functionInverse blk -- Injectivity might cause non-termination for unsatisfiable constraints@@ -358,8 +364,8 @@ reportSDoc "tc.inj.use" 20 $ vcat [ fsep (pwords "comparing application of injective function" ++ [prettyTCM f] ++ pwords "at")- , nest 2 $ fsep $ punctuate comma $ map prettyTCM blkArgs- , nest 2 $ fsep $ punctuate comma $ map prettyTCM neuArgs+ , nest 2 $ fsep $ punctuate comma $ map' prettyTCM blkArgs+ , nest 2 $ fsep $ punctuate comma $ map' prettyTCM neuArgs , nest 2 $ "and type" <+> prettyTCM fTy ] fs <- getForcedArgs f@@ -384,8 +390,8 @@ -- We can't invert in this case, since we can't -- tell the difference between a solution that makes -- the blocked term neutral and one that makes progress.- Just hd -> invertFunction cmp blk inv hd fallback err success- where err = typeError $ app (\ u v -> UnequalTerms cmp u v ty) blk neu+ Just hd -> invertFunction cmp blk inv hd fallback err success where+ err = app (\u v -> failConversion cmp u v ty) blk neu where fallback = addConstraint blocker $ app (ValueCmp cmp ty) blk neu success blk' = app (compareAs cmp ty) blk' neu@@ -399,16 +405,14 @@ -- | The second argument should be a blocked application and the third argument -- the inverse of the applied function.-invertFunction- :: MonadConversion m- => Comparison -> Term -> InvView -> TermHead -> m () -> m () -> (Term -> m ()) -> m ()+invertFunction :: Comparison -> Term -> InvView -> TermHead -> TCM () -> TCM () -> (Term -> TCM ()) -> TCM () invertFunction _ _ NoInv _ fallback _ _ = fallback invertFunction cmp blk (Inv f blkArgs hdMap) hd fallback err success = do fTy <- defType <$> getConstInfo f reportSDoc "tc.inj.use" 20 $ vcat [ "inverting injective function" <?> hsep [prettyTCM f, ":", prettyTCM fTy] , "for" <?> pretty hd- , nest 2 $ "args =" <+> prettyList (map prettyTCM blkArgs)+ , nest 2 $ "args =" <+> prettyList (map' prettyTCM blkArgs) ] -- Clauses with unknown heads are also possible candidates case fromMaybe [] $ Map.lookup hd hdMap <> Map.lookup UnknownHead hdMap of [] -> err@@ -417,12 +421,12 @@ let ps = clausePats cl perm = fromMaybe __IMPOSSIBLE__ $ clausePerm cl -- These are what dot patterns should be instantiated at- ms <- map unArg <$> newTelMeta tel+ ms <- map' unArg <$> newTelMeta tel reportSDoc "tc.inj.invert" 20 $ vcat- [ "meta patterns" <+> prettyList (map prettyTCM ms)+ [ "meta patterns" <+> prettyList (map' prettyTCM ms) , " perm =" <+> text (show perm) , " tel =" <+> prettyTCM tel- , " ps =" <+> prettyList (map (text . prettyShow) ps)+ , " ps =" <+> prettyList (map' (text . prettyShow) ps) ] -- and this is the order the variables occur in the patterns let msAux = permute (invertP __IMPOSSIBLE__ $ compactP perm) ms@@ -487,8 +491,8 @@ metaPat (DotP _ v) = dotP v metaPat (VarP _ _) = nextMeta metaPat (IApplyP{}) = nextMeta- metaPat (ConP c mt args) = Con c (fromConPatternInfo mt) . map Apply <$> metaArgs args- metaPat (DefP o q args) = Def q . map Apply <$> metaArgs args+ metaPat (ConP c mt args) = Con c (fromConPatternInfo mt) . map' Apply <$> metaArgs args+ metaPat (DefP o q args) = Def q . map' Apply <$> metaArgs args metaPat (LitP _ l) = return $ Lit l metaPat ProjP{} = __IMPOSSIBLE__
src/full/Agda/TypeChecking/Inlining.hs view
@@ -9,7 +9,6 @@ import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.CompiledClause import Agda.TypeChecking.Free-import Agda.Utils.Lens -- | Mark a definition to be inlined if it satisfies the inlining criterion. autoInline :: Defn -> TCM Defn@@ -25,6 +24,6 @@ -- Only auto-inline simple definitions (no pattern matching) where no variable -- is used more than once, and some variables are not used at all. shouldInline' :: CompiledClauses -> Bool-shouldInline' (Done xs body) = all (< 2) counts && length counts < length xs- where counts = IntMap.elems $ varCounts $ freeVars body+shouldInline' (Done _ _ xs body) = all (< 2) counts && length counts < length xs+ where counts = IntMap.elems $ varCounts $ freeVarCounts body shouldInline' _ = False
src/full/Agda/TypeChecking/InstanceArguments.hs view
@@ -39,7 +39,7 @@ import Agda.Syntax.Scope.Base (isNameInScope, inverseScopeLookupName', AllowAmbiguousNames(..)) import qualified Agda.TypeChecking.Monad.Benchmark as Bench-import Agda.TypeChecking.Conversion.Pure (pureEqualTermB)+import Agda.TypeChecking.Conversion.Pure (pureBlockOrEqualTerm) import Agda.TypeChecking.Errors () --instance only import Agda.TypeChecking.Implicit (implicitArgs) import Agda.TypeChecking.Monad@@ -57,21 +57,18 @@ import qualified Agda.Benchmarking as Benchmark import Agda.TypeChecking.Monad.Benchmark (billTo) -import Agda.Utils.Lens+import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Size import Agda.Utils.Tuple import Agda.Syntax.Common.Pretty (prettyShow) -import qualified Agda.Utils.ProfileOptions as Profile--- import qualified Agda.Utils.HashTable as HashTable+import qualified Agda.Interaction.Options.ProfileOptions as Profile import Agda.Utils.WithDefault (lensCollapseDefault) import Agda.Utils.Impossible--- import Agda.Utils.HashTable (HashTable) import Agda.TypeChecking.DiscrimTree--- import GHC.IO (unsafePerformIO) -- | Compute a list of instance candidates. -- 'Nothing' if target type or any context type is a meta, error if@@ -118,29 +115,44 @@ ctx <- getContext reportSDoc "tc.instance.cands" 40 $ hang "Getting candidates from context" 2 (inTopContext $ prettyTCM $ PrettyContext ctx) -- Context variables with their types lifted to live in the full context- let varsAndRaisedTypes = reverse $ zip (contextTerms ctx) (flattenTel $ contextToTel ctx)- vars = [ Candidate LocalCandidate x t (infoOverlapMode info)- | (x, Dom{domInfo = info, unDom = t}) <- varsAndRaisedTypes- , isInstance info+ let varsAndRaisedTypes = reverse $ zip' (contextTerms ctx) (flattenTel $ contextToTel ctx)+ vars = [ Candidate LocalCandidate x t (infoOverlapMode (dom ^. dInfo))+ | (x, dom@(unDom -> t)) <- varsAndRaisedTypes+ , isInstance (dom ^. dInfo) ] - -- {{}}-fields of variables are also candidates- let cxtAndTypes = [ (LocalCandidate, x, t) | (x, Dom{unDom = t}) <- varsAndRaisedTypes ]+ -- {{}}-fields of variables are also candidates, as long as those+ -- variables are themselves instance arguments.+ -- as an exception, the record argument to a record module can+ -- also introduce instances, so that {{}}-fields of a record R+ -- will be considered when checking a declaration nested in the+ -- definition of R.+ let+ cxtAndTypes =+ [ (LocalCandidate, x, t)+ | (x, dom@(unDom -> t)) <- varsAndRaisedTypes+ , isInstance (dom ^. dInfo) || argInfoOrigin (dom ^. dInfo) == RecordSelf+ ]+ reportSDoc "tc.instance.cands" 40 $ "Getting candidates by eta-expanding context" $$ nest 2 (vcat+ [ prettyTCM x <+> colon <+> prettyTCM t $$ (nest 2 $ "origin: " <> text (show o) <> ", used: " <> text (show used))+ | (x, dom@(unDom -> t)) <- varsAndRaisedTypes, let o = argInfoOrigin (dom ^. dInfo)+ , let used = isInstance (dom ^. dInfo) || o == RecordSelf+ ]) fields <- concat <$> mapM instanceFields (reverse cxtAndTypes) reportSDoc "tc.instance.fields" 30 $ if null fields then "no instance field candidates" else "instance field candidates" $$ do- nest 2 $ vcat (map debugCandidate fields)+ nest 2 $ vcat (map' debugCandidate fields) -- get let bindings- env <- asksTC envLetBindings+ env <- viewTC eLetBindings env <- mapM (traverse getOpen) $ Map.toList env let lets = [ Candidate LocalCandidate v t DefaultOverlap- | (_, LetBinding _ v Dom{domInfo = info, unDom = t}) <- env- , isInstance info- , usableModality info+ | (_, LetBinding _isAxiom _origin v dom@(unDom -> t)) <- env+ , isInstance (dom ^. dInfo)+ , usableModality (dom ^. dInfo) ]- filterM (sameHead cls . candidateType) $ vars ++ fields ++ lets+ filterM (sameHead cls . candidateType) $ vars ++! fields ++! lets sameHead :: Maybe QName -> Type -> BlockT TCM Bool sameHead Nothing _ = pure True@@ -172,16 +184,25 @@ instanceFields = instanceFields' True instanceFields' :: Bool -> (CandidateKind,Term,Type) -> BlockT TCM [Candidate]- instanceFields' etaOnce (q, v, t) =- ifBlocked t (\ m _ -> patternViolation m) $ \ _ t -> do- caseMaybeM (etaExpand etaOnce t) (return []) $ \ (r, pars) -> do- (tel, args) <- lift $ forceEtaExpandRecord r pars v- let types = map unDom $ applySubst (parallelS $ reverse $ map unArg args) (flattenTel tel)- fmap concat $ forM (zip args types) $ \ (arg, t) ->- ([ Candidate LocalCandidate (unArg arg) t (infoOverlapMode arg)- | isInstance arg- ] ++) <$>- instanceFields' False (LocalCandidate, unArg arg, t)+ instanceFields' etaOnce (q, v, t) = do+ TelV piTel t' <- lift $ telViewUpTo' (-1) notVisible t+ ifBlocked t' (\ m _ -> patternViolation m) $ \ _ t' -> do+ let n = size piTel+ addContext piTel $ caseMaybeM (etaExpand etaOnce t') (return []) $ \ (r, pars) -> do+ let v' = raise n v `apply` teleArgs piTel+ mtelargs <- lift $ forceEtaExpandRecord r pars v'+ case mtelargs of+ Nothing -> return [] -- Issue #8636: cannot eta-expand the value at this record type+ Just (tel, args) -> do+ let types = map' unDom $ applySubst (parallelS $ reverse $ map' unArg args) (flattenTel tel)+ fmap concat $ forM (zip' args types) $ \ (arg, t) -> do+ let+ absArg = abstract piTel (unArg arg)+ absTy = telePi piTel t+ ([ Candidate LocalCandidate absArg absTy (infoOverlapMode arg)+ | isInstance arg+ ] ++) <$>+ instanceFields' False (LocalCandidate, absArg, absTy) -- Compute whether we should block this instance constraint at the -- discrimination tree stage.@@ -191,7 +212,7 @@ recursive = useTC stConsideringInstance hack = useTC stInstanceHack enabled = useTC (stPragmaOptions . lensOptExperimentalLazyInstances . lensCollapseDefault)- mutual = caseMaybeM (asksTC envMutualBlock) (pure mempty) \ mb ->+ mutual = caseMaybeM (viewTC eMutualBlock) (pure mempty) \ mb -> mutualNames <$> lookupMutualBlock mb andM@@ -318,7 +339,7 @@ -- I do not understand why the Constructor case is not impossible. -- Ulf, 2014-08-20: constructors are always instances. Constructor{ conSrcCon = c } -> Con c ConOSystem []- _ -> Def q $ map Apply args+ _ -> Def q $! map' Apply args mode = case defInstance def of Just i -> instanceOverlap i@@ -373,7 +394,7 @@ 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- reportSLn "tc.instance" 70 $ "findInstance 1: t: " ++ prettyShow t+ reportSLn "tc.instance" 70 $ "findInstance 1: t: " ++! prettyShow t -- Issue #2577: If the target is a function type the arguments are -- potential candidates, so we add them to the context to make@@ -416,7 +437,7 @@ lift (foldrM insertCandidate [] cands) reportSDoc "tc.instance.sort" 20 $ nest 2 $- "sorted candidates" $$ vcat (map debugCandidate cands)+ "sorted candidates" $$ vcat (map' debugCandidate cands) pure cands @@ -514,17 +535,17 @@ mv <- lookupLocalMeta m setCurrentRange mv $ do reportSLn "tc.instance" 15 $- "findInstance 2: constraint: " ++ prettyShow m ++ "; candidates left: " ++ show (length cands)- reportSDoc "tc.instance" 60 $ nest 2 $ vcat $ map debugCandidate cands+ "findInstance 2: constraint: " ++! prettyShow m ++! "; candidates left: " ++! show (length cands)+ reportSDoc "tc.instance" 60 $ nest 2 $ vcat $ map' debugCandidate cands reportSDoc "tc.instance" 70 $ "raw" $$ do- nest 2 $ vcat $ map debugCandidateRaw cands+ nest 2 $ vcat $ map' debugCandidateRaw cands t <- getMetaTypeInContext m- reportSLn "tc.instance" 70 $ "findInstance 2: t: " ++ prettyShow t+ reportSLn "tc.instance" 70 $ "findInstance 2: t: " ++! prettyShow t insidePi t $ \ t -> do reportSDoc "tc.instance" 15 $ "findInstance 3: t =" <+> prettyTCM t- reportSLn "tc.instance" 70 $ "findInstance 3: t: " ++ prettyShow t+ reportSLn "tc.instance" 70 $ "findInstance 3: t: " ++! prettyShow t mcands <- -- Temporarily remove other instance constraints to avoid@@ -548,7 +569,7 @@ let sortedErrs = List.sortBy (compare `on` precision) errs where precision (_, err) = maybe infinity iLength $ rangeToInterval $ getRange err infinity = 1000000000- setCurrentRange (take 1 $ map snd sortedErrs) $+ setCurrentRange (take' 1 $ map' snd sortedErrs) $ typeError $ InstanceNoCandidate t [ (candidateTerm c, err) | (c, err) <- sortedErrs ] Just (errs, [(c@(Candidate q term t' _), v)]) -> do@@ -560,7 +581,7 @@ reportSDoc "tc.instance" 70 $ nest 2 $ "candidate v = " <+> pretty v - ctxElims <- map Apply <$> getContextArgs+ ctxElims <- map' Apply <$> getContextArgs equalTerm t (MetaV m ctxElims) v reportSDoc "tc.instance" 15 $ vcat@@ -576,10 +597,10 @@ return Nothing -- We’re done _ -> do- let cs = maybe cands (map fst . snd) mcands -- keep the current candidates if Nothing+ let cs = maybe cands (map' fst . snd) mcands -- keep the current candidates if Nothing reportSDoc "tc.instance" 15 $ text ("findInstance 5: refined candidates: ") <+>- prettyTCM (List.map candidateTerm cs)+ prettyTCM (map' candidateTerm cs) whenProfile Profile.Instances $ tick "findInstance: multiple candidates" return (Just (cs, neverUnblock)) @@ -595,7 +616,7 @@ Level{} -> __IMPOSSIBLE__ MetaV{} -> __IMPOSSIBLE__ DontCare{} -> __IMPOSSIBLE__- Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s+ Dummy s _ -> __IMPOSSIBLE_VERBOSE__ (show s) -- | Apply the computation to every argument in turn by resetting the state every -- time. Return the list of the arguments giving the result True.@@ -614,8 +635,8 @@ -> TCM ([(Candidate, TCErr)], [(Candidate, Term)]) filterResettingState m cands f = do ctxArgs <- getContextArgs- let ctxElims = map Apply ctxArgs- result <- mapM (\c -> do bs <- localTCStateSaving (f c); return (c, bs)) cands+ let ctxElims = map' Apply ctxArgs+ result <- mapM (\c -> (c,) <$> localTCStateSaving (f c)) cands -- Check that there aren't any hard failures case [ err | (_, (HellNo err, _)) <- result ] of@@ -633,7 +654,12 @@ _ -> True result'' <- dropSameCandidates m overlap result' case result'' of- [(c, v, s)] -> ([], [(c, v)]) <$ putTC s++ -- Have to use 'putTCPreservingStats' here otherwise the stats+ -- accumulated from checking other candidates and from+ -- 'dropSameCandidates' are lost.+ [(c, v, s)] -> ([], [(c, v)]) <$ putTCPreservingStats s+ _ -> do let bad = [ (c, err) | (c, (NoBecause err, _)) <- result ] good = [ (c, v) | (c, v, _) <- result'' ]@@ -678,7 +704,7 @@ -- If some of the candidates are overlappable/overlapping, then we -- should do the work. | otherwise = Bench.billTo [Bench.Typing, Bench.InstanceSearch, Bench.CheckOverlap] do- reportSDoc "tc.instance.overlap" 30 $ "overlapping instances:" $$ vcat (map (debugCandidate . itemC) cands)+ reportSDoc "tc.instance.overlap" 30 $ "overlapping instances:" $$ vcat (map' (debugCandidate . itemC) cands) sinkIncoherent . survivingCands <$> foldrM insert (OverlapState [] []) cands @@ -694,7 +720,7 @@ sinkIncoherent :: [item] -> [item] sinkIncoherent cands = case List.partition (isIncoherent . itemC) cands of (as, [c]) | all (isGlobal . itemC) as -> pure c- (as, cs) | all (isGlobal . itemC) as -> cs ++ as+ (as, cs) | all (isGlobal . itemC) as -> cs ++! as _ -> cands -- Insert a new item into the overlap state.@@ -736,7 +762,7 @@ [ "will become guard:" , nest 2 (debugCandidate new) , "old items:"- , nest 2 (vcat (map (debugCandidate . itemC) oldItems))+ , nest 2 (vcat (map' (debugCandidate . itemC) oldItems)) ] -- But we can't /just/ add it to the list of guards: the new@@ -767,9 +793,9 @@ [ "inserting new candidate:" , nest 2 (debugCandidate new) , "against old candidates"- , nest 2 (vcat (map (debugCandidate . itemC) oldItems))+ , nest 2 (vcat (map' (debugCandidate . itemC) oldItems)) , "and guarding candidates"- , nest 2 (vcat (map debugCandidate guards))+ , nest 2 (vcat (map' debugCandidate guards)) , "is guarded?" <+> prettyTCM guarded ] @@ -789,13 +815,15 @@ -- Take overlappable candidates into account cands <- resolveInstanceOverlap overlapOk rel fst3 cands0- reportSDoc "tc.instance.overlap" 30 $ "instances after resolving overlap:" $$ vcat (map (debugCandidate . fst3) cands)+ reportSDoc "tc.instance.overlap" 30 $ "instances after resolving overlap:" $$ vcat (map' (debugCandidate . fst3) cands) reportSDoc "tc.instance" 50 $ vcat [ "valid candidates:"- , nest 2 $ vcat [ if freshMetas v then "(redacted)" else- sep [ prettyTCM v ]- | (_, v, _) <- cands ] ]+ , nest 2 $ vcat+ [ if freshMetas v+ then sep [ pretty v, parens "contains fresh metas" ]+ else sep [ prettyTCM v ]+ | (_, v, _) <- cands ] ] case cands of [] -> return cands@@ -806,7 +834,7 @@ -- If there's nothing, try not to reduce the candidate. [cvd] -> pure [cvd] - cvd@(_, v, _) : vas -> do+ cvd@(_, v, st) : vas -> do let equal :: (Candidate, Term, a) -> TCM Bool equal (c, v', _)@@ -816,14 +844,20 @@ verboseBracket "tc.instance" 30 "dropSameCandidates: " $ do reportSDoc "tc.instance" 30 $ sep [ prettyTCM v <+> "==", nest 2 $ prettyTCM v' ] a <- uncurry piApplyM =<< ((,) <$> getMetaType m <*> getContextArgs)- pureEqualTermB a v v' <&> \case+ pureBlockOrEqualTerm a v v' <&> \case Left{} -> False Right b -> b -- If we do actually have to remove overlap then we have to reduce -- the candidate to eliminate any "phantom" dependencies on fresh -- metas.- v <- reduce v+ -- ... issue #8215: while fastReduce is perfectly happy to block+ -- on a meta that doesn't exist, the short-circuit blocking in+ -- maybeFastReduce explodes, we have to reduce in the new TC+ -- state.+ v <- localTCState do+ putTC st+ reduce v if | freshMetas v -> do reportSLn "tc.instance" 30 "dropSameCandidates: Solution of instance meta has fresh metas so we don't filter equal candidates yet"@@ -866,29 +900,28 @@ -- candidates that failed some constraints. checkCandidates :: MetaId -> Type -> [Candidate] -> TCM (Maybe ([(Candidate, TCErr)], [(Candidate, Term)])) checkCandidates m t cands =- verboseBracket "tc.instance.candidates" 20 ("checkCandidates " ++ prettyShow m) $- ifM (anyMetaTypes cands) (return Nothing) $ Just <$> do+ verboseBracket "tc.instance.candidates" 20 ("checkCandidates " ++! prettyShow m) $+ -- Andreas, 2026-05-07: Ulf, 2015-10-31 commit 711bc27+ -- If there are candidates of meta type we won't be able to solve the constraint+ -- anyway and trying can be very expensive since checking a candidate might+ -- lead to further instance problems (exponential in depth).+ ifM (anyM (isMetaV . candidateType) cands) (return Nothing) $ Just <$> do reportSDoc "tc.instance.candidates" 20 $ nest 2 $ "target:" <+> prettyTCM t reportSDoc "tc.instance.candidates" 20 $ nest 2 $ vcat- [ "candidates", vcat (map debugCandidate cands) ]+ [ "candidates", vcat (map' debugCandidate cands) ] t <- instantiateFull t cands'@(_, okay) <- filterResettingState m cands (checkCandidateForMeta m t) reportSDoc "tc.instance.candidates" 20 $ nest 2 $ vcat- [ "valid candidates", vcat (map (debugCandidate . fst) okay) ]+ [ "valid candidates", vcat (map' (debugCandidate . fst) okay) ] reportSDoc "tc.instance.candidates" 60 $ nest 2 $ vcat- [ "valid candidates", vcat (map (debugCandidateTerm . fst) okay) ]+ [ "valid candidates", vcat (map' (debugCandidateTerm . fst) okay) ] return cands' where- anyMetaTypes :: [Candidate] -> TCM Bool- anyMetaTypes [] = return False- anyMetaTypes (Candidate _ _ a _ : cands) = do- a <- instantiate a- case unEl a of- MetaV{} -> return True- _ -> anyMetaTypes cands+ isMetaV :: Type -> TCM Bool+ isMetaV a = isJust . isMeta <$> instantiate a checkDepth :: Term -> Type -> TCM YesNo -> TCM YesNo checkDepth c a k = locallyTC eInstanceDepth succ $ do@@ -906,7 +939,7 @@ -- current instance meta, thus, we set the range. mv <- lookupLocalMeta m setCurrentRange mv $ runCandidateCheck $- verboseBracket "tc.instance" 20 ("checkCandidateForMeta " ++ prettyShow m) $ do+ verboseBracket "tc.instance" 20 ("checkCandidateForMeta " ++! prettyShow m) $ do reportSDoc "tc.instance" 20 $ vcat [ "checkCandidateForMeta" , " t =" <+> prettyTCM t@@ -937,7 +970,11 @@ -- Check whether this candidate is OK, and whether it is okay -- for the overlap check. For the candidate to be acceptable, -- its type must be a subtype of the goal type.- (cons, overlapOk) <- ifNoConstraints_ (leqType t'' t) (pure ([], True)) \pid -> do+ -- Issue #8866: the candidate must also not solve metas of the+ -- goal type directly (e.g. @spec : C Z@ for goal @C ?B@).+ -- Instantiating such a meta by another meta is fine.+ goalMetas <- allMetasList <$> instantiateFull t+ (cons, overlapOk0) <- ifNoConstraints_ (leqType t'' t) (pure ([], True)) \pid -> do -- To know if this candidate is safe for overlap, we have to -- check that it does not constrain the type of the instance -- goal. We can do this by running it in a new problem and@@ -949,8 +986,16 @@ stealConstraints pid let blocking = foldMap (allBlockingMetas . constraintUnblocker) cons- !ok = getAll $! flip allMetas t (All . not . flip Set.member blocking)+ !ok = getAll $! allMetas (All . not . flip Set.member blocking) t pure (cons, ok)+ let+ stillFlexible :: MetaId -> TCM Bool+ stillFlexible x = lookupMetaInstantiation x >>= \case+ InstV i -> instantiate (instBody i) <&> \case+ MetaV{} -> True+ _ -> False+ _ -> pure True+ overlapOk <- (overlapOk0 &&) <$> allM stillFlexible goalMetas debugConstraints flip catchError (return . NoBecause) $ do@@ -968,7 +1013,7 @@ reportSDoc "tc.instance.overlap" 30 $ "candidate" <+> prettyTCM v <+> "okay for overlap?" <+> prettyTCM overlapOk- $$ vcat (map prettyTCM cons)+ $$ vcat (map' prettyTCM cons) whenProfile Profile.Instances $ tick "checkCandidateForMeta: yes" return $ Yes v overlapOk@@ -1040,7 +1085,7 @@ Constructor {conPars = n, conData = d} -> do -- Szumi, 2025-05-05, issue #7853: don't drop parameters from the current module. fv <- getDefFreeVars d- return $ Con c ci (map Apply $ drop (n - fv) vs)+ return $! Con c ci $! map' Apply $ drop (n - fv) vs _ -> __IMPOSSIBLE__ -- Def f [] -> do -- -- Andreas, 2022-03-07, issue #5809: don't drop parameters of irrelevant projections.@@ -1086,22 +1131,24 @@ Level{} -> __IMPOSSIBLE__ MetaV{} -> __IMPOSSIBLE__ DontCare{} -> __IMPOSSIBLE__- Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s+ Dummy s _ -> __IMPOSSIBLE_VERBOSE__ (show s) -- | Register the definition with the given type as an instance. -- Issue warnings if instance is unusable. addTypedInstance ::- QName -- ^ Name of instance.- -> Type -- ^ Type of instance.+ KwRange -- ^ Range of the @instance@ keyword.+ -> QName -- ^ Name of instance.+ -> Type -- ^ Type of instance. -> TCM () addTypedInstance = addTypedInstance' True False Nothing -- | Like 'addTypedInstance', but delete any existing entries for the -- given name from the discrimination tree. readdTypedInstance ::- QName -- ^ Name of instance.- -> Type -- ^ Type of instance.+ KwRange -- ^ Range of the @instance@ keyword.+ -> QName -- ^ Name of instance.+ -> Type -- ^ Type of instance. -> TCM () readdTypedInstance = addTypedInstance' True True Nothing @@ -1110,10 +1157,11 @@ :: Bool -- ^ Should we print warnings for unusable instance declarations? -> Bool -- ^ Is this the second time we're adding this QName as an instance? -> Maybe InstanceInfo -- ^ Is this instance a copy?+ -> KwRange -- ^ Range of the @instance@ keyword. -> QName -- ^ Name of instance. -> Type -- ^ Type of instance. -> TCM ()-addTypedInstance' w readd orig inst t = do+addTypedInstance' w readd orig kwr inst t = do reportSDoc "tc.instance.add" 30 $ vcat [ "adding typed instance" <+> prettyTCM inst <+> "with type" , prettyTCM =<< flip abstract t <$> getContextTelescope@@ -1145,7 +1193,7 @@ setTCLens stInstanceTree tree' modifyTCLens' (stSignature . sigInstances . itableCounts) $- if readd then Map.insertWith (+) n 1 else id+ if readd then id else Map.insertWith (+) n 1 let info = flip fromMaybe orig InstanceInfo@@ -1169,18 +1217,20 @@ OutputTypeNameNotYetKnown b -> do addUnknownInstance inst- addConstraint b $ ResolveInstanceHead inst+ addConstraint b $ ResolveInstanceHead kwr inst - NoOutputTypeName -> when w $ warning $ WrongInstanceDeclaration- OutputTypeVar -> when w $ warning $ WrongInstanceDeclaration- OutputTypeVisiblePi -> when w $ warning $ InstanceWithExplicitArg inst+ NoOutputTypeName -> when w $ warning $ WrongInstanceDeclaration kwr+ OutputTypeVar -> when w $ warning $ WrongInstanceDeclaration kwr+ OutputTypeVisiblePi -> when w $ warning $ InstanceWithExplicitArg kwr inst -resolveInstanceHead :: QName -> TCM ()-resolveInstanceHead q = do+resolveInstanceHead ::+ KwRange -- ^ The range of the @instance@ keyword.+ -> QName -> TCM ()+resolveInstanceHead kwr q = do clearUnknownInstance q -- Andreas, 2022-12-04, issue #6380: -- Do not warn about unusable instances here.- addTypedInstance' False True Nothing q =<< typeOfConst q+ addTypedInstance' False True Nothing kwr q =<< typeOfConst q -- | Try to solve the instance definitions whose type is not yet known, report -- an error if it doesn't work and return the instance table otherwise.
src/full/Agda/TypeChecking/InstanceArguments.hs-boot view
@@ -2,6 +2,7 @@ import Agda.TypeChecking.Monad.Base (TCM, InstanceInfo) +import Agda.Syntax.Common (KwRange) import Agda.Syntax.Internal (QName, Type) -addTypedInstance' :: Bool -> Bool -> Maybe InstanceInfo -> QName -> Type -> TCM ()+addTypedInstance' :: Bool -> Bool -> Maybe InstanceInfo -> KwRange -> QName -> Type -> TCM ()
src/full/Agda/TypeChecking/Irrelevance.hs view
@@ -92,6 +92,14 @@ import Agda.Utils.Impossible +checkIrrelevanceAllowed :: LensRelevance a => a -> TCM ()+checkIrrelevanceAllowed x = unlessM isIrrelevanceEnabled $+ when (isIrrelevant x) $ typeError NeedOptionIrrelevance++checkAllIrrelevanceAllowed :: (Traversable f, LensRelevance a) => f a -> TCM ()+checkAllIrrelevanceAllowed xs = unlessM isIrrelevanceEnabled $+ when (any isIrrelevant xs) $ typeError NeedOptionIrrelevance+ -- | Check whether something can be used in a position of the given relevance. -- -- This is a substitute for double-checking that only makes sure@@ -108,7 +116,7 @@ -- class UsableRelevance a where usableRel- :: (ReadTCState m, HasConstInfo m, MonadTCEnv m, MonadAddContext m, MonadDebug m)+ :: (ReadTCState m, HasConstInfo m, MonadAddContext m) => Relevance -> a -> m Bool instance UsableRelevance Term where@@ -147,7 +155,7 @@ LockUniv -> return True LevelUniv -> return True IntervalUniv -> return True- PiSort a s1 s2 -> usableRel rel (a,s1,s2)+ PiSort _c a s1 s2 -> usableRel rel (a,s1,s2) FunSort s1 s2 -> usableRel rel (s1,s2) UnivSort s -> usableRel rel s MetaS x es -> usableRel rel es@@ -182,7 +190,7 @@ in usableRel (rel `composeRelevance` rel') u instance UsableRelevance a => UsableRelevance (Dom a) where- usableRel rel Dom{unDom = u} = usableRel rel u+ usableRel rel d = usableRel rel (unDom d) instance (Subst a, UsableRelevance a) => UsableRelevance (Abs a) where usableRel rel abs = underAbstraction_ abs $ \u -> usableRel rel u@@ -202,7 +210,7 @@ -- class UsableModality a where usableMod- :: (ReadTCState m, HasConstInfo m, MonadTCEnv m, MonadAddContext m, MonadDebug m, MonadReduce m, MonadError Blocker m)+ :: (HasConstInfo m, MonadAddContext m, MonadReduce m, MonadError Blocker m) => Modality -> a -> m Bool instance UsableModality Term where@@ -248,7 +256,9 @@ Sort s -> usableMod mod s Level l -> return True MetaV m vs -> do- mmod <- lookupMetaModality m+ -- Polarity is a pure modality, as for definitions (see above).+ -- (The free variables of the meta solution are checked via @vs@.)+ mmod <- setModalPolarity mixedPolarity <$> lookupMetaModality m let ok = mmod `moreUsableModality` mod reportSDoc "tc.irr" 50 $ "Metavariable" <+> prettyTCM (MetaV m []) <+>@@ -260,8 +270,7 @@ DontCare v -> usableMod mod v Dummy{} -> return True -usableModAbs :: (Subst a, MonadAddContext m, UsableModality a,- ReadTCState m, HasConstInfo m, MonadReduce m, MonadError Blocker m) =>+usableModAbs :: (Subst a, MonadAddContext m, UsableModality a, HasConstInfo m, MonadReduce m, MonadError Blocker m) => ArgInfo -> Modality -> Abs a -> m Bool usableModAbs info mod abs = underAbstraction (setArgInfo info $ __DUMMY_DOM__) abs $ \ u -> usableMod mod u @@ -297,7 +306,7 @@ in usableMod (mod `composeModality` mod') u instance UsableModality a => UsableModality (Dom a) where- usableMod mod Dom{unDom = u} = usableMod mod u+ usableMod mod d = usableMod mod (unDom d) usableAtModality' :: MonadConstraint TCM -- Note: This weird-looking constraint is to trick GHC into accepting@@ -315,6 +324,71 @@ usableAtModality :: MonadConstraint TCM => WhyCheckModality -> Modality -> Term -> TCM () usableAtModality = usableAtModality' Nothing +-- | Given a partitioning of the context into the local context, telescope of+-- of pattern variables and pattern-lambda bound variables, return whether+-- the given variable is one of the pattern variables.+isPatternVar :: Nat -> Nat -> Nat -> Bool+isPatternVar k0 k1 x = k0 > x && x >= k1++{-# SPECIALIZE isDefSing :: Nat -> Nat -> Type -> TCM DefSing #-}+-- | Compute whether a type is a definitional singleton or might become one+-- after a substitution or after the addition of some rewrite rules+-- Assumes type passed in has been reduced (otherwise will be even more+-- conservative than necessary).+isDefSing :: (PureTCM m, MonadBlock m) => Nat -> Nat -> Type -> m DefSing+isDefSing k0 k1 a = do+ let s = getSort a+ p <- isProp <$> abortIfBlocked s+ -- Strict propositions are always definitional singletons+ if p+ then pure MaybeSing+ else do+ case unEl a of+ Var x _ ->+ -- Pattern variables might get substituted for definitional singletons+ -- but bound variables cannot+ if isPatternVar k0 k1 x then pure MaybeSing else pure NeverSing+ Lam _ _ -> __IMPOSSIBLE__+ Lit _ -> __IMPOSSIBLE__+ Def d es -> do+ def <- theDef <$> getConstInfo d+ case def of+ Datatype{} -> pure NeverSing+ Record{recTel=tel} -> case recEtaEquality def of+ YesEta -> do+ let Just vs = allApplyElims es+ sings <- traverse (isDefSing' k0 k1) $ tel `apply` vs+ pure $ foldr minDefSing AlwaysSing sings+ NoEta _ -> pure NeverSing+ Axiom{} -> pure $ NeverSing+ -- TODO: Postulated type formers might still become definitionally+ -- singular if further rewrites are added (see #8266)+ DataOrRecSig{} -> pure NeverSing+ AbstractDefn{} -> pure MaybeSing+ -- I am erring on the side of caution here: specifically, I am+ -- worried about the possibility that a rewrite might look fine+ -- outside of an abstract block, but then inside an abstract block,+ -- all the abstract definitions will reduce and the rewrite will+ -- become invalid.+ Function{} -> pure MaybeSing+ Primitive{} -> pure MaybeSing+ PrimitiveSort{} -> __IMPOSSIBLE__+ GeneralizableVar{} -> __IMPOSSIBLE__+ Constructor{} -> __IMPOSSIBLE__+ Con _ _ _ -> __IMPOSSIBLE__+ Pi _ (unAbs -> b) -> isDefSing k0 (k1 + 1) b+ Sort _ -> pure NeverSing+ Level _ -> __IMPOSSIBLE__+ MetaV _ _ -> __IMPOSSIBLE__+ DontCare a -> __IMPOSSIBLE__+ Dummy _ _ -> __IMPOSSIBLE__++{-# SPECIALIZE isDefSing' :: Nat -> Nat -> Dom Type -> TCM DefSing #-}+isDefSing' :: (PureTCM m, MonadBlock m) => Nat -> Nat -> Dom Type -> m DefSing+isDefSing' k0 k1 t =+ if isIrrelevant $ getRelevance t+ then pure AlwaysSing+ else isDefSing k0 k1 $ unDom t -- * Propositions
src/full/Agda/TypeChecking/Level.hs view
@@ -8,7 +8,10 @@ import Agda.Syntax.Common import Agda.Syntax.Internal -import Agda.TypeChecking.Free.Lazy+import Agda.TypeChecking.Free++import Agda.Utils.ExpandCase+ import Agda.TypeChecking.Monad import Agda.TypeChecking.Substitute import Agda.TypeChecking.Reduce@@ -254,5 +257,6 @@ applySubst sub (SinglePlus a) = SinglePlus $ applySubst sub a instance Free t => Free (SingleLevel' t) where- freeVars' (SingleClosed m) = mempty- freeVars' (SinglePlus a) = freeVars' a+ freeVars l = expand \ret -> case l of+ SingleClosed m -> ret mempty+ SinglePlus a -> ret $ freeVars a
src/full/Agda/TypeChecking/LevelConstraints.hs view
@@ -11,7 +11,7 @@ import Agda.TypeChecking.Level import Agda.Utils.Impossible-import Agda.Utils.List (nubOn)+import Agda.Utils.List import Agda.Utils.List1 (List1) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Update@@ -28,7 +28,15 @@ -> List1 Constraint -- ^ Other constraints, enable simplification. -> Maybe [Constraint] -- ^ @Just@: list of constraints equal to the original @c@. -- @Nothing@: no simplification possible.-simplifyLevelConstraint c others = do+simplifyLevelConstraint c others+ -- Andreas, 2026-10-29, issue #8881:+ -- @a ≤ b₁ ⊔ ... ⊔ bₙ@ and @bᵢ ≤ a@ for all @i@ give @a = b₁ ⊔ ... ⊔ bₙ@.+ | LevelCmp CmpLeq a b <- c+ , Just a' <- singleLevelView a+ , all (\ b' -> any (matchLeq (b' :=< a')) leqs) (levelMaxView b)+ = Just [ LevelCmp CmpEq a b ]++ | otherwise = do cs <- inequalities c case runChange $ mapM simpl cs of (cs', True) -> Just cs'@@ -44,17 +52,17 @@ data Leq = SingleLevel :=< SingleLevel deriving (Show, Eq) +{-# SPECIALIZE freeVarList :: (SingleLevel, SingleLevel) -> [Int] #-}+ -- | Check if two inequality constraints are the same up to variable renaming. matchLeq :: Leq -> Leq -> Bool matchLeq (a :=< b) (c :=< d) | length xs == length ys = (a, b) == applySubst rho (c, d) | otherwise = False where- free :: Free a => a -> [Int]- free = nubOn id . runFree (:[]) IgnoreNot -- Note: use a list to preserve order of variables- xs = free (a, b)- ys = free (c, d)- rho = mkSub $ List.sort $ zip ys xs+ xs = nubOn id . freeVarList $ (a, b) -- Note: use a list to preserve order of variables+ ys = nubOn id . freeVarList $ (c, d)+ rho = mkSub $ List.sort $ zip' ys xs mkSub = go 0 where go _ [] = IdS@@ -68,7 +76,7 @@ inequalities :: Constraint -> Maybe [Leq] inequalities (LevelCmp CmpLeq a b)- | Just b' <- singleLevelView b = Just $ map (:=< b') $ List1.toList $ levelMaxView a+ | Just b' <- singleLevelView b = Just $! map' (:=< b') $ List1.toList $ levelMaxView a -- Andreas, 2016-09-28 -- Why was this most natural case missing? -- See test/Succeed/LevelLeqGeq.agda for where it is useful!@@ -79,12 +87,12 @@ inequalities (LevelCmp CmpEq a b) | Just a' <- singleLevelView a = case List1.break (== a') (levelMaxView b) of- (bs0, _ : bs1) -> Just [ b' :=< a' | b' <- bs0 ++ bs1 ]+ (bs0, _ : bs1) -> Just $! map' (\b' -> b' :=< a') (bs0 ++! bs1) _ -> Nothing inequalities (LevelCmp CmpEq a b) | Just b' <- singleLevelView b = case List1.break (== b') (levelMaxView a) of- (as0, _ : as1) -> Just [ a' :=< b' | a' <- as0 ++ as1 ]+ (as0, _ : as1) -> Just $! map' (\a' -> a' :=< b') (as0 ++! as1) _ -> Nothing inequalities _ = Nothing
src/full/Agda/TypeChecking/Lock.hs view
@@ -9,8 +9,10 @@ ) where +import Prelude hiding (null)+import qualified Prelude as Prelude+ import qualified Data.IntMap as IMap-import qualified Data.IntSet as ISet import qualified Data.Set as Set import Agda.Syntax.Common@@ -24,14 +26,15 @@ import Agda.TypeChecking.Free import qualified Agda.Utils.List1 as List1-import qualified Agda.Utils.VarSet as VSet-import Agda.Utils.Functor+import qualified Agda.Utils.VarSet as VarSet+import Agda.Utils.VarSet (VarSet) import Agda.Utils.Maybe import Agda.Utils.Monad+import Agda.Utils.Null import Agda.Utils.Size -checkLockedVars- :: Term+checkLockedVars ::+ Term -- ^ term to check -> Type -- ^ its type@@ -40,15 +43,23 @@ -> Type -- ^ type of the lock -> TCM ()-checkLockedVars t ty lk lk_ty = catchConstraint (CheckLockedVars t ty lk lk_ty) $ do+checkLockedVars t ty lk lk_ty = do -- Have to instantiate the lock, otherwise we might block on it even -- after it's been solved (e.g.: it's an interaction point, see #6528) -- Update (Andreas, 2023-10-23, issue #6913): need even full instantiation. -- Since @lk@ is typically just a variable, 'instantiateFull' is not expensive here. -- In #6913 it was a postulate applied to a meta, thus, 'instantiate' was not enough. lk <- instantiateFull lk+ catchConstraint (CheckLockedVars t ty lk lk_ty) do+ reportSDoc "tc.term.lock" 40 $ "Checking locked vars.."- reportSDoc "tc.term.lock" 50 $ nest 2 $ vcat+ reportSDoc "tc.term.lock" 45 $ nest 2 $ vcat+ [ text "t = " <+> prettyTCM t+ , text "ty = " <+> prettyTCM ty+ , text "lk = " <+> prettyTCM lk+ , text "lk_ty = " <+> prettyTCM lk_ty+ ]+ reportSDoc "tc.term.lock" 80 $ nest 2 $ vcat [ text "t = " <+> pretty t , text "ty = " <+> pretty ty , text "lk = " <+> pretty lk@@ -60,35 +71,35 @@ caseMaybe mi (typeError (DoesNotMentionTicks t ty lk)) $ \ i -> do cxt <- getContext- let toCheck = zip [0..] $ zipWith raise [1..] (take i cxt) - let fv = freeVarsIgnore IgnoreInAnnotations (t,ty)+ let fv = freeVarMapIgnoreAnn (t,ty) let rigid = rigidVars fv -- flexible = IMap.keysSet $ flexibleVars fv termVars = allVars fv -- ISet.union rigid flexible- earlierVars = ISet.fromList [i + 1 .. size cxt - 1]- if termVars `ISet.isSubsetOf` earlierVars then return () else do+ earlierVars = VarSet.range i (size cxt)+ if termVars `VarSet.isSubsetOf` earlierVars then return () else do + let toCheck = zip [0..] $ zipWith raise [1..] $ cxTake i cxt checked <- fmap catMaybes . forM toCheck $ \ (j,ce) -> do ifM (isTimeless (ctxEntryType ce)) (return $ Just j) (return $ Nothing) - let allowedVars = ISet.union earlierVars (ISet.fromList checked)+ let allowedVars = VarSet.union earlierVars (VarSet.fromList checked) - if termVars `ISet.isSubsetOf` allowedVars then return () else do+ if termVars `VarSet.isSubsetOf` allowedVars then return () else do let- illegalVars = rigid ISet.\\ allowedVars+ illegalVars = rigid `VarSet.difference` allowedVars -- flexVars = flexibleVars fv -- blockingMetas = map (`lookupVarMap` flexVars) (ISet.toList $ termVars ISet.\\ allowedVars)- if ISet.null illegalVars then -- only flexible vars are infringing+ if null illegalVars then -- only flexible vars are infringing -- TODO: be more precise about which metas -- flexVars = flexibleVars fv -- blockingMetas = map (`lookupVarMap` flexVars) (ISet.toList $ termVars ISet.\\ allowedVars) patternViolation alwaysUnblock else- typeError $ ReferencesFutureVariables t (List1.fromList (ISet.toList illegalVars)) lk i+ typeError $ ReferencesFutureVariables t (List1.fromList (VarSet.toAscList illegalVars)) lk i -- List1.fromList is guarded by not (null illegalVars) @@ -96,7 +107,7 @@ getLockVar :: Term -> TCMT IO (Maybe Int) getLockVar lk = do let- fv = freeVarsIgnore IgnoreInAnnotations lk+ fv = freeVarMapIgnoreAnn lk flex = flexibleVars fv isLock i = fmap (getLock . domInfo) (domOfBV i) <&> \case@@ -110,7 +121,7 @@ -- We should not block on solved metas, so we need @lk@ to be fully instantiated, -- otherwise it may mention solved metas which end up here. - is <- filterM isLock $ ISet.toList $ rigidVars fv+ is <- filterM isLock $ VarSet.toAscList $ rigidVars fv -- Out of the lock variables that appear in @lk@ the one in the -- left-most position in the context is what will determine the@@ -131,8 +142,8 @@ -- | If the first argument is a lock variable, check that all variables in the given set -- are either earlier than this variable or are timeless. ---checkEarlierThan :: Term -> VSet.VarSet -> TCM Bool+checkEarlierThan :: Term -> VarSet -> TCM Bool checkEarlierThan lk fvs = do getLockVar lk >>= \case Nothing -> return True- Just i -> allM (isTimeless <=< typeOfBV) $ filter (<= i) $ VSet.toList fvs+ Just i -> allM (isTimeless <=< typeOfBV) $ filter (<= i) $ VarSet.toAscList fvs
src/full/Agda/TypeChecking/MetaVars.hs view
@@ -9,7 +9,6 @@ import Control.Monad.Except ( MonadError(..), ExceptT, runExceptT ) import Control.Monad.Trans.Maybe -import qualified Data.IntSet as IntSet import qualified Data.IntMap as IntMap import qualified Data.List as List import qualified Data.Map.Strict as MapS@@ -46,14 +45,14 @@ import Agda.TypeChecking.SizedTypes (boundedSizeMetaHook, isSizeProblem) import {-# SOURCE #-} Agda.TypeChecking.CheckInternal import {-# SOURCE #-} Agda.TypeChecking.Conversion+import Agda.TypeChecking.Warnings (warning) -- import Agda.TypeChecking.CheckInternal -- import {-# SOURCE #-} Agda.TypeChecking.CheckInternal (checkInternal)-import Agda.TypeChecking.MetaVars.Occurs+import Agda.TypeChecking.MetaVars.Occurs (occursCheck, prune, PruneResult(..)) import qualified Agda.Utils.BiMap as BiMap import Agda.Utils.Function-import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.List1 (List1, pattern (:|)) import qualified Agda.Utils.List1 as List1@@ -63,7 +62,7 @@ import Agda.Utils.Tuple import Agda.Utils.Permutation import Agda.Syntax.Common.Pretty (Pretty, prettyShow, render)-import qualified Agda.Utils.ProfileOptions as Profile+import qualified Agda.Interaction.Options.ProfileOptions as Profile import Agda.Utils.Singleton import qualified Agda.Utils.Graph.TopSort as Graph import Agda.Utils.VarSet (VarSet)@@ -72,20 +71,38 @@ import Agda.Utils.Impossible instance MonadMetaSolver TCM where- newMeta' = newMetaTCM'- assignV dir x args v t = assignWrapper dir x (map Apply args) v $ assign dir x args v t- assignTerm' = assignTermTCM'- etaExpandMeta = etaExpandMetaTCM- updateMetaVar = updateMetaVarTCM+ newMeta' inst frozen mi p perm j = ifImpureConv (newMetaTCM' inst frozen mi p perm j) $+ patternViolation alwaysUnblock -- TODO: does this happen? - -- Right now we roll back the full state when aborting.- -- TODO: only roll back the metavariables- speculateMetas fallback m = do- (a, s) <- localTCStateSaving m- case a of- KeepMetas -> putTC s- RollBackMetas -> fallback+ assignV dir x args v t = ifImpureConv (assignWrapper dir x (map' Apply args) v $ assign dir x args v t) $ do+ bv <- isBlocked v+ let blocker = caseMaybe bv id unblockOnEither $ unblockOnMeta x+ patternViolation blocker + assignTerm' m tel v = ifImpureConv (assignTermTCM' m tel v) $ do+ bv <- isBlocked v+ let blocker = caseMaybe bv id unblockOnEither $ unblockOnMeta m+ patternViolation blocker++ etaExpandMeta x y = ifImpureConv (etaExpandMetaTCM x y) $+ return ()++ updateMetaVar x y = ifImpureConv (updateMetaVarTCM x y) $+ patternViolation alwaysUnblock -- TODO: does this happen?++ {-# INLINE speculateMetas #-}+ -- Right now we roll back the full state when aborting.+ -- TODO: only roll back the metavariables+ speculateMetas fallback m = ifImpureConv+ (do (a, s) <- localTCStateSaving m+ case a of+ KeepMetas -> putTC s+ RollBackMetas -> fallback)+ (m >>= \case+ KeepMetas -> return ()+ RollBackMetas -> fallback)++ -- | Find position of a value in a list. -- Used to change metavar argument indices during assignment. --@@ -99,12 +116,12 @@ hasTwinMeta :: MetaId -> TCM Bool hasTwinMeta x = do m <- lookupLocalMeta x- return $ isJust $ mvTwin m+ 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? "+ reportSLn "tc.meta.blocked" 12 $ "is " ++! prettyShow x ++! " a blocked term? " i <- lookupMetaInstantiation x let r = case i of BlockedConst{} -> True@@ -112,13 +129,13 @@ InstV{} -> False OpenMeta{} -> False reportSLn "tc.meta.blocked" 12 $- if r then " yes, because " ++ prettyShow i else " no"+ if r then " yes, because " ++! prettyShow i else " no" return r isEtaExpandable :: [MetaClass] -> MetaId -> TCM Bool isEtaExpandable classes x = do i <- lookupMetaInstantiation x- return $ case i of+ return $! case i of OpenMeta UnificationMeta -> True OpenMeta InstanceMeta -> Records `notElem` classes InstV{} -> False@@ -132,7 +149,7 @@ -- The instantiation should not be an 'InstV' and the 'MetaId' -- should point to something 'Open' or a 'BlockedConst'. -- Further, the meta variable may not be 'Frozen'.-assignTerm :: MonadMetaSolver m => MetaId -> [Arg ArgName] -> Term -> m ()+assignTerm :: MetaId -> [Arg ArgName] -> Term -> TCM () assignTerm x tel v = do -- verify (new) invariants whenM (isFrozen x) __IMPOSSIBLE__@@ -141,12 +158,15 @@ -- | Skip frozen check. Used for eta expanding frozen metas. assignTermTCM' :: MetaId -> [Arg ArgName] -> Term -> TCM () assignTermTCM' x tel v = do+ let dummyFromArg (Arg i n) = defaultNamedArgDom i n __DUMMY_TYPE__+ reportSDoc "tc.meta.assign" 70 $ vcat- [ "assignTerm" <+> prettyTCM x <+> " := " <+> prettyTCM v- , nest 2 $ "tel =" <+> prettyList_ (map (text . unArg) tel)+ [ "assignTerm" <+> prettyTCM x <+> " := " <+>+ addContext (dummyFromArg <$> tel) (prettyTCM v)+ , nest 2 $ "tel =" <+> prettyList_ (map' (text . unArg) tel) ] -- verify (new) invariants- whenM (not <$> asksTC envAssignMetas) __IMPOSSIBLE__+ whenM (not <$> viewTC eAssignMetas) __IMPOSSIBLE__ whenProfile Profile.Metas $ liftTCM $ return () {-tickMax "max-open-metas" . (fromIntegral . size) =<< getOpenMetas-} updateMetaVarTCM x $ \ mv ->@@ -162,7 +182,7 @@ } etaExpandListeners x wakeupConstraints x- reportSLn "tc.meta.assign" 20 $ "completed assignment of " ++ prettyShow x+ reportSLn "tc.meta.assign" 20 $ "completed assignment of " ++! prettyShow x -- * Creating meta variables. @@ -173,9 +193,8 @@ hasBiggerSort x return x -{-# SPECIALIZE newSortMeta :: TCM Sort #-} -- | Create a sort meta that may be instantiated with 'Inf' (Setω).-newSortMeta :: MonadMetaSolver m => m Sort+newSortMeta :: TCM Sort newSortMeta = ifM hasUniversePolymorphism (newSortMetaCtx =<< getContextArgs) -- else (no universe polymorphism)@@ -184,7 +203,7 @@ x <- newMeta Instantiable i normalMetaPriority (idP 0) j reportSDoc "tc.meta.new" 50 $ "new sort meta" <+> prettyTCM x- return $ MetaS x []+ return $! MetaS x [] -- | Create a sort meta that may be instantiated with 'Inf' (Setω). newSortMetaCtx :: MonadMetaSolver m => Args -> m Sort@@ -195,7 +214,7 @@ x <- newMeta Instantiable i normalMetaPriority (idP $ size tel) $ IsSort () t reportSDoc "tc.meta.new" 50 $ "new sort meta" <+> prettyTCM x <+> ":" <+> prettyTCM t- return $ MetaS x $ map Apply vs+ return $! MetaS x $ map' Apply vs newTypeMeta' :: Comparison -> Sort -> TCM Type newTypeMeta' cmp s = El s . snd <$> newValueMeta RunMetaOccursCheck cmp (sort s)@@ -210,28 +229,22 @@ -- that it has a sort. The sort comes from the solution. -- newTypeMeta_ = newTypeMeta Inf -{-# SPECIALIZE newLevelMeta :: TCM Level #-}-newLevelMeta :: MonadMetaSolver m => m Level+newLevelMeta :: TCM Level newLevelMeta = do (x, v) <- newValueMeta RunMetaOccursCheck CmpEq =<< levelType- return $ case v of+ return $! case v of Level l -> l _ -> atomicLevel v -{-# SPECIALIZE newInstanceMeta :: MetaNameSuggestion -> Type -> TCM (MetaId, Term) #-} -- | @newInstanceMeta s t cands@ creates a new instance metavariable -- of type the output type of @t@ with name suggestion @s@.-newInstanceMeta- :: MonadMetaSolver m- => MetaNameSuggestion -> Type -> m (MetaId, Term)+newInstanceMeta :: MetaNameSuggestion -> Type -> TCM (MetaId, Term) newInstanceMeta s t = do vs <- getContextArgs ctx <- getContextTelescope newInstanceMetaCtx s (telePi_ ctx t) vs -newInstanceMetaCtx- :: MonadMetaSolver m- => MetaNameSuggestion -> Type -> Args -> m (MetaId, Term)+newInstanceMetaCtx :: MetaNameSuggestion -> Type -> Args -> TCM (MetaId, Term) newInstanceMetaCtx s t vs = do reportSDoc "tc.meta.new" 50 $ fsep [ "new instance meta:"@@ -250,77 +263,70 @@ let c = FindInstance r x Nothing addAwakeConstraint alwaysUnblock c etaExpandMetaSafe x- return (x, MetaV x $ map Apply vs)+ return (x, MetaV x $ map' Apply vs) -- | Create a new value meta with specific dependencies, possibly η-expanding in the process.-newNamedValueMeta :: MonadMetaSolver m => RunMetaOccursCheck -> MetaNameSuggestion -> Comparison -> Type -> m (MetaId, Term)+newNamedValueMeta :: RunMetaOccursCheck -> MetaNameSuggestion -> Comparison -> Type -> TCM (MetaId, Term) newNamedValueMeta b s cmp t = do (x, v) <- newValueMeta b cmp t setMetaNameSuggestion x s return (x, v) -- | Create a new value meta with specific dependencies without η-expanding.-newNamedValueMeta' :: MonadMetaSolver m => RunMetaOccursCheck -> MetaNameSuggestion -> Comparison -> Type -> m (MetaId, Term)+newNamedValueMeta' :: RunMetaOccursCheck -> MetaNameSuggestion -> Comparison -> Type -> TCM (MetaId, Term) newNamedValueMeta' b s cmp t = do (x, v) <- newValueMeta' b cmp t setMetaNameSuggestion x s return (x, v) -{-# SPECIALIZE newValueMetaOfKind :: A.MetaInfo -> RunMetaOccursCheck -> Comparison -> Type -> TCM (MetaId, Term) #-}-newValueMetaOfKind :: MonadMetaSolver m- => A.MetaInfo+newValueMetaOfKind ::+ A.MetaInfo -> RunMetaOccursCheck -- ^ Ignored for instance metas. -> Comparison -- ^ Ignored for instance metas. -> Type- -> m (MetaId, Term)+ -> TCM (MetaId, Term) newValueMetaOfKind info = case A.metaKind info of UnificationMeta -> newValueMeta InstanceMeta -> \ _run _cmp -> newInstanceMeta (A.metaNameSuggestion info) -{-# SPECIALIZE newValueMeta :: RunMetaOccursCheck -> Comparison -> Type -> TCM (MetaId, Term) #-} -- | Create a new metavariable, possibly η-expanding in the process.-newValueMeta :: MonadMetaSolver m => RunMetaOccursCheck -> Comparison -> Type -> m (MetaId, Term)+newValueMeta :: RunMetaOccursCheck -> Comparison -> Type -> TCM (MetaId, Term) newValueMeta b cmp t = do vs <- getContextArgs tel <- getContextTelescope newValueMetaCtx Instantiable b cmp t tel (idP $ size tel) vs -newValueMetaCtx- :: MonadMetaSolver m- => Frozen -> RunMetaOccursCheck -> Comparison -> Type -> Telescope -> Permutation -> Args -> m (MetaId, Term)+newValueMetaCtx ::+ Frozen -> RunMetaOccursCheck -> Comparison -> Type -> Telescope -> Permutation -> Args -> TCM (MetaId, Term) newValueMetaCtx frozen b cmp t tel perm ctx =- mapSndM instantiateFull =<< newValueMetaCtx' frozen b cmp t tel perm ctx+ secondM instantiateFull =<< newValueMetaCtx' frozen b cmp t tel perm ctx -{-# SPECIALIZE newValueMeta' :: RunMetaOccursCheck -> Comparison -> Type -> TCM (MetaId, Term) #-} -- | Create a new value meta without η-expanding.-newValueMeta'- :: MonadMetaSolver m- => RunMetaOccursCheck -> Comparison -> Type -> m (MetaId, Term)+newValueMeta' :: RunMetaOccursCheck -> Comparison -> Type -> TCM (MetaId, Term) newValueMeta' b cmp t = do vs <- getContextArgs tel <- getContextTelescope newValueMetaCtx' Instantiable b cmp t tel (idP $ size tel) vs -newValueMetaCtx'- :: MonadMetaSolver m- => Frozen -> RunMetaOccursCheck -> Comparison -> Type -> Telescope -> Permutation -> Args -> m (MetaId, Term)+newValueMetaCtx' ::+ Frozen -> RunMetaOccursCheck -> Comparison -> Type -> Telescope -> Permutation -> Args -> TCM (MetaId, Term) newValueMetaCtx' frozen b cmp a tel perm vs = do i <- createMetaInfo' b let t = telePi_ tel a x <- newMeta frozen i normalMetaPriority perm (HasType () cmp t) modality <- currentModality reportSDoc "tc.meta.new" 50 $ fsep- [ text $ "new meta (" ++ show (i ^. lensIsAbstract) ++ "):"+ [ text $ "new meta (" ++! show (i ^. lensIsAbstract) ++! "):" , nest 2 $ prettyTCM vs <+> "|-" , nest 2 $ pretty x <+> ":" <+> pretty modality <+> prettyTCM t ] etaExpandMetaSafe x -- Andreas, 2012-09-24: for Metas X : Size< u add constraint X+1 <= u- let u = MetaV x $ map Apply vs+ let u = MetaV x $ map' Apply vs boundedSizeMetaHook u tel a return (x, u) -newTelMeta :: MonadMetaSolver m => Telescope -> m Args+newTelMeta :: Telescope -> TCM Args newTelMeta tel = newArgsMeta (abstract tel $ __DUMMY_TYPE__) type Condition = Dom Type -> Abs Type -> Bool@@ -328,12 +334,10 @@ trueCondition :: Condition trueCondition _ _ = True -{-# SPECIALIZE newArgsMeta :: Type -> TCM Args #-}-newArgsMeta :: MonadMetaSolver m => Type -> m Args+newArgsMeta :: Type -> TCM Args newArgsMeta = newArgsMeta' trueCondition -{-# SPECIALIZE newArgsMeta' :: Condition -> Type -> TCM Args #-}-newArgsMeta' :: MonadMetaSolver m => Condition -> Type -> m Args+newArgsMeta' :: Condition -> Type -> TCM Args newArgsMeta' condition t = do args <- getContextArgs tel <- getContextTelescope@@ -342,36 +346,33 @@ newArgsMetaCtx :: Type -> Telescope -> Permutation -> Args -> TCM Args newArgsMetaCtx = newArgsMetaCtx' Instantiable trueCondition -newArgsMetaCtx''- :: MonadMetaSolver m- => MetaNameSuggestion -> Frozen -> Condition -> Type -> Telescope -> Permutation -> Args -> m Args+newArgsMetaCtx'' :: MetaNameSuggestion -> Frozen -> Condition -> Type -> Telescope -> Permutation -> Args -> TCM Args newArgsMetaCtx'' pref frozen condition (El s tm) tel perm ctx = do tm <- reduce tm case tm of- Pi dom@(Dom{domInfo = info, unDom = a}) codom | condition dom codom -> do- let mod = getModality info+ Pi dom@(unDom -> a) codom | condition dom codom -> do+ let info = (dom ^. dInfo)+ mod = getModality (dom ^. dInfo) -- Issue #3031: It's not enough to applyModalityToContext, since most (all?) -- of the context lives in tel. Don't forget the arguments in ctx. tel' = telFromList $- map (mod `inverseApplyModalityButNotQuantity`) $+ map' (mod `inverseApplyModalityButNotQuantity`) $ telToList tel- ctx' = map (mod `inverseApplyModalityButNotQuantity`) ctx- (m, u) <- applyModalityToContext info $- newValueMetaCtx frozen RunMetaOccursCheck CmpLeq a tel' perm ctx'+ ctx' = map' (mod `inverseApplyModalityButNotQuantity`) ctx+ (m, u) <- applyDomToContext dom $+ newValueMetaCtx frozen RunMetaOccursCheck CmpLeq a tel' perm ctx' -- Jesper, 2021-05-05: When creating a metavariable from a -- generalizable variable, we must set the modality at which it -- will be generalized. Don't do this for other metavariables,- -- as they should keep the defaul modality (see #5363).+ -- as they should keep the default modality (see #5363). whenM ((== YesGeneralizeVar) <$> viewTC eGeneralizeMetas) $ setMetaGeneralizableArgInfo m $ hideOrKeepInstance info setMetaNameSuggestion m (suffixNameSuggestion pref (absName codom)) args <- newArgsMetaCtx'' pref frozen condition (codom `absApp` u) tel perm ctx- return $ Arg info u : args+ return $! Arg info u : args _ -> return [] -newArgsMetaCtx'- :: MonadMetaSolver m- => Frozen -> Condition -> Type -> Telescope -> Permutation -> Args -> m Args+newArgsMetaCtx' :: Frozen -> Condition -> Type -> Telescope -> Permutation -> Args -> TCM Args newArgsMetaCtx' = newArgsMetaCtx'' mempty -- | Create a metavariable of record type. This is actually one metavariable@@ -397,7 +398,7 @@ let ftel = apply (_recTel rdef) pars fields <- newArgsMetaCtx'' pref frozen trueCondition (telePi_ ftel __DUMMY_TYPE__) tel perm ctx- return $ Con con ConOSystem (map Apply fields)+ return $! Con con ConOSystem $! map' Apply fields newQuestionMark :: InteractionId -> Comparison -> Type -> TCM (MetaId, Term) newQuestionMark ii cmp = newQuestionMark' (newValueMeta' RunMetaOccursCheck) ii cmp@@ -431,9 +432,10 @@ Just x -> do -- Get the context Γ in which the meta was created. MetaVar- { mvInfo = MetaInfo{ miClosRange = Closure{ clEnv = TCEnv{ envContext = gamma }}}+ { mvInfo = MetaInfo{ miClosRange = Closure{ clEnv = view eContext -> gamma }} , mvPermutation = p } <- fromMaybe __IMPOSSIBLE__ <$> lookupLocalMeta' x+ -- Get the current context Δ. delta <- getContext -- A bit hazardous:@@ -442,14 +444,16 @@ -- with substitutions to move between parent and child. let gxs = contextNames' gamma let dxs = contextNames' delta- let gys = map nameCanonical gxs- let dys = map nameCanonical dxs+ let gys = map' nameCanonical gxs+ let dys = map' nameCanonical dxs let glen = length gxs let dlen = length dxs reportSDoc "tc.interaction" 20 $ vcat [ "reusing meta"- , nest 2 $ "creation context:" <+> pretty gxs- , nest 2 $ "reusage context:" <+> pretty dxs+ , nest 2 $ "creation context:" <+> prettyTCM gamma+ -- , nest 2 $ "creation context:" <+> pretty gxs+ , nest 2 $ "reusage context:" <+> prettyTCM delta+ -- , nest 2 $ "reusage context:" <+> pretty dxs ] -- When checking a record declaration (e.g. Σ), creation context Γ@@ -476,7 +480,7 @@ ] __IMPOSSIBLE__ -- Apply the meta to |Γ| arguments from Δ.- return $ map var [dlen - glen .. dlen - 1]+ return $! map' var [dlen - glen .. dlen - 1] -- Case: record variable in the context. Just k -> do@@ -486,9 +490,10 @@ -- However, as they do not share common ancestry, the @nameId@s differ, -- so we consider only the original concrete names in gys and dys. -- This is a bit risky... blame goes to #434.- let (d2len, g1len) = findOverlap (take k dys) gys- reportSDoc "tc.interaction" 30 $ vcat $ map (nest 2)- [ "glen =" <+> pretty glen+ let (d2len, g1len) = findOverlap (take' k dys) gys+ reportSDoc "tc.interaction" 30 $ vcat $ map' (nest 2)+ [ "k =" <+> pretty k+ , "glen =" <+> pretty glen , "g0len =" <+> pretty g0len , "g1len =" <+> pretty g1len , "d2len =" <+> pretty d2len@@ -503,7 +508,7 @@ ] __IMPOSSIBLE__ -- The Γ₁ part should match.- unless ( ((==) `on` take g1len) gys (drop d2len dys) ) $ do+ unless ( ((==) `on` take' g1len) gys (drop d2len dys) ) $ do reportSDoc "impossible" 10 $ vcat [ "expecting meta-creation context (with fields instead of record var)" , nest 2 $ pretty gxs@@ -511,48 +516,53 @@ , nest 2 $ pretty dxs ] __IMPOSSIBLE__- let (vs1, v : vs0) = splitAt g1len $ map var [d2len..dlen-1]+ let (vs1, v : vs0) = splitAt' g1len $ map' var [d2len..dlen-1] -- We need to expand the record var @v@ into the correct number of fields. let numFields = glen - g1len - g0len- if numFields <= 0 then return $ vs1 ++ vs0 else do+ if numFields <= 0 then return $! vs1 ++! vs0 else do -- Get the record type.- let t = (unDom . ctxEntryDom) $ fromMaybe __IMPOSSIBLE__ $ delta !!! k+ let t = unDom $ ctxEntryDom $ fromMaybe __IMPOSSIBLE__ $+ cxLookup k delta -- Get the record field names.- fs <- getRecordTypeFields t+ fs <- reverse . take' numFields <$> getRecordTypeFields t+ -- Check that the record field names match+ -- the supposed record field names from the context of the original meta.+ let gfs = take' numFields (drop g1len gxs)+ reportSDoc "tc.interaction" 30 $ vcat $ map' (nest 2)+ [ "fs =" <+> pretty fs+ , "gfs =" <+> pretty gfs+ ]+ -- NameIds do not match, so we have to revert to the concrete name.+ -- unless (gfs == map' (qnameName . unDom) fs) __IMPOSSIBLE__+ unless (((==) `on` map' nameCanonical) gfs (map' (qnameName . unDom) fs)) __IMPOSSIBLE__ -- Field arguments to the original meta are projections from the record var.- let vfs = map ((\ x -> v `applyE` [Proj ProjSystem x]) . unDom) fs+ let vfs = map' ((\ x -> v `applyE` [Proj ProjSystem x]) . unDom) fs -- These are the final args to the original meta:- return $ vs1 ++ reverse (take numFields vfs) ++ vs0+ return $! vs1 ++! vfs ++! vs0 -- Use ArgInfo from Γ.- let args = zipWith (<$) (reverse rev_args) $ contextArgs gamma+ let args = zipWith' (<$) (reverse rev_args) $ contextArgs gamma -- Take the permutation into account (see TC.Monad.MetaVars.getMetaContextArgs). let vs = permute (takeP (length args) p) args reportSDoc "tc.interaction" 20 $ vcat [ "meta reuse arguments:" <+> prettyTCM vs ]- return (x, MetaV x $ map Apply vs)+ return (x, MetaV x $ map' Apply vs) -{-# SPECIALIZE blockTerm :: Type -> TCM Term -> TCM Term #-} -- | Construct a blocked constant if there are constraints.-blockTerm- :: (MonadMetaSolver m, MonadConstraint m, MonadFresh Nat m, MonadFresh ProblemId m)- => Type -> m Term -> m Term+blockTerm :: Type -> TCM Term -> TCM Term blockTerm t blocker = do (pid, v) <- newProblem blocker blockTermOnProblem t v pid -{-# SPECIALIZE blockTermOnProblem :: Type -> Term -> ProblemId -> TCM Term #-}-blockTermOnProblem- :: (MonadMetaSolver m, MonadFresh Nat m)- => Type -> Term -> ProblemId -> m Term+blockTermOnProblem :: Type -> Term -> ProblemId -> TCM Term blockTermOnProblem t v pid = do -- Andreas, 2012-09-27 do not block on unsolved size constraints solved <- isProblemSolved pid ifM (return solved `or2M` isSizeProblem pid)- (v <$ reportSLn "tc.meta.blocked" 20 ("Not blocking because " ++ show pid ++ " is " +++ (v <$ reportSLn "tc.meta.blocked" 20 ("Not blocking because " ++! show pid ++! " is " ++ if solved then "solved" else "a size problem")) $ do i <- createMetaInfo- es <- map Apply <$> getContextArgs+ es <- map' Apply <$> getContextArgs tel <- getContextTelescope x <- newMeta' (BlockedConst $ abstract tel v) Instantiable@@ -590,10 +600,7 @@ listenToMeta (CheckConstraint i cmp) x return v -{-# SPECIALIZE blockTypeOnProblem :: Type -> ProblemId -> TCM Type #-}-blockTypeOnProblem- :: (MonadMetaSolver m, MonadFresh Nat m)- => Type -> ProblemId -> m Type+blockTypeOnProblem :: Type -> ProblemId -> TCM Type blockTypeOnProblem (El s a) pid = El s <$> blockTermOnProblem (sort s) a pid -- | @unblockedTester t@ returns a 'Blocker' for @t@.@@ -631,8 +638,9 @@ m <- newMeta' (PostponedTypeCheckingProblem cl) Instantiable i normalMetaPriority (idP (size tel)) $ HasType () CmpLeq $ telePi_ tel t- inTopContext $ reportSDoc "tc.meta.postponed" 20 $ vcat- [ "new meta" <+> prettyTCM m <+> ":" <+> prettyTCM (telePi_ tel t)+ reportSDoc "tc.meta.postponed" 20 $ vcat+ [ "new meta" <+> inTopContext (prettyTCM m) <+>+ ":" <+> inTopContext (prettyTCM $ telePi_ tel t) , "for postponed typechecking problem" <+> prettyTCM p ] @@ -643,7 +651,7 @@ -- Since this meta's solution comes from user code, we do not need -- to run the extended occurs check (metaOccurs) to exclude -- non-terminating solutions.- es <- map Apply <$> getContextArgs+ es <- map' Apply <$> getContextArgs (_, v) <- newValueMeta DontRunMetaOccursCheck CmpLeq t cmp <- buildProblemConstraint_ (unblockOnMeta m) (ValueCmp CmpEq (AsTermsOf t) v (MetaV m es)) reportSDoc "tc.constr.add" 20 $ "adding constraint" <+> prettyTCM cmp@@ -664,8 +672,9 @@ -- | 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 :: [MetaClass] -> 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+etaExpandMetaTCM kinds m =+ whenM ((not <$> isFrozen m) `and2M` viewTC eAssignMetas `and2M` isEtaExpandable kinds m) $ do+ verboseBracket "tc.meta.eta" 20 ("etaExpandMeta " ++! prettyShow m) $ do let waitFor b = do reportSDoc "tc.meta.eta" 20 $ do "postponing eta-expansion of meta variable" <+>@@ -675,7 +684,7 @@ dontExpand = do reportSDoc "tc.meta.eta" 20 $ do "we do not expand meta variable" <+> prettyTCM m <+>- text ("(requested was expansion of " ++ show kinds ++ ")")+ text ("(requested was expansion of " ++! show kinds ++! ")") meta <- lookupLocalMeta m case mvJudgement meta of IsSort{} -> dontExpand@@ -719,13 +728,13 @@ u <- withMetaInfo' meta $ newRecordMetaCtx (miNameSuggestion (mvInfo meta)) (mvFrozen meta) r ps tel (idP $ size tel) $ teleArgs tel+ reportSDoc "tc.meta.eta" 15 $ sep+ [ "eta expanding: " <+> pretty m <+> " --> "+ , nest 2 $ prettyTCM u+ ] -- Andreas, 2019-03-18, AIM XXIX, issue #3597 -- When meta is frozen instantiate it with in-turn frozen metas. inTopContext $ do- reportSDoc "tc.meta.eta" 15 $ sep- [ "eta expanding: " <+> pretty m <+> " --> "- , nest 2 $ prettyTCM u- ] -- Andreas, 2012-03-29: No need for occurrence check etc. -- we directly assign the solution for the meta -- 2012-05-23: We also bypass the check for frozen.@@ -736,7 +745,7 @@ catchPatternErr (\x -> waitFor x) $ do ifM (isSingletonRecord r ps) expand dontExpand else dontExpand- ) $ {- else -} ifM (andM [ return $ Levels `elem` kinds+ ) $ {- else -} ifM (andM [ return $! Levels `elem` kinds , typeInType , (Just lvl ==) <$> getBuiltin' builtinLevel ]) (do@@ -750,7 +759,7 @@ -- | Eta expand blocking metavariables of record type, and reduce the -- blocked thing. -etaExpandBlocked :: (MonadReduce m, MonadMetaSolver m, IsMeta t, Reduce t)+etaExpandBlocked :: (MonadMetaSolver m, IsMeta t, Reduce t) => Blocked t -> m (Blocked t) etaExpandBlocked t@NotBlocked{} = return t etaExpandBlocked t@(Blocked _ v) | Just{} <- isMeta v = return t@@ -762,19 +771,49 @@ Blocked b' _ | b /= b' -> etaExpandBlocked t _ -> return t +-- | Is the term an @rewrite function?+-- Does not need to do reduction because of syntactic restrictions on+-- the placement of @rewrite+isRewPi :: Term -> Bool+isRewPi (Pi a b) = isJust (rewDom a) || isRewPi (unEl $ unAbs b)+isRewPi _ = False+ {-# SPECIALIZE assignWrapper :: CompareDirection -> MetaId -> Elims -> Term -> TCM () -> TCM () #-}-assignWrapper :: (MonadMetaSolver m, MonadConstraint m, MonadError TCErr m, MonadDebug m, HasOptions m)+assignWrapper :: (MonadMetaSolver m) => CompareDirection -> MetaId -> Elims -> Term -> m () -> m () assignWrapper dir x es v doAssign = do- ifNotM (asksTC envAssignMetas) dontAssign $ {- else -} do+ ifNotM (viewTC eAssignMetas) dontAssign $ {- else -} do reportSDoc "tc.meta.assign" 10 $ do- "term" <+> prettyTCM (MetaV x es) <+> text (":" ++ prettyShow dir) <+> prettyTCM v+ "term" <+> prettyTCM (MetaV x es) <+> text (":" ++! prettyShow dir) <+> prettyTCM v nowSolvingConstraints doAssign `finally` solveAwakeConstraints where dontAssign = do reportSLn "tc.meta.assign" 10 "don't assign metas" patternViolation alwaysUnblock -- retry again when we are allowed to instantiate metas +allRewDoms :: Tele (Dom Type) -> [RewDom]+allRewDoms = mapMaybe rewDom . flattenTel++-- | Gets the set of variables constrained by local rewrite rules+--+-- We specifically care about variables that occur exactly as LHSs of local+-- rewrite rules. Unification problems under such local rewrite rules might+-- appear outside the pattern fragment after rewriting arguments, but if the+-- argument is constrained in the meta's context, we know it is uniquely+-- determined up to defeq and can proceed.+rewConstrained :: Tele (Dom Type) -> TCM VarSet+rewConstrained tel = localRewritingOption >>= \case+ True -> pure $! foldMap (rewConstrained' . fromMaybe __IMPOSSIBLE__ . rewDomRew) $! allRewDoms tel+ False -> pure mempty+ where+ rewConstrained' :: RewriteRule -> VarSet+ rewConstrained' (RewriteRule EmptyTel (RewVarHead x) [] _ _) =+ VarSet.singleton x+ rewConstrained' (RewriteRule _ (RewVarHead x) [] _ _) =+ __IMPOSSIBLE__+ rewConstrained' _ =+ VarSet.empty+ -- | Miller pattern unification: -- -- @assign dir x vs v a@ solves problem @x vs <=(dir) v : a@ for meta @x@@@ -813,7 +852,7 @@ reportSDoc "tc.meta.assign" 25 $ "v = " <+> prettyTCM v reportSDoc "tc.meta.assign" 45 $ "MetaVars.assign: assigning meta " <+> prettyTCM (MetaV x []) <+>- " with args " <+> prettyList_ (map (prettyTCM . unArg) args) <+>+ " with args " <+> prettyList_ (map' (prettyTCM . unArg) args) <+> " to " <+> prettyTCM v reportSDoc "tc.meta.assign" 45 $ "MetaVars.assign: type of meta: " <+> prettyTCM t@@ -822,17 +861,21 @@ text "MetaVars.assign: assigning meta " <> pretty x <> text " with args " <> pretty args <> text " to " <> pretty v let- boundary v = do- cubical <- cubicalOption- isip <- isInteractionMetaB x args- case (,) <$> cubical <*> isip of- Just (_, (x, ip, args)) -> tryAddBoundary dir x ip args v target- _ -> pure ()+ boundary v = runMaybeT do+ _ <- MaybeT cubicalOption+ (x, ip, args) <- MaybeT (isInteractionMetaB x args)+ lift $ tryAddBoundary dir x ip args v target case (v, mvJudgement mvar) of (Sort s, HasType{}) -> hasBiggerSort s _ -> return () + -- Instantiating metas with @rewrite functions is never allowed to ensure+ -- quantification is always prenex+ when (isRewPi v) $ do+ warning $ InferredLocalRewrite x v+ patternViolation neverUnblock+ -- Jesper, 2019-09-13: When --no-sort-comparison is enabled, -- we equate the sort of the solution with the sort of the -- metavariable, in order to solve metavariables in sorts.@@ -892,9 +935,27 @@ when (mvFrozen mvar == Frozen) $ do reportSLn "tc.meta.assign" 25 $ "aborting: meta is frozen!" -- IApplyConfluence can contribute boundary conditions to frozen metas- boundary v+ void $ boundary v patternViolation neverUnblock + -- Issue #8828: if we are inside an abstract block, we don't instantiate metas+ -- except the ones created in an abstract block of the current module+ whenM ((== AbstractMode) <$> viewTC eAbstractMode) $ do+ currentMod <- dropAnonymousModules <$> viewTC eCurrentModule+ let metaMod = dropAnonymousModules $ view eCurrentModule $ getMetaEnv mvar+ unless (view lensIsAbstract mvar == AbstractDef+ && currentMod `isLeParentModuleOf` metaMod) $ do+ reportSLn "tc.meta.assign" 25 $ "aborting: we are abstract but meta isn't"+ patternViolation (unblockOnMeta x)++ -- Issue #8828: if we are in an opaque block, we don't instantiate metas+ -- except the ones created in the current opaque block.+ whenJustM (viewTC eCurrentOpaqueId) $ \oid -> do+ let metaOId = view eCurrentOpaqueId $ getMetaEnv mvar+ unless (metaOId == Just oid) $ do+ reportSLn "tc.meta.assign" 25 $ "aborting: meta is from outside current opaque block"+ patternViolation (unblockOnMeta x)+ -- We never get blocked terms here anymore. TODO: we actually do. why? whenM (isBlockedTerm x) $ do reportSLn "tc.meta.assign" 25 $ "aborting: meta is a blocked term!"@@ -928,8 +989,8 @@ expandProjectedVars args (v, target) $ \ args (v, target) -> do + cxt <- getContextTelescope reportSDoc "tc.meta.assign.proj" 45 $ do- cxt <- getContextTelescope vcat [ "context after projection expansion" , nest 2 $ inTopContext $ prettyTCM cxt@@ -948,8 +1009,8 @@ -- BEGIN attempt #4159 -- let constraint = case v of- -- -- Sort s -> dirToCmp SortCmp dir (MetaS x $ map Apply args) s- -- _ -> dirToCmp (\ cmp -> ValueCmp cmp target) dir (MetaV x $ map Apply args) v+ -- -- Sort s -> dirToCmp SortCmp dir (MetaS x $ map' Apply args) s+ -- _ -> dirToCmp (\ cmp -> ValueCmp cmp target) dir (MetaV x $ map' Apply args) v -- reportSDoc "tc.meta.assign.catch" 40 $ sep -- [ "assign: catching constraint:" -- , prettyTCM constraint@@ -971,7 +1032,7 @@ -- even though the lhs is not a pattern, we can prune the y from _2 let- vars = freeVars args+ vars = freeVarMap args relevantVL = filterVarMapToList isRelevant vars shapeIrrelevantVL = filterVarMapToList isShapeIrrelevant vars irrelevantVL = filterVarMapToList (liftM2 (&&) isIrrelevant isUnguarded) vars@@ -996,10 +1057,10 @@ pr (Def c []) = prettyTCM c pr _ = ".." in vcat- [ "mvar args:" <+> sep (map (pr . unArg) args)- , "fvars lhs (relevant) :" <+> sep (map (text . show) relevantVL)- , "fvars lhs (shape-irrelevant):" <+> sep (map (text . show) shapeIrrelevantVL)- , "fvars lhs (irrelevant) :" <+> sep (map (text . show) irrelevantVL)+ [ "mvar args:" <+> sep (map' (pr . unArg) args)+ , "fvars lhs (relevant) :" <+> sep (map' (text . show) relevantVL)+ , "fvars lhs (shape-irrelevant):" <+> sep (map' (text . show) shapeIrrelevantVL)+ , "fvars lhs (irrelevant) :" <+> sep (map' (text . show) irrelevantVL) ] -- Check that the x doesn't occur in the right hand side.@@ -1025,21 +1086,27 @@ -- free in v -- Ulf, 2011-09-22: we need to respect irrelevant vars as well, otherwise -- we'll build solutions where the irrelevant terms are not valid- let fvs = allFreeVars v+ let fvs = freeVarSet v reportSDoc "tc.meta.assign" 20 $- "fvars rhs:" <+> sep (map (text . show) $ VarSet.toList fvs)+ "fvars rhs:" <+> sep (map' (text . show) $ VarSet.toAscList fvs) + let n = length args+ TelV mTel _ <- telViewUpToPath n t++ -- We should never prune local rewrite rules+ let noPrune = VarSet.union fvs $ theRewVars cxt+ -- Check that the arguments are variables mids <- do- res <- runExceptT $ inverseSubst' (const False) args+ res <- runExceptT $ inverseSubst' (const False) mTel args case res of -- all args are variables Right ids -> do reportSDoc "tc.meta.assign" 60 $- "inverseSubst returns:" <+> sep (map pretty ids)+ "inverseSubst returns:" <+> sep (map' pretty ids) reportSDoc "tc.meta.assign" 50 $- "inverseSubst returns:" <+> sep (map prettyTCM ids)- let boundVars = VarSet.fromList $ map fst ids+ "inverseSubst returns:" <+> sep (map' prettyTCM ids)+ let boundVars = VarSet.fromList $ map' fst ids if fvs `VarSet.isSubsetOf` boundVars then return $ Just ids else return Nothing@@ -1047,10 +1114,10 @@ -- here, we cannot prune, since offending vars could be eliminated Left (CantInvert tm) -> Nothing <$ boundary v -- we have non-variables, but these are not eliminateable- Left NeutralArg -> Just <$> attemptPruning x args fvs+ Left NeutralArg -> Just <$> attemptPruning x args noPrune -- we have a projected variable which could not be eta-expanded away: -- same as neutral- Left ProjVar{} -> Just <$> attemptPruning x args fvs+ Left ProjVar{} -> Just <$> attemptPruning x args noPrune case mids of -- vv Ulf 2014-07-13: actually not needed after all: attemptInertRHSImprovement x args v Nothing -> patternViolation =<< updateBlocker (unblockOnAnyMetaIn v) -- TODO: more precise@@ -1067,28 +1134,24 @@ -- using non-linear variables need to be solved). Left () -> do block <- updateBlocker $ unblockOnAnyMetaIn v- addOrUnblocker block $ attemptPruning x args fvs+ addOrUnblocker block $ attemptPruning x args noPrune -- Check ids is time respecting. () <- do- let idvars = map (mapSnd allFreeVars) ids+ let idvars = map' (second freeVarSet) ids -- earlierThan α v := v "arrives" before α let earlierThan l j = j > l- TelV tel' _ <- telViewUpToPath (length args) t forM_ ids $ \(i,u) -> do d <- domOfBV i case getLock (getArgInfo d) of IsNotLock -> pure () IsLock{} -> do- let us = IntSet.unions $ map snd $ filter (earlierThan i . fst) idvars+ let us = VarSet.unions $ map' snd $ filter (earlierThan i . fst) idvars -- us Earlier than u- unlessM (addContext tel' $ checkEarlierThan u us) $+ unlessM (addContext mTel $ checkEarlierThan u us) $ patternViolation (unblockOnMeta x) -- If the earlier check hard-fails we need to -- solve this meta in some other way. - let n = length args- TelV tel' _ <- telViewUpToPath n t- -- Check subtyping constraints on the context variables. -- Intuition: suppose @_X : (x : A) → B@, then to turn@@ -1100,11 +1163,11 @@ -- Γ ⊢ _X =?= λ x → v -- @ -- we need to check that @A <: A'@ (due to contravariance).- let sigma = parallelS $ reverse $ map unArg args+ let sigma = parallelS $ reverse $ map' unArg args 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)+ a <- applySubst sigma <$> addContext mTel (infer u) a' <- typeOfBV i checkSubtypeIsEqual a' a `catchError` \case@@ -1119,17 +1182,18 @@ attemptPruning :: MetaId -- Meta-variable (lhs) -> Args -- Meta arguments (lhs)- -> FVs -- Variables occuring on the rhs+ -> VarSet -- Variables we do not want to prune+ -- (e.g. those occurring on the rhs) -> TCM a- attemptPruning x args fvs = do+ attemptPruning x args noPrune = do -- non-linear lhs: we cannot solve, but prune- killResult <- prune x args $ (`VarSet.member` fvs)+ killResult <- prune x args $ (`VarSet.member` noPrune) let success = killResult `elem` [PrunedSomething,PrunedEverything] reportSDoc "tc.meta.assign" 10 $ "pruning" <+> prettyTCM x <+> do text $ if success then "succeeded" else "failed" blocker <- if | success -> return alwaysUnblock -- If pruning succeeded we want to retry right away- | otherwise -> unblockOnAnyMetaIn . MetaV x . map Apply <$> instantiateFull args+ | otherwise -> unblockOnAnyMetaIn . MetaV x . map' Apply <$> instantiateFull args -- TODO: could be more precise: only unblock on metas -- applied to offending variables patternViolation blocker@@ -1137,7 +1201,7 @@ -- | Is the given metavariable application secretly an interaction point -- application? Ugly. isInteractionMetaB- :: forall m. (ReadTCState m, MonadReduce m, MonadPretty m)+ :: forall m. (MonadPretty m) => MetaId -> Args -> m (Maybe (MetaId, InteractionId, Args))@@ -1159,13 +1223,14 @@ iid <- MaybeT (isInteractionMeta m) args <- MaybeT (pure (allApplyElims args)) pure (m, iid, args)- -- It might be the case that the inner meta (the interaction point)- -- exists in a larger context, so instantiating the outer meta (the- -- original argument) will produce lambdas.- --- -- Since the boundary code runs in the inner, larger context, we can- -- peel off the lambdas without running afoul of the scope.- there (Lam _ as) = there (absApp as (var 0))+ -- Andreas, 2026-10-05, issue #8808:+ -- If the instantiation is a lambda, the interaction point lives in a+ -- larger context than the current one. We must not peel off the+ -- lambdas here, since the boundary code runs in the current context,+ -- where the bound variables are not in scope.+ -- Instead, we give up; the conversion checker will eta-expand and+ -- come back here with the variables in scope.+ -- WAS: there (Lam _ as) = there (absApp as (var 0)) -- produces out-of-scope indices there _ = mzero {- UNUSED@@ -1176,7 +1241,7 @@ attemptInertRHSImprovement m args v = do reportSDoc "tc.meta.inert" 30 $ vcat [ "attempting inert rhs improvement"- , nest 2 $ sep [ prettyTCM (MetaV m $ map Apply args) <+> "=="+ , nest 2 $ sep [ prettyTCM (MetaV m $ map' Apply args) <+> "==" , prettyTCM v ] ] -- Check that the right-hand side has the form D vs, for some inert constant D. -- Returns the type of D and a function to build an application of D.@@ -1196,13 +1261,13 @@ -- Solve the meta with _M := \ xs -> D (_Y1 xs) .. (_Yn xs), for fresh metas -- _Yi. metaArgs <- inTopContext $ addContext tel $ newArgsMeta a- let varArgs = map Apply $ reverse $ zipWith (\i a -> var i <$ a) [0..] (reverse args)+ let varArgs = map' Apply $ reverse $ zipWith' (\i a -> var i <$ a) [0..] (reverse args) sol = mkRHS metaArgs- argTel = map ("x" <$) args+ argTel = map' ("x" <$) args reportSDoc "tc.meta.inert" 30 $ nest 2 $ vcat [ "a =" <+> prettyTCM a , "tel =" <+> prettyTCM tel- , "metas =" <+> prettyList (map prettyTCM metaArgs)+ , "metas =" <+> prettyList (map' prettyTCM metaArgs) , "sol =" <+> prettyTCM sol ] assignTerm m argTel sol@@ -1221,11 +1286,11 @@ patternViolation Just args -> return args case v of- Var x elims -> (, Var x . map Apply) <$> typeOfBV x+ Var x elims -> (, Var x . map' Apply) <$> typeOfBV x Con c ci args -> notInert -- (, Con c ci) <$> defType <$> getConstInfo (conName c) Def f elims -> do def <- getConstInfo f- let good = return (defType def, Def f . map Apply)+ let good = return (defType def, Def f . map' Apply) case theDef def of Axiom{} -> good Datatype{} -> good@@ -1275,7 +1340,7 @@ assignMeta :: Int -> MetaId -> Type -> [Int] -> Term -> TCM () assignMeta m x t ids v = do let n = length ids- cand = List.sort $ zip ids $ map var $ downFrom n+ cand = List.sort $ zip' ids $ map' var $ downFrom n assignMeta' m x t n cand v -- | @assignMeta' m x t ids u@ solves @x = [ids]u@ for meta @x@ of type @t@,@@ -1309,42 +1374,67 @@ rho = prependS impossible ivs $ raiseS n v' = applySubst rho v + cxt <- getContextTelescope++ -- Variables corresponding to local rewrite rules+ let rVars = VarSet.toDescList $ theRewVars cxt+ -- Variables not strengthened away+ let notDropped = VarSet.fromList $ fmap fst ids+ -- Metas are top-level so we do the assignment at top-level. inTopContext $ do+ -- Andreas, 2011-04-18 to work with irrelevant parameters -- we need to construct tel' from the type of the meta variable -- (no longer from ids which may not be the complete variable list -- any more) reportSDoc "tc.meta.assign" 15 $ "type of meta =" <+> prettyTCM t - (telv@(TelV tel' a), bs) <- telViewUpToPathBoundary n t- reportSDoc "tc.meta.assign" 30 $ "tel' =" <+> prettyTCM tel'+ (telv@(TelV mTel a), bs) <- telViewUpToPathBoundary n t+ reportSDoc "tc.meta.assign" 30 $ "tel' =" <+> prettyTCM mTel reportSDoc "tc.meta.assign" 30 $ "#args =" <+> text (show n)++ -- Solving metas in contexts with extra local rewrite rules is+ -- problematic because solutions that appear unique locally may not be+ -- globally unique.+ -- We fix this by checking that every local rewrite rule in the solution+ -- context is mapped to a local rewrite rule in the meta's context.+ -- This is conservative, but should at least be pretty fast.++ stillRews <- addContext mTel $ forM rVars \i -> do+ if not $ VarSet.member i notDropped then pure False else do+ case deBruijnView $ lookupS rho i of+ Just i' -> do+ isJust . rewDom <$> domOfBV i'+ Nothing -> pure False++ -- The current context has a rewrite rule which does not appear to be+ -- in the meta's+ unless (and stillRews) $ patternViolation neverUnblock+ -- Andreas, 2013-09-17 (AIM XVIII): if t does not provide enough -- types for the arguments, it might be blocked by a meta; -- then we give up. (Issue 903)- when (size tel' < n) $ do+ when (size mTel < n) $ do a <- abortIfBlocked a reportSDoc "impossible" 10 $ "not enough pis, but not blocked?" <?> pretty a __IMPOSSIBLE__ -- If we get here it was _not_ blocked by a meta! -- Perform the assignment (and wake constraints). - let vsol = abstract tel' v'+ v' <- blockOnBoundary telv bs v' -- Andreas, 2013-10-25 double check solution before assigning whenM (optDoubleCheck <$> pragmaOptions) $ do m <- lookupLocalMeta x reportSDoc "tc.meta.check" 30 $ "double checking solution" catchConstraint (CheckMetaInst x) $- addContext tel' $ checkSolutionForMeta x m v' a+ addContext mTel $ checkSolutionForMeta x m v' a reportSDoc "tc.meta.assign" 10 $- "solving" <+> prettyTCM x <+> ":=" <+> prettyTCM vsol-- v' <- blockOnBoundary telv bs v'+ "solving" <+> prettyTCM x <+> ":=" <+> prettyTCM (abstract mTel v') - assignTerm x (telToArgs tel') v'+ assignTerm x (telToArgs mTel) v' where blockOnBoundary :: TelView -> Boundary -> Term -> TCM Term blockOnBoundary telv (Boundary []) v = return v@@ -1461,12 +1551,12 @@ (HasType __IMPOSSIBLE__ CmpLeq t') -- Note: no eta-expansion of new meta possible/necessary. -- Add the size constraint @y args `dir` u@.- let yArgs = MetaV y $ map Apply args+ let yArgs = MetaV y $ map' Apply args addConstraint (unblockOnMeta y) $ dirToCmp (`ValueCmp` AsSizes) dir yArgs u -- We continue with the new assignment problem, and install -- an exception handler, since we created a meta and a constraint, -- so we cannot fall back to the original handler.- let xArgs = MetaV x $ map Apply args+ let xArgs = MetaV x $ map' Apply args v' = Def qSizeLt [Apply $ Arg ai yArgs] c = dirToCmp (`ValueCmp` (AsTermsOf sizeUniv)) dir xArgs v' catchConstraint c $ cont v'@@ -1502,7 +1592,11 @@ etaExpandProjectedVar i v fail succeed = do reportSDoc "tc.meta.assign.proj" 40 $ "trying to expand projected variable" <+> prettyTCM (var i)- caseMaybeM (etaExpandBoundVar i) fail $ \ (delta, sigma, tau) -> do+ -- We don't eta-expand variables which occur in local rewrite rules+ -- In principle, I think we could handle this safely, but it is tricky+ tel <- getContextTelescope+ if i `VarSet.member` inRewVars tel then fail else+ caseMaybeM (etaExpandBoundVar i) fail $ \ (delta, sigma, tau) -> do reportSDoc "tc.meta.assign.proj" 25 $ "eta-expanding var " <+> prettyTCM (var i) <+> " in terms " <+> prettyTCM v@@ -1524,11 +1618,11 @@ instance NoProjectedVar Term where noProjectedVar = \case Var i es- | qs@(_:_) <- takeWhileJust id $ map isProjElim es+ | qs@(_:_) <- takeWhileJust id $ map' isProjElim es -> Left $ ProjectedVar i qs -- Andreas, 2015-09-12 Issue #1316: -- Also look in inductive record constructors- Con (ConHead _ IsRecord{} Inductive _) _ es+ Con (ConHead _ IsRecord{} Inductive _ _) _ es | Just vs <- allApplyElims es -> noProjectedVar vs _ -> return ()@@ -1538,7 +1632,7 @@ reduceAndEtaContract :: a -> TCM a default reduceAndEtaContract- :: (Traversable f, TermLike b, Subst b, Reduce b, ReduceAndEtaContract b, f b ~ a)+ :: (Traversable f, ReduceAndEtaContract b, f b ~ a) => a -> TCM a reduceAndEtaContract = Trav.mapM reduceAndEtaContract @@ -1582,36 +1676,6 @@ patternViolation -} -{-- -- first, strip the leading n domains (which remain unchanged)- TelV gamma core <- telViewUpTo n t- case unEl core of- -- There should be at least one domain left- Pi (Dom ai a) b -> do- -- Eta-expand @dom@ along @qs@ into a telescope @tel@, computing a substitution.- -- For now, we only eta-expand once.- -- This might trigger another call to @etaExpandProjectedVar@ later.- -- A more efficient version does all the eta-expansions at once here.- (r, pars, def) <- fromMaybe __IMPOSSIBLE__ <$> isRecordType a- unless (recEtaEquality def) __IMPOSSIBLE__- let tel = recTel def `apply` pars- m = size tel- v = Con (recConHead def) $ map var $ downFrom m- b' = raise m b `absApp` v- fs = recFields def- vs = zipWith (\ f i -> Var i [Proj f]) fs $ downFrom m- -- v = c (n-1) ... 1 0- (tel, u) <- etaExpandAtRecordType a $ var 0- -- TODO: compose argInfo ai with tel.- -- Substitute into @b@.- -- Abstract over @tel@.- -- Abstract over @gamma@.- -- Create new meta.- -- Solve old meta, using substitution.- patternViolation- _ -> __IMPOSSIBLE__--}- type FVs = VarSet type SubstCand = [(Int,Term)] -- ^ a possibly non-deterministic substitution @@ -1651,11 +1715,13 @@ -- Linearity, i.e., whether the substitution is deterministic, -- has to be checked separately. ---inverseSubst' :: (Term -> Bool) -> Args -> ExceptT InvertExcept TCM SubstCand-inverseSubst' skip args = map (mapFst unArg) <$> loop (zip args terms)+inverseSubst' ::+ (Term -> Bool) -> Tele (Dom Type) -> Args+ -> ExceptT InvertExcept TCM SubstCand+inverseSubst' skip tel args = map' (first unArg) <$> loop (zip' args terms) where loop = foldM isVarOrIrrelevant []- terms = map var (downFrom (size args))+ terms = map' var (downFrom (size args)) failure c = do lift $ reportSDoc "tc.meta.assign" 15 $ vcat [ "not all arguments are variables: " <+> prettyTCM args@@ -1665,74 +1731,88 @@ 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- ineg <- getPrimitiveName' builtinINeg- case stripDontCare v of- -- i := x- Var i [] -> return $ (Arg info i, t) `cons` vars+ -- We need to identify arguments to the meta that are fully constrained by+ -- local rewrite rules+ -- These are simply ignored when building the inverse substitution+ -- (analogously to irrelevant arguments)+ constrained <- lift $ rewConstrained tel+ case t of+ Var x [] | x `VarSet.member` constrained -> do+ lift $ reportSDoc "tc.meta.assign" 60 $ vcat+ [ "argument is constrained by rewrite rule"+ , " arg = " <+> prettyTCM v+ , " var = " <+> prettyTCM (var x)+ ]+ return vars+ _ -> do+ let irr | isIrrelevant info = True+ | DontCare{} <- v = True+ | otherwise = False+ ineg <- getPrimitiveName' builtinINeg+ 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- tm@(Con c ci es) -> do- let fallback- | isIrrelevant info = return vars- | skip tm = return vars- | otherwise = failure tm- irrProj <- optIrrelevantProjections <$> pragmaOptions- lift (isEtaRecordConstructor $ conName c) >>= \case- -- Andreas, 2019-11-10, issue #4185: only for eta-records- Just (_, RecordData{ _recFields = fs })- | 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')- , modPolarity = addPolarity (getModalPolarity info) (getModalPolarity info') -- XXX- }- , 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+ tm@(Con c ci es) -> do+ let fallback+ | isIrrelevant info = return vars+ | skip tm = return vars+ | otherwise = failure tm+ irrProj <- optIrrelevantProjections <$> pragmaOptions+ lift (isEtaRecordConstructor $ conName c) >>= \case+ -- Andreas, 2019-11-10, issue #4185: only for eta-records+ Just (_, RecordData{ _recFields = fs })+ | 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@(unDom -> f) = (Arg ai v,) $ t `applyE` [Proj ProjSystem f]+ where+ info' = dom ^. dInfo+ 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')+ , modPolarity = addPolarity (getModalPolarity info) (getModalPolarity info') -- XXX+ }+ , 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+ -- Distinguish args that can be eliminated (Con,Lit,Lam,unsure) ==> failure+ -- from those that can only put somewhere as a whole ==> neutralArg+ Var{} -> neutralArg - -- primINeg i := x becomes i := primINeg x- -- (primINeg is a definitional involution)- Def qn es | Just [Arg _ (Var i [])] <- allApplyElims es, Just qn == ineg ->- pure $ (Arg info i, Def qn [Apply (defaultArg t)]) `cons` vars+ -- primINeg i := x becomes i := primINeg x+ -- (primINeg is a definitional involution)+ Def qn es | Just [Arg _ (Var i [])] <- allApplyElims es, Just qn == ineg ->+ pure $ (Arg info i, Def qn [Apply (defaultArg t)]) `cons` vars - Def{} -> neutralArg -- Note that this Def{} is in normal form and might be prunable.- t@Lam{} -> failure t- t@Lit{} -> failure t- t@MetaV{} -> failure t- Pi{} -> neutralArg- Sort{} -> neutralArg- Level{} -> neutralArg- DontCare{} -> __IMPOSSIBLE__ -- Ruled out by stripDontCare- Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s+ Def{} -> neutralArg -- Note that this Def{} is in normal form and might be prunable.+ tm@Lam{} -> failure tm+ tm@Lit{} -> failure tm+ tm@MetaV{} -> failure tm+ Pi{} -> neutralArg+ Sort{} -> neutralArg+ Level{} -> neutralArg+ DontCare{} -> __IMPOSSIBLE__ -- Ruled out by stripDontCare+ Dummy s _ -> __IMPOSSIBLE_VERBOSE__ (show s) -- managing an assoc list where duplicate indizes cannot be irrelevant vars append :: Res -> Res -> Res@@ -1787,16 +1867,19 @@ IZero -> Just (i, False) _ -> Nothing + m <- getContextSize+ TelV tel' _ <- telViewUpToPath n t+ -- The logic here is essentially the same as for actually solving the -- meta.. We just return the pieces instead of doing the assignment. -- We must check the "face condition" (the relaxed pattern condition) -- and check linearity of the substitution candidate, otherwise the -- equation can't be inverted into a face constraint.- sub <- MaybeT $ either (const Nothing) Just <$> runExceptT (inverseSubst' isEndpoint args)- ids <- MaybeT $ either (const Nothing) Just <$> runExceptT (checkLinearity sub)+ sub <- MaybeT $ either (const Nothing) Just <$> runExceptT+ (inverseSubst' isEndpoint tel' args)+ ids <- MaybeT $ either (const Nothing) Just <$> runExceptT+ (checkLinearity sub) - m <- getContextSize- TelV tel' _ <- telViewUpToPath n t tel'' <- enterClosure mvar $ \_ -> getContextTelescope let@@ -1808,7 +1891,7 @@ rho = prependS impossible ivs $ raiseS n over = size tel' - size tel''- endps = IntMap.fromList $ catMaybes $ zipWith (\a i -> fin a (i - over)) args (downFrom n)+ endps = IntMap.fromList $ catMaybes $ zipWith' (\a i -> fin a (i - over)) args (downFrom n) reportSDoc "tc.ip.boundary" 45 $ vcat [ "ivs =" <+> prettyTCM ivs@@ -1843,10 +1926,10 @@ let t = jMetaType $ mvJudgement mvar n = length args- rhsv = allFreeVars v+ rhsv = freeVarSet v allVars :: SubstCand -> Bool- allVars sub = rhsv `VarSet.isSubsetOf` VarSet.fromList (map fst sub)+ allVars sub = rhsv `VarSet.isSubsetOf` VarSet.fromList (map' fst sub) TelV tel' _ <- telViewUpToPath n t @@ -1893,7 +1976,7 @@ -- openMetasToPostulates :: TCM () openMetasToPostulates = do- m <- asksTC envCurrentModule+ m <- viewTC eCurrentModule -- Go through all open metas. ms <- MapS.assocs <$> useTC stOpenMetaStore@@ -1903,13 +1986,13 @@ -- 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'+ 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 ")+ [ text ("Turning " ++! if isSortMeta_ mv then "sort" else "value" ++! " meta ") <+> prettyTCM x <+> " into postulate." , nest 2 $ vcat [ "Name: " <+> prettyTCM q@@ -1945,7 +2028,7 @@ getType m return [ (m, m') | m' <- Set.toList deps ] - return $ Graph.topSort metas' metaGraph+ return $! Graph.topSort metas' metaGraph where metas' = Set.fromList metas
src/full/Agda/TypeChecking/MetaVars.hs-boot view
@@ -13,15 +13,15 @@ type Condition = Dom Type -> Abs Type -> Bool type SubstCand = [(Int,Term)] -newArgsMeta' :: MonadMetaSolver m => Condition -> Type -> m Args-newArgsMeta :: MonadMetaSolver m => Type -> m Args-assignTerm :: MonadMetaSolver m => MetaId -> [Arg String] -> Term -> m ()+newArgsMeta' :: Condition -> Type -> TCM Args+newArgsMeta :: Type -> TCM Args+assignTerm :: MetaId -> [Arg String] -> Term -> TCM () assign :: CompareDirection -> MetaId -> Args -> Term -> CompareAs -> TCM ()-newInstanceMeta :: MonadMetaSolver m => String -> Type -> m (MetaId, Term)-newValueMeta :: MonadMetaSolver m => RunMetaOccursCheck -> Comparison -> Type -> m (MetaId, Term)-newNamedValueMeta :: MonadMetaSolver m => RunMetaOccursCheck -> String -> Comparison -> Type -> m (MetaId, Term)-newNamedValueMeta':: MonadMetaSolver m => RunMetaOccursCheck -> String -> Comparison -> Type -> m (MetaId, Term)-newTelMeta :: MonadMetaSolver m => Telescope -> m Args-newSortMeta :: MonadMetaSolver m => m Sort+newInstanceMeta :: String -> Type -> TCM (MetaId, Term)+newValueMeta :: RunMetaOccursCheck -> Comparison -> Type -> TCM (MetaId, Term)+newNamedValueMeta :: RunMetaOccursCheck -> String -> Comparison -> Type -> TCM (MetaId, Term)+newNamedValueMeta':: RunMetaOccursCheck -> String -> Comparison -> Type -> TCM (MetaId, Term)+newTelMeta :: Telescope -> TCM Args+newSortMeta :: TCM Sort checkMetaInst :: MetaId -> TCM () isFaceConstraint :: MetaId -> Args -> TCM (Maybe (MetaVariable, IntMap Bool, SubstCand, Substitution))
src/full/Agda/TypeChecking/MetaVars/Mention.hs view
@@ -57,13 +57,19 @@ LockUniv -> False LevelUniv -> False IntervalUniv -> False- PiSort a s1 s2 -> mentionsMetas xs (a, s1, s2)+ PiSort c a s1 s2 -> mentionsMetas xs (c, a, s1, s2) FunSort s1 s2 -> mentionsMetas xs (s1, s2) UnivSort s -> mentionsMetas xs s MetaS m es -> HashSet.member m xs || mentionsMetas xs es DefS d es -> mentionsMetas xs es DummyS{} -> False +instance MentionsMeta t => MentionsMeta (BlockedDepCheck t) where+ mentionsMetas xs (CodomainSortOld s) =+ mentionsMetas xs s+ mentionsMetas xs CodomainSortSame+ = False+ instance MentionsMeta t => MentionsMeta (Abs t) where mentionsMetas xs = mentionsMetas xs . unAbs @@ -87,6 +93,14 @@ instance (MentionsMeta a, MentionsMeta b, MentionsMeta c) => MentionsMeta (a, b, c) where mentionsMetas xs (a, b, c) = mentionsMetas xs a || mentionsMetas xs b || mentionsMetas xs c +instance (MentionsMeta a, MentionsMeta b, MentionsMeta c, MentionsMeta d)+ => MentionsMeta (a, b, c, d) where+ mentionsMetas xs (a, b, c, d) =+ mentionsMetas xs a ||+ mentionsMetas xs b ||+ mentionsMetas xs c ||+ mentionsMetas xs d+ instance MentionsMeta a => MentionsMeta (Closure a) where mentionsMetas xs cl = mentionsMetas xs (clValue cl) @@ -102,6 +116,9 @@ instance MentionsMeta ProblemConstraint where mentionsMetas xs = mentionsMetas xs . theConstraint +instance MentionsMeta LocalEquation where+ mentionsMetas xs (LocalEquation g t u a) = mentionsMetas xs (g, t, u, a)+ instance MentionsMeta Constraint where mentionsMetas xs = \case ValueCmp _ t u v -> mm (t, u, v)@@ -113,7 +130,7 @@ -- problem and we don't have a handle on -- what metas it depends on FindInstance{} -> True -- this needs to be woken up for any meta- ResolveInstanceHead q -> True -- TODO+ ResolveInstanceHead{} -> True -- TODO IsEmpty r t -> mm t CheckSizeLtSat t -> mm t CheckFunDef{} -> True -- not sure what metas this depends on@@ -125,6 +142,7 @@ CheckType t -> mm t CheckLockedVars a b c d -> mm ((a, b), (c, d)) UsableAtModality _ ms mod t -> mm (ms, t)+ RewConstraint e -> mm e where mm :: forall t. MentionsMeta t => t -> Bool mm = mentionsMetas xs
src/full/Agda/TypeChecking/MetaVars/Occurs.hs view
@@ -1,32 +1,45 @@-{-# OPTIONS_GHC -Wunused-imports #-} +{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-} {-# LANGUAGE NondecreasingIndentation #-} {- | The occurs check for unification. Does pruning on the fly. - When hitting a meta variable:+When hitting a meta variable: - Compute flex/rigid for its arguments. - Compare to allowed variables. - Mark arguments with rigid occurrences of disallowed variables for deletion. - Attempt to delete marked arguments. - We don't need to check for success, we can just continue occurs checking.++We also check modality usability for all bound variables; see issue 8570. In the example there, we+elaborate a term as a type (using resourcing rules for types), but then solve a term metavariable+with it. Hence, well-resourcing needs to be re-checked when we solve the metavariable. -} -module Agda.TypeChecking.MetaVars.Occurs where+module Agda.TypeChecking.MetaVars.Occurs (+ PruneResult(..)+ , killArgs+ , occursCheck+ , prune+ , rigidVarsNotContainedIn+ ) where +import Prelude hiding (null, zip, zipWith)+ import Control.Monad.Except ( ExceptT, runExceptT, catchError, throwError )-import Control.Monad.Reader ( ReaderT, runReaderT, ask, asks, local ) import Data.Foldable (traverse_) import Data.Functor-import Data.Monoid+ import Data.Set (Set) import qualified Data.Set as Set-import qualified Data.IntMap as IntMap+import qualified Data.IntMap.Strict as IntMap import qualified Agda.Benchmarking as Bench +import qualified Agda.Syntax.Common.Pretty as P import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.MetaVars@@ -37,26 +50,29 @@ import Agda.TypeChecking.Reduce import Agda.TypeChecking.Pretty import Agda.TypeChecking.Free-import Agda.TypeChecking.Free.Lazy import Agda.TypeChecking.Free.Reduce import Agda.TypeChecking.ProjectionLike import Agda.TypeChecking.Substitute import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Records import {-# SOURCE #-} Agda.TypeChecking.MetaVars-import Agda.Interaction.Options (optFirstOrder)+import Agda.Interaction.Options (optFirstOrder, optErasure, optExperimentalIrrelevance) import Agda.Utils.Either import Agda.Utils.Function-import Agda.Utils.Lens-import Agda.Utils.List (downFrom)+import Agda.Utils.List+import Agda.Utils.ListInf qualified as ListInf import Agda.Utils.Maybe import Agda.Utils.Monad+import Agda.Utils.Null import Agda.Utils.Permutation import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Utils.Size import Agda.Utils.VarSet (VarSet) import qualified Agda.Utils.VarSet as VarSet+import Agda.Utils.Zip+import Agda.Utils.ExpandCase+import Agda.Utils.StrictReader import Agda.Utils.Impossible @@ -91,10 +107,10 @@ d to discover that it mentions X. To this end, we extend the state by names of definitions that have to-be checked when they occur. At the beginning, this is initialized-with the names in the current mutual block. Each time we encounter a+be checked when they occur. At the beginning, this is initialized+with the names in the current mutual block. Each time we encounter a name in the list during occurs check, we delete it (if check is-successful). This way, we do not duplicate work.+successful). This way, we do not duplicate work. -} @@ -103,25 +119,25 @@ -- | Set the names of definitions to be looked at -- to the defs in the current mutual block.-initOccursCheck :: MetaVariable -> TCM ()-initOccursCheck mv = modifyOccursCheckDefs . const =<<+initOccursCheck :: MetaId -> MetaVariable -> TCM ()+initOccursCheck m mv = modifyOccursCheckDefs . const =<< if (miMetaOccursCheck (mvInfo mv) == DontRunMetaOccursCheck) then do reportSLn "tc.meta.occurs" 20 $ "initOccursCheck: we do not look into definitions" return Set.empty else do- reportSLn "tc.meta.occurs" 20 $- "initOccursCheck: we look into the following definitions:"- mb <- asksTC envMutualBlock- case mb of- Nothing -> do- reportSLn "tc.meta.occurs" 20 $ "(none)"- return Set.empty- Just b -> do- ds <- mutualNames <$> lookupMutualBlock b- reportSDoc "tc.meta.occurs" 20 $ sep $ map prettyTCM $ Set.toList ds- return ds+ mb <- viewTC eMutualBlock >>= \case+ Nothing -> return Set.empty+ Just b -> do+ ds <- mutualNames <$!> lookupMutualBlock b+ return ds+ reportSDoc "tc.meta.occurs" 20 $ vcat+ [ "initOccursCheck for metavariable" <+> pretty m+ , nest 2 $ "definitions:" <+> prettyTCM mb+ , nest 2 $ "modality: " <+> pretty (getModality mv)+ ]+ pure mb -- | Is a def in the list of stuff to be checked?@@ -135,40 +151,37 @@ --------------------------------------------------------------------------- -- * OccursM monad and its services --- | Extra environment for the occurs check. (Complements 'FreeEnv'.)-data OccursExtra = OccursExtra- { occUnfold :: UnfoldStrategy- , occMeta :: MetaId -- ^ The meta @m@ we want to solve.- , occVars :: VarMap -- ^ The allowed variables @xs@ with their variance.- , occRHS :: Term -- ^ The proposed solution @v@ for the meta (@m xs := v@).- , occCxtSize :: Nat -- ^ The size of the typing context upon invocation.- }+-- | Unfold definitions during occurs check?+-- This effectively runs the occurs check on the normal form.+data UnfoldStrategy = YesUnfold | NoUnfold+ deriving (Eq, Show) -type OccursCtx = FreeEnv' () OccursExtra AllowedVar-type OccursM = ReaderT OccursCtx TCM+data OccursCxt = OccursCxt+ { occUnfold :: !UnfoldStrategy+ , occMeta :: !MetaId -- ^ The meta @m@ we want to solve.+ , occVars :: !VarMap -- ^ The allowed variables @xs@ with their variance.+ , occRHS :: !Term -- ^ The proposed solution @v@ for the meta (@m xs := v@).+ , occLocals :: !Int -- ^ Number of local binders (relative to the invocation of+ -- occurs checking).+ , occLocalModalities :: ![Modality] -- ^ Modalities of local variables.+ , occModality :: !Modality -- ^ Modality of current position.+ , occFlexRig :: !(FlexRig' ()) -- ^ Flexibility of current position.+ } --- ** Modality handling.+instance LensFlexRig OccursCxt () where+ {-# INLINE lensFlexRig #-}+ lensFlexRig = \f e -> f (occFlexRig e) <&> \fr -> e {occFlexRig = fr} --- | The passed modality is the one of the current context.-type AllowedVar = Modality -> All+instance LensModality OccursCxt where+ {-# INLINE getModality #-}+ getModality = occModality+ {-# INLINE mapModality #-}+ mapModality = \f e -> e {occModality = f (occModality e)} -instance IsVarSet () AllowedVar where- withVarOcc o f = f . composeModality (getModality o)+instance LensRelevance OccursCxt where+instance LensQuantity OccursCxt where --- | Check whether a free variable is allowed in the context as--- specified by the modality.-variableCheck :: VarMap -> Maybe Variable -> AllowedVar-variableCheck xs mi q = All $- -- Bound variables are always allowed to occur:- caseMaybe mi True $ \ i ->- -- Free variables not listed in @xs@ are forbidden:- caseMaybe (lookupVarMap i xs) False $ \ o ->- -- For listed variables it holds:- -- The ascribed modality @o@ must be submodality of the- -- modality @q@ of the current context.- -- E.g. irrelevant variables (ascribed, lhs) can only- -- be used in irrelevant position (rhs).- getModality o `moreUsableModality` q+type OccursM = ReaderT OccursCxt TCM -- | Occurs check fails if a defined name is not available -- since it was declared in irrelevant or erased context.@@ -177,7 +190,7 @@ cxt <- ask let irr = isIrrelevant cxt er = hasQuantity0 cxt- m = occMeta $ feExtra cxt+ m = occMeta cxt -- Anything goes if we are both irrelevant and erased. -- Otherwise, have to check the modality of the defined name. unless (irr && er) $ getConstInfo' d >>= \case@@ -197,7 +210,7 @@ , "has relevance" , text . show $ getRelevance dmod ]- abort neverUnblock $ MetaIrrelevantSolution m $ occRHS $ feExtra cxt+ abort neverUnblock $ MetaIrrelevantSolution m $ occRHS cxt unless (er || usableQuantity dmod) $ do reportSDoc "tc.meta.occurs" 35 $ hsep [ "occursCheck: definition"@@ -205,14 +218,14 @@ , "has quantity" , text . show $ getQuantity dmod ]- abort neverUnblock $ MetaErasedSolution m $ occRHS $ feExtra cxt+ abort neverUnblock $ MetaErasedSolution m $ occRHS cxt metaCheck :: MetaId -> OccursM MetaId metaCheck m = do cxt <- ask- let rel = getRelevance cxt- qnt = getQuantity cxt- m0 = occMeta $ feExtra cxt+ let rel = getRelevance (occModality cxt)+ qnt = getQuantity (occModality cxt)+ m0 = occMeta cxt -- Check for loop -- don't fail hard on this, since we might still be on the top-level@@ -243,7 +256,7 @@ , "and quantity" , text . show $ getQuantity mmod ]- allowAssign <- asksTC envAssignMetas+ allowAssign <- viewTC eAssignMetas -- Jesper, 2020-11-10: if we encounter a metavariable that is -- unusable because of its modality (e.g. irrelevant or erased) we -- try to *promote* the meta to the required modality, by creating@@ -264,7 +277,7 @@ patternViolation $ unblockOnMeta m when (mvFrozen mv == Frozen) $ fail "meta is frozen" unless (isOpenMeta $ mvInstantiation mv) $ fail "meta is already solved"- unlessM (asksTC envAssignMetas) $ fail "assigning metas is not allowed here"+ unlessM (viewTC eAssignMetas) $ fail "assigning metas is not allowed here" -- Jesper, 2023-09-03, issue #6759: When --lossy-unification is enabled, -- we already lose the guarantee that we only throw an error when a -- problem is really unsolvable in favor of taking the "obvious" solution.@@ -281,67 +294,104 @@ wakeupConstraints m return m +{-# INLINE allowedVars #-} -- | Construct a test whether a de Bruijn index is allowed -- or needs to be pruned. allowedVars :: OccursM (Nat -> Bool) allowedVars = do -- @n@ is the number of binders we have stepped under.- n <- liftM2 (-) getContextSize (asks (occCxtSize . feExtra))- xs <- asks (theVarMap . occVars . feExtra)+ n <- asks occLocals+ xs <- asks (theVarMap . occVars) -- Bound variables are allowed, and those mentioned in occVars.- return $ \ i -> i < n || (i - n) `IntMap.member` xs---- ** Unfolding during occurs check.---- | Unfold definitions during occurs check?--- This effectively runs the occurs check on the normal form.-data UnfoldStrategy = YesUnfold | NoUnfold- deriving (Eq, Show)+ return $! \i -> i < n || (i - n) `IntMap.member` xs +{-# INLINE defArgs #-} defArgs :: OccursM a -> OccursM a-defArgs m = asks (occUnfold . feExtra) >>= \case+defArgs m = asks occUnfold >>= \case NoUnfold -> flexibly m YesUnfold -> weakly m +{-# INLINE conArgs #-} -- | For a path constructor `c : ... -> Path D a b`, we have that e.g. `c es i0` reduces to `a`. -- So we have to consider its arguments as flexible when we do not actually unfold. conArgs :: Elims -> OccursM a -> OccursM a-conArgs es m = asks (occUnfold . feExtra) >>= \case+conArgs es m = asks occUnfold >>= \case YesUnfold -> m- NoUnfold | null [ () | IApply{} <- es ]- -> m- NoUnfold -> flexibly m+ NoUnfold+ | any (\case IApply{} -> True; _ -> False) es -> flexibly m+ | otherwise -> m +{-# INLINE unfoldB #-} unfoldB :: (Instantiate t, Reduce t) => t -> OccursM (Blocked t) unfoldB v = do- unfold <- asks $ occUnfold . feExtra- rel <- asks feModality+ unfold <- asks $ occUnfold+ rel <- asks occModality case unfold of YesUnfold | not (isIrrelevant rel) -> reduceB v _ -> notBlocked <$> instantiate v +{-# INLINE unfold #-} unfold :: (Instantiate t, Reduce t) => t -> OccursM t-unfold v = asks (occUnfold . feExtra) >>= \case+unfold v = asks occUnfold >>= \case NoUnfold -> instantiate v YesUnfold -> reduce v --- ** Managing rigidiy during occurs check.+-- ** Managing rigidity during occurs check. +{-# INLINE weakly #-} -- | Leave the strongly rigid position. weakly :: OccursM a -> OccursM a weakly = local $ over lensFlexRig $ composeFlexRig WeaklyRigid +{-# INLINE strongly #-} strongly :: OccursM a -> OccursM a strongly = local $ over lensFlexRig $ \case WeaklyRigid -> StronglyRigid Unguarded -> StronglyRigid- ctx -> ctx+ ctx -> ctx +{-# INLINE flexibly #-} flexibly :: OccursM a -> OccursM a flexibly = local $ set lensFlexRig $ Flexible () --- ** Error throwing during occurs check.+-- ** Managing modality during occurs check.+--+-- The variables are checked as the type checker checks them (see+-- 'Agda.TypeChecking.Rules.Application.inferHead'): the modalities in+-- 'occVars' and 'occLocalModalities' are relative to the current position,+-- divided by the modality of every position we descend into, and must be+-- usable there. Only the 'Quantity' is absolute: division leaves it alone,+-- and it is compared against the one in 'occModality'. +-- | Divide the modalities of all variables by the given modality,+-- as 'applyModalityToContext' does.+{-# INLINE divideVars #-}+divideVars :: Modality -> OccursCxt -> OccursCxt+divideVars mod e+ | mod == unitModality = e+ | otherwise = e+ { occVars = mapVarMap (fmap (inverseApplyModalityButNotQuantity mod)) (occVars e)+ , occLocalModalities = map (inverseApplyModalityButNotQuantity mod) (occLocalModalities e)+ }++-- | Going into an argument of the given modality.+-- Updates both the 'occModality' and the modalities of each variable.+{-# INLINE occUnderArgModality #-}+occUnderArgModality :: Modality -> OccursM a -> OccursM a+occUnderArgModality mod = local \e -> divideVars mod e+ { occModality = composeModality mod (occModality e) }++{-# INLINE debugModalities #-}+debugModalities :: OccursM ()+debugModalities = do+ env <- ask+ reportSDoc "tc.meta.occurs.modal" 60 $ nest 2 (vcat+ [ "ctx:" <+> prettyTCM (getModality env)+ , "var:" <+> prettyTCM (occVars env)+ ])++{-# INLINE patternViolation' #-}+-- ** Error throwing during occurs check. patternViolation' :: MonadTCM m => Blocker -> Int -> String -> m a patternViolation' unblock n err = liftTCM $ do reportSLn "tc.meta.occurs" n err@@ -369,74 +419,181 @@ default metaOccurs :: (Foldable f, Occurs a, f a ~ t) => MetaId -> t -> TCM () metaOccurs = traverse_ . metaOccurs +{-# INLINE occurs_ #-}+-- GHC flags this as redundant constraint, so we turn off -Wredundant-constraints. occurs_ :: (Occurs t, TypeOf t ~ ()) => t -> OccursM t occurs_ t = occurs t +{-# INLINE metaOccurs2 #-} metaOccurs2 :: (Occurs a, Occurs b) => MetaId -> a -> b -> TCM () metaOccurs2 m x y = metaOccurs m x >> metaOccurs m y +{-# INLINE metaOccurs3 #-} metaOccurs3 :: (Occurs a, Occurs b, Occurs c) => MetaId -> a -> b -> c -> TCM () metaOccurs3 m x y z = metaOccurs m x >> metaOccurs m y >> metaOccurs m z +-- | Going under a binder.+--+-- Issues #8775 , #8784 and #8793.+-- The new local variable gets the modality ascribed by its binder, which is+-- relative to the position the binder sits in, like the modalities of the+-- other variables. Only its quantity is composed with the ambient one,+-- since quantities are absolute (a variable bound in an erased position is+-- itself erased, cf. the LAM rule in Conor McBride's+-- I got plenty o' nuttin', Wadlerfest 2016).+{-# INLINE underBinder #-}+underBinder :: Modality -> OccursM z -> OccursM z+underBinder mod = local \e ->+ e { occLocals = occLocals e + 1+ , occLocalModalities =+ mapQuantity (composeQuantity (getQuantity (occModality e))) mod+ : occLocalModalities e+ }++-- | Going under the binder of a 'Pi' (or 'PiSort'): its codomain is a type,+-- so the type checker makes the bound variable usable at any polarity,+-- and, with @--experimental-irrelevance@, shape-irrelevant if it was+-- irrelevant (see @modMod PiNotLam@ in+-- 'Agda.TypeChecking.Rules.Term.checkTypedBindings').+-- We do the latter regardless of the option: the use of a local variable+-- was already checked when the solution was type checked.+{-# INLINE underPiBinder #-}+underPiBinder :: Modality -> OccursM z -> OccursM z+underPiBinder = underBinder+ . mapRelevance irrelevantToShapeIrrelevant+ . inverseApplyPolarity (withStandardLock UnusedPolarity)++-- | Changing the 'Relevance'.+{-# INLINE underRelevance #-}+underRelevance :: (LensRelevance o) => o -> OccursM z -> OccursM z+underRelevance o = local \e -> divideVars (setRelevance r unitModality) $+ mapRelevance (composeRelevance r) e+ where r = getRelevance o++-- | In the given computation the 'Quantity' is locally scaled using+-- the 'Quantity' of the first argument.+{-# INLINE underQuantity #-}+underQuantity :: (LensQuantity o) => o -> OccursM a -> OccursM a+underQuantity = local . mapQuantity . composeQuantity . getQuantity++-- | Going into the sort annotation @s@ of a type @El s t@.+--+-- Issue #8811.+-- The type checker infers @s@ from @t@ rather than checking it,+-- so @s@ should be subject to no more modality restrictions than @t@+-- is when checked by 'workOnTypes':+-- it is erased (its metas are created with quantity 0 by 'workOnTypes'),+-- has unused polarity, and, with @--experimental-irrelevance@,+-- it is shape-irrelevant and irrelevant variables become+-- shape-irrelevant.+--+-- Issue #8823.+-- We must not treat @s@ as irrelevant: in irrelevant positions,+-- the occurs check does not reduce, so it misses the blockers+-- of offending occurrences, and postponed assignments are not retried.+{-# INLINE underSortAnnotation #-}+underSortAnnotation :: OccursM a -> OccursM a+underSortAnnotation cont = do+ experimental <- optExperimentalIrrelevance <$> pragmaOptions+ underQuantity zeroQuantity+ . applyWhen experimental (local wakeIrrelevantVars . underRelevance shapeIrrelevant)+ . local (divideVars $ setModalPolarity (withStandardLock UnusedPolarity) unitModality)+ $ cont+ where+ -- Make irrelevant variables shape-irrelevant, as 'workOnTypes' does.+ wakeIrrelevantVars e = e+ { occVars = mapVarMap (fmap $ mapRelevance irrelevantToShapeIrrelevant) (occVars e)+ , occLocalModalities = map (mapRelevance irrelevantToShapeIrrelevant) (occLocalModalities e)+ }++-- | Check whether a free variable is allowed in the context as+-- specified by the modality.+variableCheck :: Int -> OccursM Bool+variableCheck i = do+ locals <- asks occLocals+ -- For bound variables, check if they are usable in current modality+ -- The modalities of the variables have been divided on the way down,+ -- so they have to be usable, except for the quantity, which is absolute.+ required <- asks \e -> setQuantity (getQuantity (occModality e)) unitModality+ if i < locals then do+ localMods <- asks occLocalModalities+ let mod = indexWithDefault __IMPOSSIBLE__ localMods i+ pure $! mod `moreUsableModality` required+ else do+ vars <- asks occVars+ case lookupVarMap (i - locals) vars of+ -- free vars not listed in @occVars@ are forbidden+ Nothing -> pure False+ -- otherwise check the usability of modality+ Just o -> do+ let !mod = getModality o+ pure $! mod `moreUsableModality` required++ -- | When assigning @m xs := v@, check that @m@ does not occur in @v@ -- and that the free variables of @v@ are contained in @xs@.-occursCheck- :: MetaId -> VarMap -> Term -> TCM Term+occursCheck :: MetaId -> VarMap -> Term -> TCM Term occursCheck m xs v = Bench.billTo [ Bench.Typing, Bench.OccursCheck ] $ do mv <- lookupLocalMeta m n <- getContextSize- reportSDoc "tc.meta.occurs" 65 $ "occursCheck" <+> pretty m <+> text (show xs)- let initEnv unf = FreeEnv- { feExtra = OccursExtra- { occUnfold = unf- , occMeta = m- , occVars = xs- , occRHS = v- , occCxtSize = n- }- , feFlexRig = StronglyRigid -- ? Unguarded- , feModality = getModality mv- , feSingleton = variableCheck xs- }- initOccursCheck mv+ reportSDoc "tc.meta.occurs" 65 $ "occursCheck" <+> pretty m <+> prettyTCM xs+ let initCxt unf = OccursCxt+ { occUnfold = unf+ , occMeta = m+ -- The solution is checked at the meta's modality, so divide by it.+ , occVars = mapVarMap (fmap (inverseApplyModalityButNotQuantity (getModality mv))) xs+ , occRHS = v+ , occLocals = 0+ , occModality = getModality mv+ , occLocalModalities = []+ , occFlexRig = StronglyRigid+ }+ initOccursCheck m mv do -- First try without normalising the term- (occurs v `runReaderT` initEnv NoUnfold) `catchError` \err -> do+ (occurs v `runReaderT` initCxt NoUnfold) `catchError` \err -> do -- If first run is inconclusive, try again with normalization -- (unless metavariable is irrelevant, in which case the -- constraint will anyway be dropped) case err of PatternErr{} | not (isIrrelevant $ getModality mv) -> do- initOccursCheck mv- occurs v `runReaderT` initEnv YesUnfold+ initOccursCheck m mv+ occurs v `runReaderT` initCxt YesUnfold _ -> throwError err instance Occurs Term where- occurs v = do+ occurs !v = do vb <- unfoldB v let block = getBlocker vb -- On a failure, we should retry when any meta that is blocking -- the term is solved.- flexIfBlocked = if+ flexIfBlocked act = expand \ret -> if -- In the metavariable case we should not yet become flexible -- because otherwise pruning won't fire.- | MetaV{} <- ignoreBlocking vb -> addOrUnblocker block- | block /= neverUnblock -> flexibly . addOrUnblocker block+ | MetaV{} <- ignoreBlocking vb -> ret $ addOrUnblocker block act+ | block /= neverUnblock -> ret $ flexibly $ addOrUnblocker block act -- Re #3594, do not fail hard when Underapplied: -- the occurrence could be computed away after eta expansion.- | NotBlocked{blockingStatus = Underapplied} <- vb -> flexibly- | otherwise -> id+ | NotBlocked{blockingStatus = Underapplied} <- vb -> ret $ flexibly act+ | otherwise -> ret act v <- reduceProjectionLike $ ignoreBlocking vb flexIfBlocked $ do ctx <- ask- let m = occMeta . feExtra $ ctx+ let m = occMeta ctx reportSDoc "tc.meta.occurs" 45 $- text ("occursCheck " ++ prettyShow m ++ " (" ++ show (feFlexRig ctx) ++ ") of ") <+> prettyTCM v+ text ("occursCheck " ++ prettyShow m ++ " (" ++ show (occFlexRig ctx) ++ ") of ") <+> prettyTCM v reportSDoc "tc.meta.occurs" 70 $ nest 2 $ pretty v- case v of- Var i es -> do- allowed <- getAll . ($ unitModality) <$> variable i+ expand \ret -> case v of+ Var i es -> ret do+ allowed <- variableCheck i++ reportSDoc "tc.meta.occurs.modal" 60 $ vcat+ [ "checking variable" <+> prettyTCM (var i) <+> parens (pretty (var i))+ , nest 2 "allowed:" <+> pretty allowed+ ]+ debugModalities+ if allowed then Var i <$> weakly (occurs es) else do -- if the offending variable is of singleton type, -- eta-expand it away@@ -452,25 +609,24 @@ -- could potentially be salvaged by eta expansion. ifM (($ i) <$> allowedVars) -- vv TODO: neverUnblock is not correct! What could trigger this eta expansion though? (patternViolation' neverUnblock 70 $ "Disallowed var " ++ show i ++ " due to modality/relevance")- (strongly $ abort neverUnblock $ MetaCannotDependOn m (occRHS $ feExtra ctx) i)+ (strongly $ abort neverUnblock $ MetaCannotDependOn m (occRHS ctx) i) -- is a singleton type with unique inhabitant sv (Just sv) -> return $ sv `applyE` es- Lam h f -> do- Lam h <$> occurs f- Level l -> Level <$> occurs_ l- Lit l -> return v- Dummy{} -> return v- DontCare v -> dontCare <$> do+ Lam h f -> ret $ Lam h <$> occursInAbs (getModality h) f+ Level l -> ret $ Level <$> occurs_ l+ Lit l -> ret $ return v+ Dummy{} -> ret $ return v+ DontCare v -> ret $ dontCare <$> do onlyReduceTypes $ underRelevance irrelevant $ occurs v- Def d es -> do+ Def d es -> ret do definitionCheck d Def d <$> occDef d es- Con c ci vs -> do+ Con c ci vs -> ret do definitionCheck (conName c) Con c ci <$> conArgs vs (occurs vs) -- if strongly rigid, remain so, except with unreduced IApply arguments.- Pi a b -> Pi <$> occurs_ a <*> occurs b- Sort s -> Sort <$> do underRelevance shapeIrrelevant $ occurs_ s- MetaV m' es -> do+ Pi a b -> ret $ Pi <$> occurs a <*> occursInPiAbs (getModality a) b+ Sort s -> ret $ Sort <$> do underRelevance shapeIrrelevant $ occurs_ s+ MetaV m' es -> ret do m' <- metaCheck m' -- The arguments of a meta are in a flexible position (MetaV m' <$> do flexibly $ occurs es) `catchError` \ err -> do@@ -500,7 +656,7 @@ -- a data or record type constructor propagates strong occurrences -- since e.g. x = List x is unsolvable occDef d vs = do- m <- asks (occMeta . feExtra)+ m <- asks occMeta lift $ metaOccurs m d ifM (liftTCM $ isJust <$> isDataOrRecordType d) {-then-} (occurs vs)@@ -510,14 +666,14 @@ v <- instantiate v case v of Var i vs -> metaOccurs m vs- Lam h f -> metaOccurs m f+ Lam h f -> metaOccursInAbs m f Level l -> metaOccurs m l Lit l -> return () Dummy{} -> return () DontCare v -> metaOccurs m v Def d vs -> metaOccurs2 m d vs Con c _ vs -> metaOccurs m vs- Pi a b -> metaOccurs2 m a b+ Pi a b -> metaOccurs m a >> metaOccursInAbs m b Sort s -> metaOccurs m s -- vv m is already an unblocker MetaV m' vs | m == m' -> patternViolation' neverUnblock 50 $ "Found occurrence of " ++ prettyShow m | otherwise -> addOrUnblocker (unblockOnMeta m') $ metaOccurs m vs@@ -575,20 +731,28 @@ metaOccurs m (Plus n l) = metaOccurs m l instance Occurs Type where- occurs (El s v) = El <$> occurs_ s <*> occurs v+ occurs (El s v) = El <$> underSortAnnotation (occurs_ s) <*> occurs v metaOccurs m (El s v) = metaOccurs2 m s v instance Occurs Sort where- occurs s = do+ occurs !s = do unfold s >>= \case- PiSort a s1 s2 -> do+ PiSort c a s1 s2 -> do+ -- We ignore occurrences in the blocked dependency check (these will+ -- vanish after 'PiSort' reduces) s1' <- flexibly $ occurs_ s1- a' <- (a $>) <$> do flexibly $ occurs (unDom a)- s2' <- mapAbstraction (El s1' <$> a') (flexibly . underBinder . occurs_) s2- return $ PiSort a' s1' s2'+ a' <- flexibly $ occurs a+ s2' <- mapAbstraction (El s1' <$> a') (flexibly . underPiBinder (getModality a) . occurs_) s2+ return $ PiSort c a' s1' s2' FunSort s1 s2 -> FunSort <$> flexibly (occurs_ s1) <*> flexibly (occurs_ s2)- Univ u a -> Univ u <$> occurs_ a+ Univ u a -> do+ -- If --erasure has been turned on, then the argument of+ -- Set/Prop/SSet is erased.+ erasureEnabled <- optErasure <$> pragmaOptions+ Univ u <$>+ (if erasureEnabled then underQuantity zeroQuantity else id)+ (occurs_ a) s@Inf{} -> return s s@SizeUniv -> return s s@LockUniv -> return s@@ -603,10 +767,12 @@ return $ DefS x es DummyS{} -> return s - metaOccurs m s = do+ metaOccurs !m !s = do s <- instantiate s case s of- PiSort a s1 s2 -> do+ PiSort _c a s1 s2 -> do+ -- We ignore occurrences in the blocked dependency check (these will+ -- vanish after 'PiSort' reduces) metaOccurs m a metaOccurs m s1 metaOccurs m (absBody s2)@@ -646,30 +812,35 @@ Apply a -> metaOccurs m a IApply x y a -> metaOccurs3 m x y a -instance Occurs (Abs Term) where- occurs (NoAbs s x) = NoAbs s <$> occurs x- occurs x = mapAbstraction_ (\body -> underBinder $ occurs body) x-- metaOccurs m (Abs _ x) = metaOccurs m x- metaOccurs m (NoAbs _ x) = metaOccurs m x+occursInAbs :: (Occurs a, Subst a) => Modality -> Abs a -> OccursM (Abs a)+occursInAbs mod (NoAbs s x) = NoAbs s <$> occurs x+occursInAbs mod x = mapAbstraction_ (underBinder mod . occurs) x -instance Occurs (Abs Type) where- occurs (NoAbs s x) = NoAbs s <$> occurs_ x- occurs x = mapAbstraction_ (\body -> underBinder $ occurs_ body) x+occursInPiAbs :: (Occurs a, Subst a) => Modality -> Abs a -> OccursM (Abs a)+occursInPiAbs mod (NoAbs s x) = NoAbs s <$> occurs x+occursInPiAbs mod x = mapAbstraction_ (underPiBinder mod . occurs) x - metaOccurs m (Abs _ x) = metaOccurs m x- metaOccurs m (NoAbs _ x) = metaOccurs m x+metaOccursInAbs :: Occurs a => MetaId -> Abs a -> TCM ()+metaOccursInAbs m (Abs _ x) = metaOccurs m x+metaOccursInAbs m (NoAbs _ x) = metaOccurs m x instance Occurs a => Occurs (Arg a) where- occurs (Arg info v) = Arg info <$> do- applyWhen (isIrrelevant info) onlyReduceTypes $- underModality info $ occurs v+ occurs arg = expand \ret -> case arg of+ Arg info v -> ret $ Arg info <$> do+ debugModalities+ verboseBracket "tc.meta.occurs.arg" 70 ("going under arg " <> show (P.pretty (getModality info))) $+ expand \ret -> if isIrrelevant info+ then ret $ onlyReduceTypes $ occUnderArgModality (getModality info) $ debugModalities >> occurs v+ else ret $ occUnderArgModality (getModality info) $ debugModalities >> occurs v metaOccurs m = metaOccurs m . unArg instance Occurs a => Occurs (Dom a) where- occurs :: Occurs a => Dom a -> OccursM (Dom a)- occurs (Dom info n f t x) =- Dom info n f t <$> underQuantity info (occurs x)+ occurs :: Dom a -> OccursM (Dom a)+ -- As in 'Agda.TypeChecking.Rules.Term.checkTypedBindings': the domain is+ -- checked at the binder's quantity and cohesion, in negative position.+ occurs (Dom info n f t r x) =+ Dom info n f t r <$> underQuantity info (local (divideVars domMod) $ occurs x)+ where domMod = setCohesion (getCohesion info) $ setModalPolarity negativePolarity unitModality --------------------------------------------------------------------------- -- * Pruning: getting rid of flexible occurrences.@@ -683,12 +854,11 @@ -- If any of the meta args @vs@ is matchable, e.g., is a constructor term, -- we cannot prune, because the offending variables could be removed by -- reduction for a suitable instantiation of the meta variable.-prune- :: (PureTCM m, MonadMetaSolver m)- => MetaId -- ^ Meta to prune.+prune ::+ MetaId -- ^ Meta to prune. -> Args -- ^ Arguments to meta variable. -> (Nat -> Bool) -- ^ Test for allowed variable (de Bruijn index).- -> m PruneResult+ -> TCM PruneResult prune m' vs xs = do caseEitherM (runExceptT $ mapM ((hasBadRigid xs) . unArg) vs) (const $ return PrunedNothing) $ \ kills -> do@@ -844,7 +1014,7 @@ LockUniv -> return False LevelUniv -> return False IntervalUniv -> return False- PiSort a s1 s2 -> return False+ PiSort c a s1 s2 -> return False FunSort s1 s2 -> return False UnivSort s -> anyRigid f s MetaS{} -> return False@@ -892,17 +1062,17 @@ -- | @killArgs [k1,...,kn] X@ prunes argument @i@ from metavar @X@ if @ki==True@. -- Pruning is carried out whenever > 0 arguments can be pruned.-killArgs :: (MonadMetaSolver m) => [Bool] -> MetaId -> m PruneResult+killArgs :: [Bool] -> MetaId -> TCM PruneResult killArgs kills _ | not (or kills) = return NothingToPrune -- nothing to kill killArgs kills m = do mv <- lookupLocalMeta m- allowAssign <- asksTC envAssignMetas+ allowAssign <- viewTC eAssignMetas if mvFrozen mv == Frozen || not allowAssign then return PrunedNothing else do -- Andreas 2011-04-26, we allow pruning in MetaV and MetaS let a = jMetaType $ mvJudgement mv TelV tel b <- telView' <$> instantiateFull a- let args = zip (telToList tel) (kills ++ repeat False)+ let args = zip (telToList tel) (ListInf.pad kills False) (kills', a') <- killedType args b dbg kills' a a' -- If there is any prunable argument, perform the pruning@@ -911,7 +1081,7 @@ -- Only successful if all occurrences were killed -- Andreas, 2011-05-09 more precisely, check that at least -- the in 'kills' prescribed kills were carried out- return $ if (and $ zipWith implies kills $ map unArg kills')+ return $ if (and $ zipWith' implies kills $ map' unArg kills') then PrunedEverything else PrunedSomething where@@ -939,7 +1109,7 @@ killedType args b = do let n = length args- let iargs = zip (downFrom n) args+ let iargs = zip' (downFrom n) args -- Turn list of bools into an VarSet containing the variables we want to kill -- (indices relative to b).@@ -949,16 +1119,13 @@ (tokill, b) <- reallyNotFreeIn tokill b -- Then recurse over the telescope (right-to-left), building up the final type.- (killed, b) <- go (reverse $ map fst args) tokill b+ (killed, b) <- go (reverse $ map' fst args) tokill b -- Turn the VarSet of killed variables into the list of Arg Bool's to return.- let kills = [ Arg (getArgInfo dom) (VarSet.member i killed)- | (i, (dom, _)) <- iargs ]+ let kills = map' (\(i, (dom, _)) -> Arg $$! getArgInfo dom $$! VarSet.member i killed)+ iargs return (kills, b) where- down = VarSet.mapMonotonic pred- up = VarSet.mapMonotonic succ- -- go Δ xs B -- Invariants: -- - Δ ⊢ B@@ -970,37 +1137,37 @@ -- ys ⊆ xs are the variables that were dropped from Δ -- B' = strengthen ys B go :: (MonadReduce m) => [Dom (ArgName, Type)] -> VarSet -> Type -> m (VarSet, Type)- go [] xs b | VarSet.null xs = return (xs, b)+ go [] xs b | null xs = return (xs, b) | otherwise = __IMPOSSIBLE__ go (arg : args) xs b -- go (Δ (x : A)) xs B, (x = deBruijn index 0) | VarSet.member 0 xs = do -- Case x ∈ xs. We know x ∉ FV(B), so we can safely drop x from the -- telescope. Drop x from xs (and shift indices) and recurse with -- `strengthen x B`.- let ys = down (VarSet.delete 0 xs)+ let ys = VarSet.strengthen 1 xs (ys, b) <- go args ys $ strengthen impossible b -- We need to return a set of killed variables relative to Δ (x : A), so -- shift ys and add x back in.- return (VarSet.insert 0 $ up ys, b)+ return (VarSet.insert 0 $ VarSet.weaken 1 ys, b) | otherwise = do -- Case x ∉ xs. We either can't or don't want to get rid of x. In -- this case we have to check A for potential dependencies preventing -- us from killing variables in xs.- let xs' = down xs -- Shift to make relative to Δ ⊢ A+ let xs' = VarSet.strengthen 1 xs -- Shift to make relative to Δ ⊢ A (name, a) = unDom arg (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 -- Shift back up to make it relative to Δ (x : A) again.- return (up zs, b)+ return (VarSet.weaken 1 zs, b) reallyNotFreeIn :: (MonadReduce m) => VarSet -> Type -> m (VarSet, Type)-reallyNotFreeIn xs a | VarSet.null xs = return (xs, a) -- Shortcut+reallyNotFreeIn xs a | null xs = return (xs, a) -- Shortcut reallyNotFreeIn xs a = do- let fvs = freeVars a+ let fvs = freeVarMap a anywhere = allVars fvs- rigid = VarSet.unions [stronglyRigidVars fvs, unguardedVars fvs]+ rigid = VarSet.union (stronglyRigidVars fvs) (unguardedVars fvs) nonrigid = VarSet.difference anywhere rigid hasNo = VarSet.disjoint xs if hasNo nonrigid@@ -1009,21 +1176,20 @@ -- occurrences so drop those and leave `a` untouched. return (VarSet.difference xs rigid, a) else do- -- If there are non-rigid occurrences we need to reduce a to see if+ -- If there are non-rigid occurrences we need to reduce to see if -- we can get rid of them (#3177).- (fvs, a) <- forceNotFree (VarSet.difference xs rigid) a- let xs = IntMap.keysSet $ IntMap.filter (== NotFree) fvs+ (fvs, a) <- liftReduce $ forceNotFree (VarSet.difference xs rigid) a+ let xs = nonFreeVars fvs return (xs, a) -- | Instantiate a meta variable with a new one that only takes -- the arguments which are not pruneable.-performKill- :: MonadMetaSolver m- => [Arg Bool] -- ^ Arguments to old meta var in left to right order+performKill ::+ [Arg Bool] -- ^ Arguments to old meta var in left to right order -- with @Bool@ indicating whether they can be pruned. -> MetaId -- ^ The old meta var to receive pruning. -> Type -- ^ The pruned type of the new meta var.- -> m ()+ -> TCM () performKill kills m a = do mv <- lookupLocalMeta m when (mvFrozen mv == Frozen) __IMPOSSIBLE__@@ -1033,7 +1199,7 @@ -- which are not pruned in left to right order -- (de Bruijn level order). let perm = Perm n- [ i | (i, Arg _ False) <- zip [0..] kills ]+ [ i | (i, Arg _ False) <- zip (ListInf.upFrom 0) kills ] -- The permutation for the old meta might range over a prefix of the arguments oldPerm = liftP (max 0 $ n - m) p where p = mvPermutation mv@@ -1047,11 +1213,11 @@ let -- Arguments to new meta (de Bruijn indices) -- in left to right order. vars = [ Arg info (var i)- | (i, Arg info False) <- zip (downFrom n) kills ]- u = MetaV m' $ map Apply vars+ | (i, Arg info False) <- zip' (downFrom n) kills ]+ u = MetaV m' $! map' Apply vars -- Arguments to the old meta (just arg infos and name hints) -- in left to right order.- tel = map ("v" <$) kills+ tel = map' ("v" <$) kills dbg m' u assignTerm m tel u -- m tel := u where
src/full/Agda/TypeChecking/Modalities.hs view
@@ -12,22 +12,18 @@ import Agda.Syntax.Common import Agda.Syntax.Internal--import Agda.TypeChecking.Conversion import Agda.TypeChecking.Free-import Agda.TypeChecking.Free.Lazy import Agda.TypeChecking.Monad import Agda.TypeChecking.Pretty import Agda.TypeChecking.Substitute import Agda.Utils.Function-import Agda.Utils.Lens import Agda.Utils.Maybe import Agda.Utils.Monad -- | The second argument is the definition of the first. -- Returns 'Nothing' if ok, otherwise the error message.-checkRelevance' :: (MonadConversion m) => QName -> Definition -> m (Maybe TypeError)+checkRelevance' :: QName -> Definition -> TCM (Maybe TypeError) checkRelevance' x def = do case getRelevance def of Relevant{} -> return Nothing -- relevance functions can be used in any context.@@ -49,7 +45,7 @@ -- | The second argument is the definition of the first. -- Returns 'Nothing' if ok, otherwise the error message.-checkQuantity' :: (MonadConversion m) => QName -> Definition -> m (Maybe TypeError)+checkQuantity' :: QName -> Definition -> TCM (Maybe TypeError) checkQuantity' x def = do case getQuantity def of dq@Quantityω{} -> do@@ -59,7 +55,7 @@ ] return Nothing -- Abundant definitions can be used in any context. dq -> do- q <- viewTC eQuantity+ q <- viewTC eQuantityZeroHardCompile reportSDoc "tc.irr" 50 $ vcat [ "declaration quantity =" <+> text (show dq) , "context quantity =" <+> text (show q)@@ -67,23 +63,23 @@ return $ boolToMaybe (not $ dq `moreQuantity` q) $ DefinitionIsErased x -- | The second argument is the definition of the first.-checkModality' :: (MonadConversion m) => QName -> Definition -> m (Maybe TypeError)+checkModality' :: QName -> Definition -> TCM (Maybe TypeError) checkModality' x def = do relOk <- checkRelevance' x def qtyOk <- checkQuantity' x def return $ relOk <|> qtyOk -- | The second argument is the definition of the first.-checkModality :: (MonadConversion m) => QName -> Definition -> m ()+checkModality :: QName -> Definition -> TCM () checkModality x def = checkModality' x def >>= mapM_ typeError -- | Checks that the given implicitely inserted arguments, are used in a modally -- correct way.-checkModalityArgs :: (MonadConversion m) => Definition -> Args -> m ()+checkModalityArgs :: Definition -> Args -> TCM () checkModalityArgs d vs = do let vmap :: VarMap- vmap = freeVars vs+ vmap = freeVarMap vs -- we iterate over all vars in the context and their ArgInfo, -- checking for each that "vs" uses them as allowed.
src/full/Agda/TypeChecking/Monad/Base.hs view
@@ -1,6700 +1,7574 @@ {-# LANGUAGE CPP #-}--- {-# LANGUAGE UndecidableInstances #-} -- ghc >= 8.2, GeneralizedNewtypeDeriving MonadTransControl BlockT--- Turning off DeepSubsumption for--- SPECIALIZE mapTCMT :: (forall a. IO a -> IO a) -> TCM a -> TCM a--- with GHC 9.14-#if __GLASGOW_HASKELL__ >= 914-{-# LANGUAGE NoDeepSubsumption #-}-#endif--module Agda.TypeChecking.Monad.Base- ( module Agda.TypeChecking.Monad.Base- , module Agda.TypeChecking.Monad.Base.Types- , module X- , HasOptions (..)- , RecordFieldWarning- , UselessPublicReason(..)- ) where--import Prelude hiding (null)--import Control.Applicative hiding (empty)-import Control.Arrow ( (&&&) )-import Control.Concurrent ( forkIO )-import Control.DeepSeq-import qualified Control.Exception as E--import Control.Monad.Except ( MonadError(..), ExceptT(..), runExceptT )-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(..), runWriterT )-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 (on)-import Data.Word (Word32)-import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-import Data.IntSet (IntSet)-import qualified Data.IntSet as IntSet-import qualified Data.List as List-import Data.Maybe-import Data.Map (Map)-import qualified Data.Map as Map -- hiding (singleton, null, empty)-import Data.Sequence (Seq)-import Data.Set (Set, toList, fromList)-import qualified Data.Set as Set -- hiding (singleton, null, empty)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HMap-import qualified Data.HashSet as HashSet-import Data.Hashable-import Data.HashSet (HashSet)-import Data.Semigroup ( Semigroup, (<>)) --, Any(..) )-import Data.Set (Set)-import qualified Data.Set as Set-import Data.String-import Data.Text (Text)-import qualified Data.Text.Lazy as TL--import Data.IORef--import GHC.Generics (Generic)--import System.IO (hFlush, stdout)--import Agda.Benchmarking (Benchmark, Phase)--import {-# SOURCE #-} Agda.Compiler.Treeless.Pretty () -- Instances only-import Agda.Syntax.Common-import Agda.Syntax.Builtin (SomeBuiltin, BuiltinId, PrimitiveId)-import qualified Agda.Syntax.Concrete as C-import Agda.Syntax.Concrete.Definitions- (NiceDeclaration, DeclarationWarning, declarationWarningName)-import Agda.Syntax.Concrete.Definitions.Errors- (DeclarationException')-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.Monad (ParseError, ParseWarning, 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 Agda.Syntax.Info ( MetaKind(InstanceMeta, UnificationMeta), MetaNameSuggestion, MutualInfo )--import Agda.TypeChecking.Monad.Base.Types-import qualified Agda.TypeChecking.Monad.Base.Warning as W-import Agda.TypeChecking.Monad.Base.Warning (RecordFieldWarning, UselessPublicReason(..))-import Agda.TypeChecking.SizedTypes.Syntax (HypSizeConstraint)--import Agda.TypeChecking.CompiledClause-import Agda.TypeChecking.Coverage.SplitTree-import Agda.TypeChecking.Positivity.Occurrence-import Agda.TypeChecking.Free.Lazy (Free(freeVars'), underBinder', underBinder)--import Agda.TypeChecking.DiscrimTree.Types--import Agda.Termination.Termination (GuardednessHelps(..))--import Agda.Compiler.Backend.Base (Backend_boot, Backend'_boot)--import Agda.Interaction.Options-import qualified Agda.Interaction.Options.Errors as ErrorName-import Agda.Interaction.Options.Errors as X- ( CannotQuoteTerm(..)- , ErasedDatatypeReason(..)- , NotAValidLetBinding(..)- , NotAValidLetExpression(..)- , NotAllowedInDotPatterns(..)- )-import Agda.Interaction.Options.Warnings-import Agda.Interaction.Response.Base (Response_boot(..))-import Agda.Interaction.Highlighting.Precise- (HighlightingInfo, NameKind)-import Agda.Interaction.Library-import Agda.Interaction.Library.Base ( ExeName, ExeMap, LibCache, LibErrors )--import Agda.Utils.Benchmark (MonadBench(..))-import Agda.Utils.BiMap (BiMap, HasTag(..))-import qualified Agda.Utils.BiMap as BiMap-import Agda.Utils.Boolean ( fromBool, toBool )-import Agda.Utils.CallStack ( CallStack, HasCallStack, withCallerCallStack )-import Agda.Utils.FileId as X ( FileId, MonadFileId( idFromFile, fileFromId ) )-import Agda.Utils.FileId ( FileDictBuilder, GetFileId(getFileId), GetIdFile(getIdFile) )-import Agda.Utils.FileName-import Agda.Utils.Functor-import Agda.Utils.Hash-import Agda.Utils.IO ( CatchIO, catchIO, showIOException )-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.Syntax.Common.Pretty-import Agda.Utils.SmallSet (SmallSet, SmallSetElement)-import qualified Agda.Utils.SmallSet as SmallSet-import Agda.Utils.Set1 (Set1)-import Agda.Utils.Singleton-import Agda.Utils.Tuple (Pair)-import Agda.Utils.Update--import Agda.Utils.Impossible-------------------------------------------------------------------------------- * Type checking state------------------------------------------------------------------------------data TCState = TCSt- { stPersistentState :: !PersistentTCState- -- ^ State which persists while we build an Agda project (same main file).- , stPreScopeState :: !PreScopeState- -- ^ The state which is frozen after scope checking.- , stPostScopeState :: !PostScopeState- -- ^ The state which is modified after scope checking.- }- deriving Generic--class Monad m => ReadTCState m where- getTCState :: m TCState- locallyTCState :: Lens' TCState a -> (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' TCState a -> (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{}"--type Backend = Backend_boot Definition TCM-type Backend' opts env menv mod def = Backend'_boot Definition TCM opts env menv mod def--type BackendForeignCode = Map BackendName ForeignCodeStack-type ImportedModules = Set TopLevelModuleName-type UserWarnings = Map QName Text--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 :: !ImportedModules- -- Andreas, 2023-08-05, issue #6750, don't make this a 'HashSet'- -- because then the order of its @toList@ is undefined,- -- leading to undefined deserialization order.- -- ^ The top-level modules imported by the current module.- , stPreImportedModulesTransitive :: !ImportedModules- -- ^ The top-level modules transitively imported by the current module.- , stPreModuleToSourceId :: !ModuleToSourceId -- imports- , stPreVisitedModules :: !VisitedModules -- imports- -- ^ Modules loaded so far.- -- In contrast 'stDecodedModules', contains also modules that are only scope-checked.- , 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 variables we wish to generalize over; used during scope checking of terms.- -- If 'Nothing', we are in a position where we do not support generalization,- -- and do not accept additions to this collection.- , stPrePragmaOptions :: !PragmaOptions- -- ^ Options applying to the current file. @OPTIONS@- -- pragmas only affect this field.- , stPreImportedBuiltins :: !BuiltinThings- , stPreImportedDisplayForms :: !DisplayForms- -- ^ Display forms added by someone else to imported identifiers- , stPreFreshInteractionId :: !InteractionId- , stPreImportedUserWarnings :: !UserWarnings- -- ^ Imported @UserWarning@s, not to be stored in the @Interface@- , stPreLocalUserWarnings :: !UserWarnings- -- ^ 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@- , stPreLibCache :: !LibCache- -- ^ Cached @.agda-lib@ files.- , stPreImportedMetaStore :: !RemoteMetaStore- -- ^ Used for meta-variables from other modules.- , stPreCopiedNames :: !(HashMap A.QName A.QName)- -- ^ Associates a copied name (the key) to its original name (the- -- value). Computed by the scope checker, used to compute opaque- -- blocks.- , stPreNameCopies :: !(HashMap A.QName (HashSet A.QName))- -- ^ Associates an original name (the key) to all its copies (the- -- value). Computed by the scope checker, used to compute opaque- -- blocks.- }- 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 (List1 C.Name)-type ShadowingNames = Map Name (Set1 RawName)-type UsedNames = Map RawName (Set1 RawName)--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- , stPostForeignCode :: !BackendForeignCode- -- ^ @{-\# FOREIGN \#-}@ code that should be included in the compiled output.- -- Does not include code for imported modules.- , stPostCurrentModule ::- !(Maybe (ModuleName, TopLevelModuleName))- -- ^ The current module is available after it has been type- -- checked.-- , stPostPendingInstances :: !(Set QName)-- , stPostTemporaryInstances :: !(Set QName)-- , 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 :: !UsedNames- -- ^ 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 :: !ShadowingNames- -- ^ 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 :: !(Set TCWarning)- , stPostMutualBlocks :: !MutualBlocks- , stPostLocalBuiltins :: !BuiltinThings- , stPostFreshMetaId :: !MetaId- , stPostFreshMutualId :: !MutualId- , stPostFreshProblemId :: !ProblemId- , stPostFreshCheckpointId :: !CheckpointId- , stPostFreshInt :: !Int- , stPostFreshNameId :: !NameId- , stPostFreshOpaqueId :: !OpaqueId- , 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@- , stPostOpaqueBlocks :: Map OpaqueId OpaqueBlock- -- ^ Associates opaque identifiers to their actual blocks.- , stPostOpaqueIds :: Map QName OpaqueId- -- ^ Associates each opaque QName to the block it was defined in.- , stPostInstanceHack :: !Bool- -- ^ Is this a context where we should always try every possible- -- instance candidate? Used to support "inert improvement", see- -- @shouldBlockOverlap@ in InstanceArguments.- }- deriving (Generic)---- | A part of the state that grows monotonically over the whole Agda session.--- Never reset.-data SessionTCState = SessionTCState- { stSessionBenchmark :: !Benchmark- -- ^ Structure to track how much CPU time was spent on which Agda phase.- -- Needs to be a strict field to avoid space leaks!- , stSessionBackends :: [Backend]- -- ^ Backends with their options.- , stSessionFileDict :: !FileDictWithBuiltins- -- ^ Map file names to unique 'FileId' and back.- -- Assuming we do not see terribly many different files during one Agda session,- -- this map needs not be garbage-collected.- --- -- Also informs about whether a 'FileId' belongs to one of- -- Agda's primitive and builtin modules.- }- deriving (Generic)---- | A part of the state which is not reverted when an error is thrown--- or the state is reset.-data PersistentTCState = PersistentTCSt- { stPersistentSession :: !SessionTCState- -- ^ State that persists for the whole Agda session.- -- Grows monotonically, never sees any deletion.- , stDecodedModules :: !DecodedModules- -- ^ Type-checked modules we visited during our Agda session.- -- A module gets dropped from this list if its source- -- or the source of any of its dependencies changed,- -- or when its identity or the identity of one of its dependencies changed- -- due to a change of the include paths.- , 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'.- , stAccumStatistics :: !Statistics- -- ^ Should be strict field.- , stPersistLoadedFileCache :: !(Strict.Maybe LoadedFileCache)- -- ^ Cached typechecking state from the last loaded file.- -- Should be @Nothing@ when checking imports.- }- 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 !Erased !ModuleName !A.Telescope- | LeaveSection !ModuleName- | Decl !A.Declaration- -- ^ Never a Section or ScopeDecl- | Pragmas !PragmaOptions- deriving (Generic)----- | Empty session state.--initFileDict :: AbsolutePath -> FileDictWithBuiltins-initFileDict primLibDir = FileDictWithBuiltins empty empty primLibDir--initSessionState :: AbsolutePath -> SessionTCState-initSessionState primLibDir = SessionTCState- { stSessionFileDict = initFileDict primLibDir- , stSessionBenchmark = empty- , stSessionBackends = empty- }---- | Empty persistent state.--initPersistentState :: AbsolutePath -> PersistentTCState-initPersistentState = initPersistentStateFromSessionState . initSessionState--initPersistentStateFromSessionState :: SessionTCState -> PersistentTCState-initPersistentStateFromSessionState s = PersistentTCSt- { stPersistentSession = s- , stPersistentOptions = defaultOptions- , stPersistentTopLevelModuleNames = empty- , stDecodedModules = Map.empty- , stInteractionOutputCallback = defaultInteractionOutputCallback- , stAccumStatistics = Map.empty- , stPersistLoadedFileCache = empty- }---- | 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- , stPreImportedModulesTransitive = empty- , stPreModuleToSourceId = Map.empty- , stPreVisitedModules = Map.empty- , stPreScope = emptyScopeInfo- , stPrePatternSyns = Map.empty- , stPrePatternSynImports = Map.empty- , stPreGeneralizedVars = mempty- , stPrePragmaOptions = defaultInteractionOptions- , stPreImportedBuiltins = Map.empty- , stPreImportedDisplayForms = HMap.empty- , stPreFreshInteractionId = 0- , stPreImportedUserWarnings = Map.empty- , stPreLocalUserWarnings = Map.empty- , stPreWarningOnImport = empty- , stPreImportedPartialDefs = Set.empty- , stPreLibCache = empty- , stPreImportedMetaStore = HMap.empty- , stPreCopiedNames = HMap.empty- , stPreNameCopies = 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- , stPostPendingInstances = Set.empty- , stPostTemporaryInstances = Set.empty- , stPostConcreteNames = Map.empty- , stPostUsedNames = Map.empty- , stPostShadowingNames = Map.empty- , stPostStatistics = Map.empty- , stPostTCWarnings = empty- , stPostMutualBlocks = empty- , stPostLocalBuiltins = Map.empty- , stPostFreshMetaId = initialMetaId- , stPostFreshMutualId = 0- , stPostFreshProblemId = 1- , stPostFreshCheckpointId = 1- , stPostFreshInt = 0- , stPostFreshNameId = NameId 0 noModuleNameHash- , stPostFreshOpaqueId = OpaqueId 0 noModuleNameHash- , stPostAreWeCaching = False- , stPostPostponeInstanceSearch = False- , stPostConsideringInstance = False- , stPostInstantiateBlocking = False- , stPostLocalPartialDefs = Set.empty- , stPostOpaqueBlocks = Map.empty- , stPostOpaqueIds = Map.empty- , stPostForeignCode = Map.empty- , stPostInstanceHack = False- }--initStateIO :: IO TCState-initStateIO = initState <$> getPrimitiveLibDir--initState :: AbsolutePath -> TCState-initState = initStateFromSessionState . initSessionState--initStateFromSessionState :: SessionTCState -> TCState-initStateFromSessionState = initStateFromPersistentState . initPersistentStateFromSessionState--initStateFromPersistentState :: PersistentTCState -> TCState-initStateFromPersistentState s = TCSt- { stPersistentState = s- , stPreScopeState = initPreScopeState- , stPostScopeState = initPostScopeState- }---- * Lenses for 'TCState'---- ** Components of 'TCState'--lensPersistentState :: Lens' TCState PersistentTCState-lensPersistentState f s = f (stPersistentState s) <&> \ x -> s { stPersistentState = x }--lensPreScopeState :: Lens' TCState PreScopeState-lensPreScopeState f s = f (stPreScopeState s) <&> \ x -> s { stPreScopeState = x }--lensPostScopeState :: Lens' TCState PostScopeState-lensPostScopeState f s = f (stPostScopeState s) <&> \ x -> s { stPostScopeState = x }---- ** Components of 'SessionTCState'--lensSessionState :: Lens' TCState SessionTCState-lensSessionState = lensPersistentState . lensPersistentSession--lensBackends :: Lens' SessionTCState [Backend]-lensBackends f s = f (stSessionBackends s) <&> \ x -> s { stSessionBackends = x }--lensBenchmark :: Lens' SessionTCState Benchmark-lensBenchmark f s = f (stSessionBenchmark s) <&> \ x -> s { stSessionBenchmark = x }--lensFileDict :: Lens' SessionTCState FileDictWithBuiltins-lensFileDict f s = f (stSessionFileDict s) <&> \ x -> s { stSessionFileDict = x }--lensFileDictBuilder :: Lens' SessionTCState FileDictBuilder-lensFileDictBuilder = lensFileDict . lensFileDictFileDictBuilder--lensBuiltinModuleIds :: Lens' SessionTCState BuiltinModuleIds-lensBuiltinModuleIds = lensFileDict . lensFileDictBuiltinModuleIds--lensPrimitiveLibDir :: Lens' SessionTCState PrimitiveLibDir-lensPrimitiveLibDir = lensFileDict . lensFileDictPrimitiveLibDir---- ** Components of 'PersistentTCState'--lensPersistentSession :: Lens' PersistentTCState SessionTCState-lensPersistentSession f s = f (stPersistentSession s) <&> \ x -> s { stPersistentSession = x }--lensLoadedFileCache :: Lens' PersistentTCState (Strict.Maybe LoadedFileCache)-lensLoadedFileCache f s = f (stPersistLoadedFileCache s) <&> \ x -> s { stPersistLoadedFileCache = x }--lensTopLevelModuleNames :: Lens' PersistentTCState (BiMap RawTopLevelModuleName ModuleNameHash)-lensTopLevelModuleNames f s =- f (stPersistentTopLevelModuleNames s) <&> \ x -> s { stPersistentTopLevelModuleNames = x }---- ** Components of 'PreScopeState'--lensPreTokens :: Lens' PreScopeState HighlightingInfo-lensPreTokens f s = f (stPreTokens s) <&> \ x -> s { stPreTokens = x }--lensImports :: Lens' PreScopeState Signature-lensImports f s = f (stPreImports s) <&> \ x -> s { stPreImports = x }--lensImportedModules :: Lens' PreScopeState ImportedModules-lensImportedModules f s = f (stPreImportedModules s) <&> \ x -> s { stPreImportedModules = x }--lensImportedModulesTransitive :: Lens' PreScopeState ImportedModules-lensImportedModulesTransitive f s = f (stPreImportedModulesTransitive s) <&> \ x -> s { stPreImportedModulesTransitive = x }--lensModuleToSourceId :: Lens' PreScopeState ModuleToSourceId-lensModuleToSourceId f s = f (stPreModuleToSourceId s ) <&> \ x -> s { stPreModuleToSourceId = x }--lensVisitedModules :: Lens' PreScopeState VisitedModules-lensVisitedModules f s = f (stPreVisitedModules s ) <&> \ x -> s { stPreVisitedModules = x }--lensScope :: Lens' PreScopeState ScopeInfo-lensScope f s = f (stPreScope s ) <&> \ x -> s { stPreScope = x }--lensPatternSyns :: Lens' PreScopeState A.PatternSynDefns-lensPatternSyns f s = f (stPrePatternSyns s ) <&> \ x -> s { stPrePatternSyns = x }--lensPatternSynImports :: Lens' PreScopeState A.PatternSynDefns-lensPatternSynImports f s = f (stPrePatternSynImports s ) <&> \ x -> s { stPrePatternSynImports = x }--lensGeneralizedVars :: Lens' PreScopeState (Strict.Maybe (Set QName))-lensGeneralizedVars f s = f (stPreGeneralizedVars s ) <&> \ x -> s { stPreGeneralizedVars = x }--instance LensPragmaOptions PreScopeState where- lensPragmaOptions f s = f (stPrePragmaOptions s ) <&> \ x -> s { stPrePragmaOptions = x }--lensImportedBuiltins :: Lens' PreScopeState BuiltinThings-lensImportedBuiltins f s = f (stPreImportedBuiltins s ) <&> \ x -> s { stPreImportedBuiltins = x }--lensFreshInteractionId :: Lens' PreScopeState InteractionId-lensFreshInteractionId f s = f (stPreFreshInteractionId s ) <&> \ x -> s { stPreFreshInteractionId = x }--lensImportedUserWarnings :: Lens' PreScopeState UserWarnings-lensImportedUserWarnings f s = f (stPreImportedUserWarnings s ) <&> \ x -> s { stPreImportedUserWarnings = x }--lensLocalUserWarnings :: Lens' PreScopeState UserWarnings-lensLocalUserWarnings f s = f (stPreLocalUserWarnings s ) <&> \ x -> s { stPreLocalUserWarnings = x }--lensWarningOnImport :: Lens' PreScopeState (Strict.Maybe Text)-lensWarningOnImport f s = f (stPreWarningOnImport s) <&> \ x -> s { stPreWarningOnImport = x }--lensImportedPartialDefs :: Lens' PreScopeState (Set QName)-lensImportedPartialDefs f s = f (stPreImportedPartialDefs s) <&> \ x -> s { stPreImportedPartialDefs = x }--lensLibCache :: Lens' PreScopeState LibCache-lensLibCache f s = f (stPreLibCache s) <&> \ x -> s { stPreLibCache = x }--lensImportedMetaStore :: Lens' PreScopeState RemoteMetaStore-lensImportedMetaStore f s = f (stPreImportedMetaStore s) <&> \x -> s { stPreImportedMetaStore = x }--lensCopiedNames :: Lens' PreScopeState (HashMap QName QName)-lensCopiedNames f s = f (stPreCopiedNames s) <&> \ x -> s { stPreCopiedNames = x }--lensNameCopies :: Lens' PreScopeState (HashMap QName (HashSet QName))-lensNameCopies f s = f (stPreNameCopies s) <&> \ x -> s { stPreNameCopies = x }---- ** Components of PostScopeState--lensForeignCode :: Lens' PostScopeState BackendForeignCode-lensForeignCode f s = f (stPostForeignCode s ) <&> \ x -> s { stPostForeignCode = x }--lensLocalPartialDefs :: Lens' PostScopeState (Set QName)-lensLocalPartialDefs f s = f (stPostLocalPartialDefs s) <&> \ x -> s { stPostLocalPartialDefs = x }--lensFreshNameId :: Lens' PostScopeState NameId-lensFreshNameId f s = f (stPostFreshNameId s) <&> \ x -> s { stPostFreshNameId = x }--lensFreshOpaqueId :: Lens' PostScopeState OpaqueId-lensFreshOpaqueId f s = f (stPostFreshOpaqueId s) <&> \ x -> s { stPostFreshOpaqueId = x }--lensOpaqueBlocks :: Lens' PostScopeState (Map OpaqueId OpaqueBlock)-lensOpaqueBlocks f s = f (stPostOpaqueBlocks s) <&> \ x -> s { stPostOpaqueBlocks = x }--lensOpaqueIds :: Lens' PostScopeState (Map QName OpaqueId)-lensOpaqueIds f s = f (stPostOpaqueIds s) <&> \ x -> s { stPostOpaqueIds = x }--lensSyntaxInfo :: Lens' PostScopeState HighlightingInfo-lensSyntaxInfo f s = f (stPostSyntaxInfo s) <&> \ x -> s { stPostSyntaxInfo = x }--lensDisambiguatedNames :: Lens' PostScopeState DisambiguatedNames-lensDisambiguatedNames f s = f (stPostDisambiguatedNames s) <&> \ x -> s { stPostDisambiguatedNames = x }--lensOpenMetaStore :: Lens' PostScopeState LocalMetaStore-lensOpenMetaStore f s = f (stPostOpenMetaStore s) <&> \ x -> s { stPostOpenMetaStore = x }--lensSolvedMetaStore :: Lens' PostScopeState LocalMetaStore-lensSolvedMetaStore f s = f (stPostSolvedMetaStore s) <&> \ x -> s { stPostSolvedMetaStore = x }--lensInteractionPoints :: Lens' PostScopeState InteractionPoints-lensInteractionPoints f s = f (stPostInteractionPoints s) <&> \ x -> s { stPostInteractionPoints = x }--lensAwakeConstraints :: Lens' PostScopeState Constraints-lensAwakeConstraints f s = f (stPostAwakeConstraints s) <&> \ x -> s { stPostAwakeConstraints = x }--lensSleepingConstraints :: Lens' PostScopeState Constraints-lensSleepingConstraints f s = f (stPostSleepingConstraints s) <&> \ x -> s { stPostSleepingConstraints = x }--lensDirty :: Lens' PostScopeState Bool-lensDirty f s = f (stPostDirty s) <&> \ x -> s { stPostDirty = x }--lensOccursCheckDefs :: Lens' PostScopeState (Set QName)-lensOccursCheckDefs f s = f (stPostOccursCheckDefs s) <&> \ x -> s { stPostOccursCheckDefs = x }--lensSignature :: Lens' PostScopeState Signature-lensSignature f s = f (stPostSignature s) <&> \ x -> s { stPostSignature = x }--lensModuleCheckpoints :: Lens' PostScopeState (Map ModuleName CheckpointId)-lensModuleCheckpoints f s = f (stPostModuleCheckpoints s) <&> \ x -> s { stPostModuleCheckpoints = x }--lensImportsDisplayForms :: Lens' PostScopeState DisplayForms-lensImportsDisplayForms f s = f (stPostImportsDisplayForms s) <&> \ x -> s { stPostImportsDisplayForms = x }--lensImportedDisplayForms :: Lens' PreScopeState DisplayForms-lensImportedDisplayForms f s = f (stPreImportedDisplayForms s) <&> \ x -> s { stPreImportedDisplayForms = x }--lensTemporaryInstances :: Lens' PostScopeState (Set QName)-lensTemporaryInstances f s = f (stPostTemporaryInstances s) <&> \ x -> s { stPostTemporaryInstances = x }--lensConcreteNames :: Lens' PostScopeState ConcreteNames-lensConcreteNames f s = f (stPostConcreteNames s) <&> \ x -> s { stPostConcreteNames = x }--lensUsedNames :: Lens' PostScopeState UsedNames-lensUsedNames f s = f (stPostUsedNames s) <&> \ x -> s { stPostUsedNames = x }--lensShadowingNames :: Lens' PostScopeState ShadowingNames-lensShadowingNames f s = f (stPostShadowingNames s) <&> \ x -> s { stPostShadowingNames = x }--lensStatistics :: Lens' PostScopeState Statistics-lensStatistics f s = f (stPostStatistics s) <&> \ x -> s { stPostStatistics = x }--lensTCWarnings :: Lens' PostScopeState (Set TCWarning)-lensTCWarnings f s = f (stPostTCWarnings s) <&> \ x -> s { stPostTCWarnings = x }--lensMutualBlocks :: Lens' PostScopeState MutualBlocks-lensMutualBlocks f s = f (stPostMutualBlocks s) <&> \ x -> s { stPostMutualBlocks = x }--lensLocalBuiltins :: Lens' PostScopeState BuiltinThings-lensLocalBuiltins f s = f (stPostLocalBuiltins s) <&> \ x -> s { stPostLocalBuiltins = x }--lensFreshMetaId :: Lens' PostScopeState MetaId-lensFreshMetaId f s = f (stPostFreshMetaId s) <&> \ x -> s { stPostFreshMetaId = x }--lensFreshMutualId :: Lens' PostScopeState MutualId-lensFreshMutualId f s = f (stPostFreshMutualId s) <&> \ x -> s { stPostFreshMutualId = x }--lensFreshProblemId :: Lens' PostScopeState ProblemId-lensFreshProblemId f s = f (stPostFreshProblemId s) <&> \ x -> s { stPostFreshProblemId = x }--lensFreshCheckpointId :: Lens' PostScopeState CheckpointId-lensFreshCheckpointId f s = f (stPostFreshCheckpointId s) <&> \ x -> s { stPostFreshCheckpointId = x }--lensFreshInt :: Lens' PostScopeState Int-lensFreshInt f s = f (stPostFreshInt s) <&> \ x -> s { stPostFreshInt = x }--lensAreWeCaching :: Lens' PostScopeState Bool-lensAreWeCaching f s = f (stPostAreWeCaching s) <&> \x -> s { stPostAreWeCaching = x }--lensPostponeInstanceSearch :: Lens' PostScopeState Bool-lensPostponeInstanceSearch f s = f (stPostPostponeInstanceSearch s) <&> \ x -> s { stPostPostponeInstanceSearch = x }--lensConsideringInstance :: Lens' PostScopeState Bool-lensConsideringInstance f s = f (stPostConsideringInstance s) <&> \ x -> s { stPostConsideringInstance = x }--lensInstantiateBlocking :: Lens' PostScopeState Bool-lensInstantiateBlocking f s = f (stPostInstantiateBlocking s) <&> \ x -> s { stPostInstantiateBlocking = x }--lensInstanceHack :: Lens' PostScopeState Bool-lensInstanceHack f s = f (stPostInstanceHack s) <&> \ x -> s { stPostInstanceHack = x }---- * @st@-prefixed lenses----------------------------------------------------------------------------- ** Session state--stBackends :: Lens' TCState [Backend]-stBackends = lensSessionState . lensBackends--stBenchmark :: Lens' TCState Benchmark-stBenchmark = lensSessionState . lensBenchmark--stFileDict :: Lens' TCState FileDictWithBuiltins-stFileDict = lensSessionState . lensFileDict--stBuiltinModuleIds :: Lens' TCState BuiltinModuleIds-stBuiltinModuleIds = lensSessionState . lensBuiltinModuleIds--stPrimitiveLibDir :: Lens' TCState PrimitiveLibDir-stPrimitiveLibDir = lensSessionState . lensPrimitiveLibDir---- ** Persistent state--stLoadedFileCache :: Lens' TCState (Maybe LoadedFileCache)-stLoadedFileCache = lensPersistentState . lensLoadedFileCache . Strict.lensMaybeLazy--stTopLevelModuleNames :: Lens' TCState (BiMap RawTopLevelModuleName ModuleNameHash)-stTopLevelModuleNames = lensPersistentState . lensTopLevelModuleNames---- ** Pre scope state--stTokens :: Lens' TCState HighlightingInfo-stTokens = lensPreScopeState . lensPreTokens--stImports :: Lens' TCState Signature-stImports = lensPreScopeState . lensImports--stImportedModules :: Lens' TCState ImportedModules-stImportedModules = lensPreScopeState . lensImportedModules--stImportedModulesTransitive :: Lens' TCState ImportedModules-stImportedModulesTransitive = lensPreScopeState . lensImportedModulesTransitive--stModuleToSourceId :: Lens' TCState ModuleToSourceId-stModuleToSourceId = lensPreScopeState . lensModuleToSourceId--stModuleToSource :: Lens' TCState ModuleToSource-stModuleToSource = lensProduct stFileDict stModuleToSourceId . lensPairModuleToSource--stVisitedModules :: Lens' TCState VisitedModules-stVisitedModules = lensPreScopeState . lensVisitedModules--stScope :: Lens' TCState ScopeInfo-stScope = lensPreScopeState . lensScope--stPatternSyns :: Lens' TCState A.PatternSynDefns-stPatternSyns = lensPreScopeState . lensPatternSyns--stPatternSynImports :: Lens' TCState A.PatternSynDefns-stPatternSynImports = lensPreScopeState . lensPatternSynImports--stGeneralizedVars :: Lens' TCState (Maybe (Set QName))-stGeneralizedVars = lensPreScopeState . lensGeneralizedVars . Strict.lensMaybeLazy--instance LensPragmaOptions TCState where- lensPragmaOptions = lensPreScopeState . lensPragmaOptions--stPragmaOptions :: Lens' TCState PragmaOptions-stPragmaOptions = lensPragmaOptions--stImportedBuiltins :: Lens' TCState BuiltinThings-stImportedBuiltins = lensPreScopeState . lensImportedBuiltins--stForeignCode :: Lens' TCState BackendForeignCode-stForeignCode = lensPostScopeState . lensForeignCode--stFreshInteractionId :: Lens' TCState InteractionId-stFreshInteractionId = lensPreScopeState . lensFreshInteractionId--stImportedUserWarnings :: Lens' TCState UserWarnings-stImportedUserWarnings = lensPreScopeState . lensImportedUserWarnings--stLocalUserWarnings :: Lens' TCState UserWarnings-stLocalUserWarnings = lensPreScopeState . lensLocalUserWarnings--getUserWarnings :: ReadTCState m => m UserWarnings-getUserWarnings = do- iuw <- useR stImportedUserWarnings- luw <- useR stLocalUserWarnings- return $ iuw `Map.union` luw--stWarningOnImport :: Lens' TCState (Maybe Text)-stWarningOnImport = lensPreScopeState . lensWarningOnImport . Strict.lensMaybeLazy--stImportedPartialDefs :: Lens' TCState (Set QName)-stImportedPartialDefs = lensPreScopeState . lensImportedPartialDefs--stLibCache :: Lens' TCState LibCache-stLibCache = lensPreScopeState . lensLibCache--stImportedMetaStore :: Lens' TCState RemoteMetaStore-stImportedMetaStore = lensPreScopeState . lensImportedMetaStore--stCopiedNames :: Lens' TCState (HashMap QName QName)-stCopiedNames = lensPreScopeState . lensCopiedNames--stNameCopies :: Lens' TCState (HashMap QName (HashSet QName))-stNameCopies = lensPreScopeState . lensNameCopies--stImportedDisplayForms :: Lens' TCState DisplayForms-stImportedDisplayForms = lensPreScopeState . lensImportedDisplayForms---- ** Post scope state--stLocalPartialDefs :: Lens' TCState (Set QName)-stLocalPartialDefs = lensPostScopeState . lensLocalPartialDefs--getPartialDefs :: ReadTCState m => m (Set QName)-getPartialDefs = do- ipd <- useR stImportedPartialDefs- lpd <- useR stLocalPartialDefs- return $ ipd `Set.union` lpd--stFreshNameId :: Lens' TCState NameId-stFreshNameId = lensPostScopeState . lensFreshNameId--stFreshOpaqueId :: Lens' TCState OpaqueId-stFreshOpaqueId = lensPostScopeState . lensFreshOpaqueId--stOpaqueBlocks :: Lens' TCState (Map OpaqueId OpaqueBlock)-stOpaqueBlocks = lensPostScopeState . lensOpaqueBlocks--stOpaqueIds :: Lens' TCState (Map QName OpaqueId)-stOpaqueIds = lensPostScopeState . lensOpaqueIds--stInstanceHack :: Lens' TCState Bool-stInstanceHack = lensPostScopeState . lensInstanceHack--stSyntaxInfo :: Lens' TCState HighlightingInfo-stSyntaxInfo = lensPostScopeState . lensSyntaxInfo--stDisambiguatedNames :: Lens' TCState DisambiguatedNames-stDisambiguatedNames = lensPostScopeState . lensDisambiguatedNames--stOpenMetaStore :: Lens' TCState LocalMetaStore-stOpenMetaStore = lensPostScopeState . lensOpenMetaStore--stSolvedMetaStore :: Lens' TCState LocalMetaStore-stSolvedMetaStore = lensPostScopeState . lensSolvedMetaStore--stInteractionPoints :: Lens' TCState InteractionPoints-stInteractionPoints = lensPostScopeState . lensInteractionPoints--stAwakeConstraints :: Lens' TCState Constraints-stAwakeConstraints = lensPostScopeState . lensAwakeConstraints--stSleepingConstraints :: Lens' TCState Constraints-stSleepingConstraints = lensPostScopeState . lensSleepingConstraints--stDirty :: Lens' TCState Bool-stDirty = lensPostScopeState . lensDirty--stOccursCheckDefs :: Lens' TCState (Set QName)-stOccursCheckDefs = lensPostScopeState . lensOccursCheckDefs--stSignature :: Lens' TCState Signature-stSignature = lensPostScopeState . lensSignature--stRewriteRules :: Lens' TCState RewriteRuleMap-stRewriteRules = stSignature . sigRewriteRules--stModuleCheckpoints :: Lens' TCState (Map ModuleName CheckpointId)-stModuleCheckpoints = lensPostScopeState . lensModuleCheckpoints--stImportsDisplayForms :: Lens' TCState DisplayForms-stImportsDisplayForms = lensPostScopeState . lensImportsDisplayForms---- | Note that the lens is \"strict\".--stCurrentModule ::- Lens' TCState (Maybe (ModuleName, TopLevelModuleName))-stCurrentModule f s =- f (stPostCurrentModule (stPostScopeState s)) <&>- \x -> s {stPostScopeState =- (stPostScopeState s)- {stPostCurrentModule = case x of- Nothing -> Nothing- Just (!m, !top) -> Just (m, top)}}---- TODO: turn this into a composition of shallow lenses---- lensCurrentModule :: Lens' PostScopeState (Maybe (ModuleName, TopLevelModuleName))--- lensCurrentModule f s = f (stPostCurrentModule s) <&> \ x -> s { stPostCurrentModule = x }---- -- | Note that the lens is \"strict\".---- stCurrentModule :: Lens' TCState (Maybe (ModuleName, TopLevelModuleName))--- stCurrentModule = lensPostScopeState . lensCurrentModule . fmap (fmap \ (!m, !top) -> (m, top))--stInstanceDefs :: Lens' TCState TempInstanceTable-stInstanceDefs f s =- f ( s ^. stSignature . sigInstances- , stPostPendingInstances (stPostScopeState s)- )- <&> \(t, x) ->- set (stSignature . sigInstances) t- (s { stPostScopeState = (stPostScopeState s) { stPostPendingInstances = x }})--stTemporaryInstances :: Lens' TCState (Set QName)-stTemporaryInstances = lensPostScopeState . lensTemporaryInstances--stConcreteNames :: Lens' TCState ConcreteNames-stConcreteNames = lensPostScopeState . lensConcreteNames--stUsedNames :: Lens' TCState UsedNames-stUsedNames = lensPostScopeState . lensUsedNames--stShadowingNames :: Lens' TCState ShadowingNames-stShadowingNames = lensPostScopeState . lensShadowingNames--stStatistics :: Lens' TCState Statistics-stStatistics = lensPostScopeState . lensStatistics--stTCWarnings :: Lens' TCState (Set TCWarning)-stTCWarnings = lensPostScopeState . lensTCWarnings--stMutualBlocks :: Lens' TCState MutualBlocks-stMutualBlocks = lensPostScopeState . lensMutualBlocks--stLocalBuiltins :: Lens' TCState BuiltinThings-stLocalBuiltins = lensPostScopeState . lensLocalBuiltins--stFreshMetaId :: Lens' TCState MetaId-stFreshMetaId = lensPostScopeState . lensFreshMetaId--stFreshMutualId :: Lens' TCState MutualId-stFreshMutualId = lensPostScopeState . lensFreshMutualId--stFreshProblemId :: Lens' TCState ProblemId-stFreshProblemId = lensPostScopeState . lensFreshProblemId--stFreshCheckpointId :: Lens' TCState CheckpointId-stFreshCheckpointId = lensPostScopeState . lensFreshCheckpointId--stFreshInt :: Lens' TCState Int-stFreshInt = lensPostScopeState . lensFreshInt---- | use @areWeCaching@ from the Caching module instead.-stAreWeCaching :: Lens' TCState Bool-stAreWeCaching = lensPostScopeState . lensAreWeCaching--stPostponeInstanceSearch :: Lens' TCState Bool-stPostponeInstanceSearch = lensPostScopeState . lensPostponeInstanceSearch--stConsideringInstance :: Lens' TCState Bool-stConsideringInstance = lensPostScopeState . lensConsideringInstance--stInstantiateBlocking :: Lens' TCState Bool-stInstantiateBlocking = lensPostScopeState . lensInstantiateBlocking--stInstanceTree :: Lens' TCState (DiscrimTree QName)-stInstanceTree = stSignature . sigInstances . itableTree--stBuiltinThings :: TCState -> BuiltinThings-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' TCState i- nextFresh' :: i -> i- nextFresh' = succ--{-# INLINE nextFresh #-}-nextFresh :: HasFresh i => TCState -> (i, TCState)-nextFresh s =- let !c = s ^. freshLens- !next = set freshLens (nextFresh' c) s- in (c, next)--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 (ExceptT e m)-instance MonadFresh i m => MonadFresh i (MaybeT m)-instance MonadFresh i m => MonadFresh i (ReaderT r m)-instance MonadFresh i m => MonadFresh i (StateT s m)-instance (MonadFresh i m, Monoid w) => MonadFresh i (WriterT w 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- {-# INLINE fresh #-}--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 OpaqueId where- freshLens = stFreshOpaqueId--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_--instance FreshName Name where- freshName_ (Name _ con can bs fix rn) = do- i <- fresh- pure $ Name i con can bs fix rn-------------------------------------------------------------------------------- * 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---- | The concrete names get lost in case of an exception.-instance MonadStConcreteNames m => MonadStConcreteNames (ExceptT e m) where- runStConcreteNames m = ExceptT $ runStConcreteNames $ StateT $ \ ns -> do- runExceptT (runStateT m ns) <&> \case- Left e -> (Left e, mempty)- Right (x, ns') -> (Right x, ns')--instance MonadStConcreteNames m => MonadStConcreteNames (IdentityT m) where- runStConcreteNames m = IdentityT $ runStConcreteNames $ StateT $ runIdentityT . runStateT m--instance MonadStConcreteNames m => MonadStConcreteNames (MaybeT m) where- runStConcreteNames m = MaybeT $ runStConcreteNames $ StateT $ \ ns -> do- runMaybeT (runStateT m ns) <&> \case- Nothing -> (Nothing, mempty)- Just (x, ns') -> (Just x, ns')--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')--instance (MonadStConcreteNames m, Monoid w) => MonadStConcreteNames (WriterT w m) where- runStConcreteNames m = WriterT $ runStConcreteNames $ StateT $ \ ns -> do- ((x,ns'),w) <- runWriterT $ runStateT m ns- return ((x,w),ns')-------------------------------------------------------------------------------- * File handling------------------------------------------------------------------------------instance GetFileId FileDictWithBuiltins where- getFileId = getFileId . fileDictBuilder--instance GetIdFile FileDictWithBuiltins where- getIdFile = getIdFile . fileDictBuilder---- | Get the file name of a 'SourceFile'.--srcFilePath :: MonadFileId m => SourceFile -> m AbsolutePath-srcFilePath (SourceFile fi) = fileFromId fi---- | Get make a 'SourceFile' from a file name.-srcFromPath :: MonadFileId m => AbsolutePath -> m SourceFile-srcFromPath p = SourceFile <$> idFromFile p--instance Pretty ModuleToSource where- pretty (ModuleToSource dict mods) = vcat- [ hsep [ "-", pretty m, "->", pretty $ getIdFile dict i ]- | (m, SourceFile i) <- Map.toList mods- ]---- | Lookup the path of a top level module name, which must be a known one.--topLevelModuleFilePath :: ModuleToSource -> TopLevelModuleName -> AbsolutePath-topLevelModuleFilePath (ModuleToSource dict m2s) m =- getIdFile dict $ srcFileId $ Map.findWithDefault __IMPOSSIBLE__ m m2s-------------------------------------------------------------------------------- * 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 :: Set 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)---- | Foreign code fragments are stored in reversed order to support efficient appending:--- head points to the latest pragma in module.-newtype ForeignCodeStack = ForeignCodeStack- { getForeignCodeStack :: [ForeignCode]- } deriving (Show, Generic, NFData)--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 :: UserWarnings- -- ^ User warnings for imported identifiers- , iImportWarning :: Maybe Text- -- ^ Whether this module should raise a warning when imported- , iBuiltin :: BuiltinThings' (PrimitiveId, QName)- , iForeignCode :: Map BackendName ForeignCodeStack- , 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 :: Set TCWarning- , iPartialDefs :: Set QName- , iOpaqueBlocks :: Map OpaqueId OpaqueBlock- , iOpaqueNames :: Map QName OpaqueId- }- 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 oblocks onames) =-- 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- , "opaque blocks:" <+> pretty oblocks- , "opaque names" <+> pretty onames- ]---- | 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' Interface Signature-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 b a | b -> a where- lensClosure :: Lens' b (Closure a)--instance LensClosure (Closure a) a where- lensClosure = id--instance LensTCEnv (Closure a) where- lensTCEnv f cl = (f $! clEnv cl) <&> \ env -> cl { clEnv = env }--{-# SPECIALIZE buildClosure :: a -> TCM (Closure a) #-}-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 Range MetaId (Maybe [Candidate])- -- ^ the second argument is the instance argument and the third one is dhe list of candidates- -- (or Nothing if we haven’t determined the list of candidates yet)- | ResolveInstanceHead QName- -- ^ Resolve the head symbol of the type that the given instance targets- | CheckFunDef 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)---- It's important to have a proper range for constraints that can remain unsolved--- without a corresponding unsolved to point to the location of the constraint.-instance HasRange Constraint where- getRange (IsEmpty r t) = r- getRange (FindInstance r _ _) = r- getRange ValueCmp{} = noRange- getRange ElimCmp{} = noRange- getRange SortCmp{} = noRange- getRange LevelCmp{} = noRange- getRange UnBlock{} = noRange- getRange ValueCmpOnFace{} = noRange- getRange HasBiggerSort{} = noRange- getRange HasPTSRule{} = noRange- getRange CheckDataSort{} = noRange- getRange CheckMetaInst{} = noRange- getRange CheckType{} = noRange- getRange CheckSizeLtSat{} = noRange- getRange CheckFunDef{} = noRange- getRange ResolveInstanceHead{} = noRange- getRange UnquoteTactic{} = noRange- getRange CheckLockedVars{} = noRange- getRange UsableAtModality{} = noRange--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- ResolveInstanceHead q -> mempty- 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- ResolveInstanceHead q -> 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--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)---- | Solution status of meta.-data MetaInstantiation- = InstV Instantiation -- ^ Solved by 'Instantiation'.- | OpenMeta MetaKind -- ^ Unsolved (open to solutions).- | BlockedConst Term -- ^ Solved, but solution blocked by unsolved constraints.- | PostponedTypeCheckingProblem (Closure TypeCheckingProblem)- -- ^ Meta stands for value of the expression that is still to be type checked.- 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 A.Expr [NamedArg A.Expr] Type Type (ArgsCheckState CheckedTarget -> TCM Term)- | CheckProjAppToKnownPrincipalArg Comparison A.Expr ProjOrigin (List1 QName) A.Expr 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'.- | DisambiguateConstructor ConstructorDisambiguationData (ConHead -> TCM Term)- -- ^ A stuck constructor disambiguation with the bits to retry it on and the success continuation.- | DoQuoteTerm Comparison Term Type -- ^ Quote the given term and check type against `Term`- deriving Generic---- | Information we have constructored in the middle of disambiguating a constructor.-data ConstructorDisambiguationData = ConstructorDisambiguationData- -- bcd for blocked constructor disambiguation- { bcdConName :: QName- -- ^ One of the eligible ambiguous names (for error messages).- , bcdCandidates :: List1 (QName, Type, ConHead)- -- ^ The possible candidates for disambiguation- , bcdArguments :: A.Args- -- ^ The arguments given to the constructor.- , bcdType :: Type- -- ^ The type of the constructor application- } deriving Generic--instance Pretty MetaInstantiation where- pretty = \case- OpenMeta UnificationMeta -> "Open"- OpenMeta InstanceMeta -> "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)--instance LensModalPolarity MetaInfo where- getModalPolarity = getModalPolarity . getModality- mapModalPolarity f = mapModality (mapModalPolarity f)---- | Append an 'ArgName' to a 'MetaNameSuggestion', for computing the--- name suggestions of eta-expansion metas. If the 'MetaNameSuggestion'--- is empty or an underscore, the field name is taken as the suggestion.-suffixNameSuggestion :: MetaNameSuggestion -> ArgName -> MetaNameSuggestion-suffixNameSuggestion "_" field = field-suffixNameSuggestion "" field = field-suffixNameSuggestion record field = record ++ "." ++ field--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--{-# SPECIALIZE Map.insert :: MetaId -> v -> Map MetaId v -> Map MetaId v #-}-{-# SPECIALIZE Map.lookup :: MetaId -> Map MetaId v -> Maybe v #-}---- | 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)--instance LensModalPolarity RemoteMetaVariable where- mapModalPolarity f = mapModality (mapModalPolarity 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' MetaVariable Frozen-metaFrozen f mv = f (mvFrozen mv) <&> \ x -> mv { mvFrozen = x }--_mvInfo :: Lens' MetaVariable MetaInfo-_mvInfo f mv = (f $! mvInfo mv) <&> \ mi -> mv { mvInfo = mi }---- Lenses onto Closure Range--instance LensClosure MetaInfo Range where- lensClosure f mi = (f $! miClosRange mi) <&> \ cl -> mi { miClosRange = cl }--instance LensClosure MetaVariable Range 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--instance LensIsOpaque TCEnv where- lensIsOpaque f env =- (f $! case envCurrentOpaqueId env of { Just x -> OpaqueDef x ; Nothing -> TransparentDef })- <&> \case { OpaqueDef x -> env { envCurrentOpaqueId = Just x }- ; TransparentDef -> env { envCurrentOpaqueId = Nothing }- }-------------------------------------------------------------------------------- ** 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.- , ipBoundary :: IPBoundary- }- 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)--newtype IPBoundary' t = IPBoundary- { getBoundary :: Map (IntMap Bool) t- }- 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.- }- | 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.- , _sigInstances :: InstanceTable- }- deriving (Show, Generic)--instance Null Signature where- empty = Sig empty empty empty empty- null (Sig a b c d) = null a && null b && null c && null d--sigSections :: Lens' Signature Sections-sigSections f s =- f (_sigSections s) <&>- \x -> s {_sigSections = x}--sigDefinitions :: Lens' Signature Definitions-sigDefinitions f s =- f (_sigDefinitions s) <&>- \x -> s {_sigDefinitions = x}--sigInstances :: Lens' Signature InstanceTable-sigInstances f s = f (_sigInstances s) <&> \x -> s {_sigInstances = x}--sigRewriteRules :: Lens' Signature RewriteRuleMap-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]---- 2023-21-30, András: see issue 6927-#if __GLASGOW_HASKELL__ >= 900-{-# SPECIALIZE HMap.insert :: QName -> v -> HashMap QName v -> HashMap QName v #-}-#endif-{-# SPECIALIZE HMap.lookup :: QName -> HashMap QName v -> Maybe v #-}--newtype Section = Section { _secTelescope :: Telescope }- deriving (Show, NFData)--instance Pretty Section where- pretty = pretty . _secTelescope--secTelescope :: Lens' Section Telescope-secTelescope f s =- f (_secTelescope s) <&>- \x -> s {_secTelescope = x}--emptySignature :: Signature-emptySignature = Sig Map.empty HMap.empty HMap.empty mempty---- | 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 (List1 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 Elims- -- ^ @.(v es)@. See 'DTerm''.- | DTerm' Term Elims- -- ^ @v es@.- -- This is a frozen elimination that is not always safe to run,- -- because display forms may be ill-typed.- -- (See issue #6476.)- deriving (Show, Generic)--pattern DDot :: Term -> DisplayTerm-pattern DDot v = DDot' v []--pattern DTerm :: Term -> DisplayTerm-pattern DTerm v = DTerm' v []--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 es) = freeVars' (v, es)- freeVars' (DTerm' v es) = freeVars' (v, es)--instance Pretty DisplayTerm where- prettyPrec p v =- case v of- DTerm v -> prettyPrec p v- DTerm' v es -> prettyPrec 9 v `pApp` es- DDot v -> "." <> prettyPrec 10 v- DDot' v es -> "." <> parens (prettyPrec 9 v `pAp` es)- 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 $ fmap (\ w -> "|" <+> pretty w) ws- ])- `pApp` es- where- pApp :: Pretty el => Doc -> [el] -> Doc- pApp d els = mparens (not (null els) && p > 9) $ pAp d els- pAp :: Pretty el => Doc -> [el] -> Doc- pAp d els = 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]--type instance TypeOf NLPat = Type-type instance TypeOf [Elim' NLPat] = (Type, Elims -> Term)--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- = PUniv Univ NLPat- | PInf Univ Integer- | PSizeUniv- | PLockUniv- | PLevelUniv- | PIntervalUniv- deriving (Show, Generic)--pattern PType, PProp, PSSet :: NLPat -> NLPSort-pattern PType p = PUniv UType p-pattern PProp p = PUniv UProp p-pattern PSSet p = PUniv USSet p--{-# COMPLETE- PType, PSSet, PProp, PInf,- PSizeUniv, PLockUniv, PLevelUniv, PIntervalUniv #-}--instance TermLike NLPSort where- traverseTermM f = \case- PUniv u p -> PUniv u <$> traverseTermM f p- s@PInf{} -> return s- s@PSizeUniv{} -> return s- s@PLockUniv{} -> return s- s@PLevelUniv{} -> return s- s@PIntervalUniv{} -> return s-- foldTerm f t = case t of- PUniv _ p -> foldTerm f p- s@PInf{} -> mempty- s@PSizeUniv{} -> mempty- s@PLockUniv{} -> mempty- s@PLevelUniv{} -> 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?- , rewTopModule :: TopLevelModuleName- -- ^ In which file is this rewrite rule defined?- -- This information is used to eliminate rewrite rules that happen to be in 'stImports'- -- but are not actually transitively imported.-- -- See issue #4343 (Andreas, 2025-06-05).- }- deriving (Show, Generic)---- | Information about an @instance@ definition.-data InstanceInfo = InstanceInfo- { instanceClass :: QName -- ^ Name of the "class" this is an instance for- , instanceOverlap :: OverlapMode -- ^ Does this instance have a specified overlap mode?- }- 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- , 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 InstanceInfo- -- ^ @Just q@ when this definition is an instance.- , 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-instance LensModalPolarity 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' Definition Defn-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 = []- , 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- }--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--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 == Left _@.- , 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?- | FunFirstOrder- -- ^ Is this function @INJECTIVE_FOR_INFERENCE@?- -- Indicates whether the first-order shortcut should be applied to the definition.- | FunErasure- -- ^ Was @--erasure@ in effect when the function was defined?- -- (This can affect the type of a projection.)- | FunAbstract- -- ^ Is the function abstract?- | FunProj- -- ^ Is this function a descendant of a field (typically, a projection)?- deriving (Eq, Ord, Enum, Show, Generic, Ix, Bounded)--instance SmallSetElement FunctionFlag-instance KillRange (SmallSet FunctionFlag) where killRange = id--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 @variable@ block).- NumGeneralizableArgs- -- ^ For a generalized variable, shows how many arguments should be generalised.- | 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)--{-# COMPLETE- Axiom, DataOrRecSig, GeneralizableVar, AbstractDefn,- Function, Datatype, Record, Constructor, Primitive, PrimitiveSort #-}--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).- , _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 :: SmallSet FunctionFlag- -- ^ Various boolean flags pertaining to the function definition, see '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?- , _funOpaque :: IsOpaque- -- ^ Is this function opaque? If so, and we're not in an opaque- -- block that includes this function('s name), it will be treated- -- abstractly.- } deriving (Show, Generic)--pattern Function- :: [Clause]- -> Maybe CompiledClauses- -> Maybe SplitTree- -> Maybe Compiled- -> [Clause]- -> FunctionInverse- -> Maybe [QName]- -> Either ProjectionLikenessMissing Projection- -> SmallSet FunctionFlag- -> Maybe Bool- -> Maybe ExtLamInfo- -> Maybe QName- -> Maybe QName- -> IsOpaque- -> Defn-pattern Function- { funClauses- , funCompiled- , funSplitTree- , funTreeless- , funCovering- , funInv- , funMutual- , funProjection- , funFlags- , funTerminates- , funExtLam- , funWith- , funIsKanOp- , funOpaque- } = FunctionDefn (FunctionData- funClauses- funCompiled- funSplitTree- funTreeless- funCovering- funInv- funMutual- funProjection- funFlags- funTerminates- funExtLam- funWith- funIsKanOp- funOpaque- )--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- , _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@.- , _conErasure :: !Bool- -- ^ Was @--erasure@ in effect when the constructor was defined?- -- (This can affect the constructor's type.)- , _conInline :: !Bool- -- ^ Shall we translate the constructor on the root of the rhs into copattern matching on the lhs?- -- Activated by INLINE pragma.- } deriving (Show, Generic)--pattern Constructor- :: Int- -> Int- -> ConHead- -> QName- -> IsAbstract- -> CompKit- -> Maybe [QName]- -> [IsForced]- -> Maybe [Bool]- -> Bool- -> Bool- -> Defn-pattern Constructor- { conPars- , conArity- , conSrcCon- , conData- , conAbstr- , conComp- , conProj- , conForced- , conErased- , conErasure- , conInline- } = ConstructorDefn (ConstructorData- conPars- conArity- conSrcCon- conData- conAbstr- conComp- conProj- conForced- conErased- conErasure- conInline- )--data PrimitiveData = PrimitiveData- { _primAbstr :: IsAbstract- , _primName :: PrimitiveId- , _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.- , _primOpaque :: IsOpaque- -- ^ Primitives can also live in opaque blocks.- } deriving (Show, Generic)--pattern Primitive- :: IsAbstract- -> PrimitiveId- -> [Clause]- -> FunctionInverse- -> Maybe CompiledClauses- -> IsOpaque- -> Defn-pattern Primitive- { primAbstr- , primName- , primClauses- , primInv- , primCompiled- , primOpaque- } = PrimitiveDefn (PrimitiveData- primAbstr- primName- primClauses- primInv- primCompiled- primOpaque- )--data PrimitiveSortData = PrimitiveSortData- { _primSortName :: BuiltinSort- , _primSortSort :: Sort- } deriving (Show, Generic)--pattern PrimitiveSort- :: BuiltinSort- -> Sort- -> Defn-pattern PrimitiveSort- { primSortName- , primSortSort- } = PrimitiveSortDefn (PrimitiveSortData- primSortName- primSortSort- )---- TODO: lenses for all Defn variants--lensFunction :: Lens' Defn FunctionData-lensFunction f = \case- FunctionDefn d -> FunctionDefn <$> f d- _ -> __IMPOSSIBLE__--lensConstructor :: Lens' Defn ConstructorData-lensConstructor f = \case- ConstructorDefn d -> ConstructorDefn <$> f d- _ -> __IMPOSSIBLE__--lensRecord :: Lens' Defn RecordData-lensRecord f = \case- RecordDefn d -> RecordDefn <$> f d- _ -> __IMPOSSIBLE__---- Lenses for Record--lensRecTel :: Lens' RecordData Telescope-lensRecTel f r =- f (_recTel r) <&> \ tel -> r { _recTel = tel }--lensRecEta :: Lens' RecordData EtaEquality-lensRecEta f r =- f (_recEtaEquality' r) <&> \ eta -> r { _recEtaEquality' = eta }---- 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- funProjection- funFlags- funTerminates- _funExtLam- funWith- funIsKanOp- funOpaque- ) =- "Function {" <?> vcat- [ "funClauses =" <?> vcat (map pretty funClauses)- , "funCompiled =" <?> pretty funCompiled- , "funSplitTree =" <?> pretty funSplitTree- , "funTreeless =" <?> pretty funTreeless- , "funInv =" <?> pretty funInv- , "funMutual =" <?> pshow funMutual- , "funProjection =" <?> pretty funProjection- , "funFlags =" <?> pshow funFlags- , "funTerminates =" <?> pshow funTerminates- , "funWith =" <?> pretty funWith- , "funIsKanOp =" <?> pretty funIsKanOp- , "funOpaque =" <?> pshow funOpaque- ] <?> "}"--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- _conComp- _conProj- _conForced- conErased- conErasure- conInline- ) =- "Constructor {" <?> vcat- [ "conPars =" <?> pshow conPars- , "conArity =" <?> pshow conArity- , "conSrcCon =" <?> pretty conSrcCon- , "conData =" <?> pretty conData- , "conAbstr =" <?> pshow conAbstr- , "conErased =" <?> pshow conErased- , "conErasure =" <?> pshow conErasure- , "conInline =" <?> pshow conInline- ] <?> "}"--instance Pretty PrimitiveData where- pretty (PrimitiveData- primAbstr- primName- primClauses- _primInv- primCompiled- primOpaque- ) =- "Primitive {" <?> vcat- [ "primAbstr =" <?> pshow primAbstr- , "primName =" <?> pshow primName- , "primClauses =" <?> pshow primClauses- , "primCompiled =" <?> pshow primCompiled- , "primOpaque =" <?> pshow primOpaque- ] <?> "}"--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 (RecordDefn d) = recRecursive_ d-recRecursive _ = __IMPOSSIBLE__--recRecursive_ :: RecordData -> Bool-recRecursive_ RecordData{ _recMutual = Just qs } = not $ null qs-recRecursive_ _ = __IMPOSSIBLE__--recEtaEquality :: Defn -> HasEta-recEtaEquality = theEtaEquality . recEtaEquality'--_recEtaEquality :: RecordData -> HasEta-_recEtaEquality = theEtaEquality . _recEtaEquality'---- | A template for creating 'Function' definitions, with sensible--- defaults.-emptyFunctionData :: HasOptions m => m FunctionData-emptyFunctionData = emptyFunctionData_ . optErasure <$> pragmaOptions--emptyFunctionData_ :: Bool -> FunctionData-emptyFunctionData_ erasure = FunctionData- { _funClauses = []- , _funCompiled = Nothing- , _funSplitTree = Nothing- , _funTreeless = Nothing- , _funInv = NotInjective- , _funMutual = Nothing- , _funProjection = Left MaybeProjection- , _funFlags = SmallSet.fromList [ FunErasure | erasure ]- , _funTerminates = Nothing- , _funExtLam = Nothing- , _funWith = Nothing- , _funCovering = []- , _funIsKanOp = Nothing- , _funOpaque = TransparentDef- }--emptyFunction :: HasOptions m => m Defn-emptyFunction = FunctionDefn <$> emptyFunctionData--emptyFunction_ :: Bool -> Defn-emptyFunction_ = FunctionDefn . emptyFunctionData_--funFlag_ :: FunctionFlag -> Lens' FunctionData Bool-funFlag_ flag f def@FunctionData{ _funFlags = flags } =- f (SmallSet.member flag flags) <&>- \ b -> def{ _funFlags = (if b then SmallSet.insert else SmallSet.delete) flag flags }--funFlag :: FunctionFlag -> Lens' Defn Bool-funFlag flag f = \case- FunctionDefn d -> FunctionDefn <$> funFlag_ flag f d- def -> f False $> def--funStatic, funInline, funMacro :: Lens' Defn Bool-funStatic = funFlag FunStatic-funInline = funFlag FunInline-funMacro = funFlag FunMacro--funMacro_ :: Lens' FunctionData Bool-funMacro_ = funFlag_ FunMacro---- | Toggle the 'FunFirstOrder' flag.-funFirstOrder :: Lens' Defn Bool-funFirstOrder = funFlag FunFirstOrder---- | Toggle the 'FunErasure' flag.-funErasure :: Lens' Defn Bool-funErasure = funFlag FunErasure---- | Toggle the 'FunAbstract' flag.-funAbstract :: Lens' Defn Bool-funAbstract = funFlag FunAbstract---- | Toggle the 'FunAbstract' flag.-funAbstr :: Lens' Defn IsAbstract-funAbstr = funAbstract . iso fromBool toBool---- | Toggle the 'FunAbstract' flag.-funAbstract_ :: Lens' FunctionData Bool-funAbstract_ = funFlag_ FunAbstract---- | Toggle the 'FunAbstract' flag.-funAbstr_ :: Lens' FunctionData IsAbstract-funAbstr_ = funAbstract_ . iso fromBool toBool---- | Toggle the 'FunProj' flag.-funProj :: Lens' Defn Bool-funProj = funFlag FunProj---- | Toggle the 'FunProj' flag.-funProj_ :: Lens' FunctionData Bool-funProj_ = funFlag_ FunProj--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--isExtendedLambda :: Defn -> Bool-isExtendedLambda def =- case def of- Function { funExtLam = Just{} } -> True- _ -> False--isWithFunction :: Defn -> Bool-isWithFunction def =- case def of- Function { funWith = Just{} } -> 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 -> ReduceM b) ->- (a' -> ReduceM (Reduced b b')) -> ReduceM (Reduced b b')-redBind ma f k = do- r <- ma- case r of- NoReduction x -> 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)--instance SmallSet.SmallSetElement AllowedReduction--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--toReduceDefs :: (Bool, [QName]) -> ReduceDefs-toReduceDefs (True, ns) = OnlyReduceDefs (Data.Set.fromList ns)-toReduceDefs (False, ns) = DontReduceDefs (Data.Set.fromList ns)--fromReduceDefs :: ReduceDefs -> (Bool, [QName])-fromReduceDefs (OnlyReduceDefs ns) = (True, toList ns)-fromReduceDefs (DontReduceDefs ns) = (False, toList ns)--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- , primFunArgOccurrences :: [Occurrence]- -- ^ See 'defArgOccurrences'.- , 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---- | 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 def = case theDef def of- AxiomDefn _ -> ConcreteDef- DataOrRecSigDefn _ -> ConcreteDef- GeneralizableVar _ -> ConcreteDef- AbstractDefn _ -> AbstractDef- FunctionDefn d -> d ^. funAbstr_- DatatypeDefn d -> _dataAbstr d- RecordDefn d -> _recAbstr d- ConstructorDefn d -> _conAbstr d- PrimitiveDefn d -> _primAbstr d- PrimitiveSortDefn _ -> ConcreteDef--defOpaque :: Definition -> IsOpaque-defOpaque d = case theDef d of- -- These two can be opaque:- Function{funOpaque=o} -> o- Primitive{primOpaque=o} -> o-- -- Doesn't matter whether or not it's opaque:- Axiom{} -> TransparentDef- -- Concreteness is orthogonal to opacity:- AbstractDefn{} -> TransparentDef-- -- None of these are supported in opaque blocks:- DataOrRecSig{} -> TransparentDef- GeneralizableVar{} -> TransparentDef- Datatype{} -> TransparentDef- Record{} -> TransparentDef- Constructor{} -> TransparentDef- PrimitiveSort{} -> TransparentDef--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 = MutualId Word32- deriving (Eq, Ord, Show, Num, Enum, NFData)--instance Pretty MutualId where- pretty (MutualId i) = pretty i---- | Map 'MutualId' to 'MutualBlock'.-type MutualBlocks = IntMap MutualBlock---- | A mutual block of names in the signature.-data MutualBlock = MutualBlock- { mutualInfo :: MutualInfo- -- ^ The original info of the mutual block.- , mutualNames :: Set QName- } deriving (Show, Eq, Generic)--instance Null MutualBlock where- empty = MutualBlock empty empty-------------------------------------------------------------------------------- ** 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 A.Expr [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- | CheckConArgFitsIn QName Bool 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- | CheckModuleParameters ModuleName A.Telescope- | CheckWithFunctionType Type- | CheckSectionApplication Range Erased 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 CheckConArgFitsIn{} = "CheckConArgFitsIn"- pretty CheckFunDefCall{} = "CheckFunDefCall"- pretty CheckPragma{} = "CheckPragma"- pretty CheckPrimitive{} = "CheckPrimitive"- pretty CheckModuleParameters{} = "CheckModuleParameters"- 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 fun _ _ _) = getRange fun- getRange (CheckMetaSolution r _ _ _) = r- getRange (CheckTargetType r _ _) = r- getRange (CheckDataDef i _ _ _) = getRange i- getRange (CheckRecDef i _ _ _) = getRange i- getRange (CheckConstructor _ _ _ c) = getRange c- getRange (CheckConArgFitsIn c _ _ _) = getRange c- getRange (CheckFunDefCall i _ _ _) = getRange i- getRange (CheckPragma r _) = r- getRange (CheckPrimitive i _ _) = getRange i- getRange (CheckModuleParameters _ tel) = getRange tel- 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-------------------------------------------------------------------------------- | Records information about the instances in the signature. Does not--- deal with local instances.-data InstanceTable = InstanceTable- { _itableTree :: DiscrimTree QName- -- ^ The actual discrimination tree for looking up instances with-- , _itableCounts :: Map QName Int- -- ^ For profiling, we store the number of instances on a per-class- -- basis. This lets us compare the result from the discrimination- -- tree with all the instances in scope, thus informing us how many- -- validity checks were skipped.- }- deriving (Show, Generic)--instance Semigroup InstanceTable where- InstanceTable t i <> InstanceTable t' i' = InstanceTable- { _itableTree = t <> t'- , _itableCounts = Map.unionWith (+) i i'- }--instance Monoid InstanceTable where- mempty = InstanceTable mempty mempty--instance Null InstanceTable where- empty = mempty- null (InstanceTable a b) = null a && null b--itableTree :: Lens' InstanceTable (DiscrimTree QName)-itableTree f s = f (_itableTree s) <&> \x -> s { _itableTree = x }--itableCounts :: Lens' InstanceTable (Map QName Int)-itableCounts f s = f (_itableCounts s) <&> \x -> s { _itableCounts = x }---- | 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 BuiltinSort- = SortUniv Univ- | SortOmega Univ- | SortIntervalUniv- | SortLevelUniv- deriving (Show, Eq, Generic)--pattern SortProp, SortSet, SortStrictSet, SortPropOmega, SortSetOmega, SortStrictSetOmega :: BuiltinSort-pattern SortProp = SortUniv UProp-pattern SortSet = SortUniv UType-pattern SortStrictSet = SortUniv USSet-pattern SortPropOmega = SortOmega UProp-pattern SortSetOmega = SortOmega UType-pattern SortStrictSetOmega = SortOmega USSet--{-# COMPLETE- SortProp, SortSet, SortStrictSet,- SortPropOmega, SortSetOmega, SortStrictSetOmega,- SortIntervalUniv, SortLevelUniv #-}--data BuiltinDescriptor- = BuiltinData (TCM Type) [BuiltinId]- | BuiltinDataCons (TCM Type)- | BuiltinPrim PrimitiveId (Term -> TCM ())- | BuiltinSort BuiltinSort- | 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 :: BuiltinId- , builtinDesc :: BuiltinDescriptor }--type BuiltinThings = BuiltinThings' PrimFun-type BuiltinThings' pf = Map SomeBuiltin (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-------------------------------------------------------------------------------- | @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 FileId- -- ^ 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 :: C.WhereClause_- -- ^ 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- , envUnquoteProblem :: Maybe ProblemId- -- ^ If inside a `runUnquoteM` call, stores the top-level problem id assigned to the- -- invokation. We use this to decide which instance constraints originate from the- -- current call and which come from the outside, for the purpose of a- -- `solveInstanceConstraints` inside `noConstraints` only failing for local instance- -- constraints.- , envAbstractMode :: AbstractMode- -- ^ When checking the typesignature of a public definition- -- or the body of a non-abstract definition this is true.- -- To prevent information about abstract things leaking- -- outside the module.- , envRelevance :: Relevance- -- ^ Are we checking an irrelevant argument? (=@Irrelevant@)- -- Then top-level irrelevant declarations are enabled.- -- Other value: @Relevant@, then only relevant decls. are available.- , envQuantity :: Quantity- -- ^ Are we checking a runtime-irrelevant thing? (='Quantity0')- -- Then runtime-irrelevant things are usable.- , envHardCompileTimeMode :: Bool- -- ^ Is the \"hard\" compile-time mode enabled? In- -- this mode the quantity component of the environment- -- is always zero, and every new definition is treated- -- as erased.- , 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.- , envFoldLetBindings :: Bool- -- ^ Fold let-bindings when printing terms (default: True)- , 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'.- , envCurrentOpaqueId :: !(Maybe OpaqueId)- -- ^ Unique identifier of the opaque block we are- -- currently under, if any. Used by the scope checker- -- (to associate definitions to blocks), and by the type- -- checker (for unfolding control).- , envTermCheckReducing :: Bool- -- ^ Are we currently trying to reduce away function calls using- -- non-recursive clauses during termination checking?- }- 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 = C.NoWhere_- , envActiveProblems = Set.empty- , envUnquoteProblem = Nothing- , 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').- , envRelevance = unitRelevance- , envQuantity = unitQuantity- , envHardCompileTimeMode = False- , envSplitOnStrict = False- , envDisplayFormsEnabled = True- , envFoldLetBindings = 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- , envCurrentOpaqueId = Nothing- , envTermCheckReducing = False- }--class LensTCEnv a where- lensTCEnv :: Lens' a TCEnv--instance LensTCEnv TCEnv where- lensTCEnv = id--data UnquoteFlags = UnquoteFlags- { _unquoteNormalise :: Bool }- deriving Generic--defaultUnquoteFlags :: UnquoteFlags-defaultUnquoteFlags = UnquoteFlags- { _unquoteNormalise = False }--unquoteNormalise :: Lens' UnquoteFlags Bool-unquoteNormalise f e = f (_unquoteNormalise e) <&> \ x -> e { _unquoteNormalise = x }--eUnquoteNormalise :: Lens' TCEnv Bool-eUnquoteNormalise = eUnquoteFlags . unquoteNormalise---- * e-prefixed lenses---------------------------------------------------------------------------eContext :: Lens' TCEnv Context-eContext f e = f (envContext e) <&> \ x -> e { envContext = x }--eLetBindings :: Lens' TCEnv LetBindings-eLetBindings f e = f (envLetBindings e) <&> \ x -> e { envLetBindings = x }--eCurrentModule :: Lens' TCEnv ModuleName-eCurrentModule f e = f (envCurrentModule e) <&> \ x -> e { envCurrentModule = x }--eCurrentPath :: Lens' TCEnv (Maybe FileId)-eCurrentPath f e = f (envCurrentPath e) <&> \ x -> e { envCurrentPath = x }--eAnonymousModules :: Lens' TCEnv [(ModuleName, Nat)]-eAnonymousModules f e = f (envAnonymousModules e) <&> \ x -> e { envAnonymousModules = x }--eImportPath :: Lens' TCEnv [TopLevelModuleName]-eImportPath f e = f (envImportPath e) <&> \ x -> e { envImportPath = x }--eMutualBlock :: Lens' TCEnv (Maybe MutualId)-eMutualBlock f e = f (envMutualBlock e) <&> \ x -> e { envMutualBlock = x }--eTerminationCheck :: Lens' TCEnv (TerminationCheck ())-eTerminationCheck f e = f (envTerminationCheck e) <&> \ x -> e { envTerminationCheck = x }--eCoverageCheck :: Lens' TCEnv CoverageCheck-eCoverageCheck f e = f (envCoverageCheck e) <&> \ x -> e { envCoverageCheck = x }--eMakeCase :: Lens' TCEnv Bool-eMakeCase f e = f (envMakeCase e) <&> \ x -> e { envMakeCase = x }--eSolvingConstraints :: Lens' TCEnv Bool-eSolvingConstraints f e = f (envSolvingConstraints e) <&> \ x -> e { envSolvingConstraints = x }--eCheckingWhere :: Lens' TCEnv C.WhereClause_-eCheckingWhere f e = f (envCheckingWhere e) <&> \ x -> e { envCheckingWhere = x }--eWorkingOnTypes :: Lens' TCEnv Bool-eWorkingOnTypes f e = f (envWorkingOnTypes e) <&> \ x -> e { envWorkingOnTypes = x }--eAssignMetas :: Lens' TCEnv Bool-eAssignMetas f e = f (envAssignMetas e) <&> \ x -> e { envAssignMetas = x }--eActiveProblems :: Lens' TCEnv (Set ProblemId)-eActiveProblems f e = f (envActiveProblems e) <&> \ x -> e { envActiveProblems = x }--eAbstractMode :: Lens' TCEnv AbstractMode-eAbstractMode f e = f (envAbstractMode e) <&> \ x -> e { envAbstractMode = x }--eRelevance :: Lens' TCEnv Relevance-eRelevance f e = f (envRelevance e) <&> \x -> e { envRelevance = x }---- | Note that this lens does not satisfy all lens laws: If hard--- compile-time mode is enabled, then quantities other than zero are--- replaced by '__IMPOSSIBLE__'.--eQuantity :: Lens' TCEnv Quantity-eQuantity f e =- if envHardCompileTimeMode e- then f (check (envQuantity e)) <&>- \x -> e { envQuantity = check x }- else f (envQuantity e) <&> \x -> e { envQuantity = x }- where- check q- | hasQuantity0 q = q- | otherwise = __IMPOSSIBLE__--eHardCompileTimeMode :: Lens' TCEnv Bool-eHardCompileTimeMode f e = f (envHardCompileTimeMode e) <&> \x -> e { envHardCompileTimeMode = x }--eSplitOnStrict :: Lens' TCEnv Bool-eSplitOnStrict f e = f (envSplitOnStrict e) <&> \ x -> e { envSplitOnStrict = x }--eDisplayFormsEnabled :: Lens' TCEnv Bool-eDisplayFormsEnabled f e = f (envDisplayFormsEnabled e) <&> \ x -> e { envDisplayFormsEnabled = x }--eFoldLetBindings :: Lens' TCEnv Bool-eFoldLetBindings f e = f (envFoldLetBindings e) <&> \ x -> e { envFoldLetBindings = x }--eRange :: Lens' TCEnv Range-eRange f e = f (envRange e) <&> \ x -> e { envRange = x }--eHighlightingRange :: Lens' TCEnv Range-eHighlightingRange f e = f (envHighlightingRange e) <&> \ x -> e { envHighlightingRange = x }--eCall :: Lens' TCEnv (Maybe (Closure Call))-eCall f e = f (envCall e) <&> \ x -> e { envCall = x }--eHighlightingLevel :: Lens' TCEnv HighlightingLevel-eHighlightingLevel f e = f (envHighlightingLevel e) <&> \ x -> e { envHighlightingLevel = x }--eHighlightingMethod :: Lens' TCEnv HighlightingMethod-eHighlightingMethod f e = f (envHighlightingMethod e) <&> \ x -> e { envHighlightingMethod = x }--eExpandLast :: Lens' TCEnv ExpandHidden-eExpandLast f e = f (envExpandLast e) <&> \ x -> e { envExpandLast = x }--eExpandLastBool :: Lens' TCEnv Bool-eExpandLastBool f e = f (isExpandLast $ envExpandLast e) <&> \ x -> e { envExpandLast = toExpandLast x }--eAppDef :: Lens' TCEnv (Maybe QName)-eAppDef f e = f (envAppDef e) <&> \ x -> e { envAppDef = x }--eSimplification :: Lens' TCEnv Simplification-eSimplification f e = f (envSimplification e) <&> \ x -> e { envSimplification = x }--eAllowedReductions :: Lens' TCEnv AllowedReductions-eAllowedReductions f e = f (envAllowedReductions e) <&> \ x -> e { envAllowedReductions = x }--eReduceDefs :: Lens' TCEnv ReduceDefs-eReduceDefs f e = f (envReduceDefs e) <&> \ x -> e { envReduceDefs = x }--eReduceDefsPair :: Lens' TCEnv (Bool, [QName])-eReduceDefsPair f e = f (fromReduceDefs $ envReduceDefs e) <&> \ x -> e { envReduceDefs = toReduceDefs x }--eReconstructed :: Lens' TCEnv Bool-eReconstructed f e = f (envReconstructed e) <&> \ x -> e { envReconstructed = x }--eInjectivityDepth :: Lens' TCEnv Int-eInjectivityDepth f e = f (envInjectivityDepth e) <&> \ x -> e { envInjectivityDepth = x }--eCompareBlocked :: Lens' TCEnv Bool-eCompareBlocked f e = f (envCompareBlocked e) <&> \ x -> e { envCompareBlocked = x }--ePrintDomainFreePi :: Lens' TCEnv Bool-ePrintDomainFreePi f e = f (envPrintDomainFreePi e) <&> \ x -> e { envPrintDomainFreePi = x }--ePrintMetasBare :: Lens' TCEnv Bool-ePrintMetasBare f e = f (envPrintMetasBare e) <&> \ x -> e { envPrintMetasBare = x }--eInsideDotPattern :: Lens' TCEnv Bool-eInsideDotPattern f e = f (envInsideDotPattern e) <&> \ x -> e { envInsideDotPattern = x }--eUnquoteFlags :: Lens' TCEnv UnquoteFlags-eUnquoteFlags f e = f (envUnquoteFlags e) <&> \ x -> e { envUnquoteFlags = x }--eInstanceDepth :: Lens' TCEnv Int-eInstanceDepth f e = f (envInstanceDepth e) <&> \ x -> e { envInstanceDepth = x }--eIsDebugPrinting :: Lens' TCEnv Bool-eIsDebugPrinting f e = f (envIsDebugPrinting e) <&> \ x -> e { envIsDebugPrinting = x }--ePrintingPatternLambdas :: Lens' TCEnv [QName]-ePrintingPatternLambdas f e = f (envPrintingPatternLambdas e) <&> \ x -> e { envPrintingPatternLambdas = x }--eCallByNeed :: Lens' TCEnv Bool-eCallByNeed f e = f (envCallByNeed e) <&> \ x -> e { envCallByNeed = x }--eCurrentCheckpoint :: Lens' TCEnv CheckpointId-eCurrentCheckpoint f e = f (envCurrentCheckpoint e) <&> \ x -> e { envCurrentCheckpoint = x }--eCheckpoints :: Lens' TCEnv (Map CheckpointId Substitution)-eCheckpoints f e = f (envCheckpoints e) <&> \ x -> e { envCheckpoints = x }--eGeneralizeMetas :: Lens' TCEnv DoGeneralize-eGeneralizeMetas f e = f (envGeneralizeMetas e) <&> \ x -> e { envGeneralizeMetas = x }--eGeneralizedVars :: Lens' TCEnv (Map QName GeneralizedValue)-eGeneralizedVars f e = f (envGeneralizedVars e) <&> \ x -> e { envGeneralizedVars = x }--eActiveBackendName :: Lens' TCEnv (Maybe BackendName)-eActiveBackendName f e = f (envActiveBackendName e) <&> \ x -> e { envActiveBackendName = x }--eConflComputingOverlap :: Lens' TCEnv Bool-eConflComputingOverlap f e = f (envConflComputingOverlap e) <&> \ x -> e { envConflComputingOverlap = x }--eCurrentlyElaborating :: Lens' TCEnv Bool-eCurrentlyElaborating f e = f (envCurrentlyElaborating e) <&> \ x -> e { envCurrentlyElaborating = x }--{-# SPECIALISE currentModality :: TCM Modality #-}--- | The current modality.--- Note that the returned cohesion component is always 'unitCohesion'.-currentModality :: MonadTCEnv m => m Modality-currentModality = do- r <- viewTC eRelevance- q <- viewTC eQuantity- return Modality- { modRelevance = r- , modPolarity = defaultPolarity- , modQuantity = q- , modCohesion = unitCohesion- }-------------------------------------------------------------------------------- ** Let bindings------------------------------------------------------------------------------type LetBindings = Map Name (Open LetBinding)--data LetBinding = LetBinding { letOrigin :: Origin- , letTerm :: Term- , letType :: Dom Type- }- deriving (Show, Generic)--onLetBindingType :: (Dom Type -> Dom Type) -> LetBinding -> LetBinding-onLetBindingType f b = b { letType = f $ letType b }-------------------------------------------------------------------------------- ** 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-------------------------------------------------------------------------------- ** Opaque blocks-------------------------------------------------------------------------------- | A block of opaque definitions.-data OpaqueBlock = OpaqueBlock- { opaqueId :: {-# UNPACK #-} !OpaqueId- -- ^ Unique identifier for this block.- , opaqueUnfolding :: HashSet QName- -- ^ Set of names we are allowed to unfold. After scope-checking,- -- this set should be transitively closed.- , opaqueDecls :: HashSet QName- -- ^ Declarations contained in this abstract block.- , opaqueParent :: Maybe OpaqueId- -- ^ Pointer to an enclosing opaque block, if one exists.- , opaqueRange :: Range- -- ^ Where is this opaque block?- } deriving (Show, Generic)--instance Pretty OpaqueBlock where- pretty (OpaqueBlock _ uf ds p _) = vcat- $ [ "opaque (extends " <> pretty p <> ") {"- , nest 2 "unfolds"- ]- ++ [ nest 4 (pretty n <> ",") | n <- List.sort $ HashSet.toList uf ]- -- Andreas, 2023-08-10, https://github.com/agda/agda/pull/6628#discussion_r1285078454- -- The HashSet.toList is non-deterministic, order may depend on version of @hashable@.- -- Thus, we sort the list, so that the output isn't dependent on the specific build.- ++ [ nest 2 "declares" ]- ++ [ nest 4 (pretty n <+> ": _") | n <- List.sort $ HashSet.toList ds ]- ++ [ "}" ]--instance Eq OpaqueBlock where- xs == ys = opaqueId xs == opaqueId ys--instance Hashable OpaqueBlock where- hashWithSalt s = hashWithSalt s . opaqueId-------------------------------------------------------------------------------- ** 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)--isExpandLast :: ExpandHidden -> Bool-isExpandLast ExpandLast = True-isExpandLast DontExpandLast = False-isExpandLast ReallyDontExpandLast = False--isDontExpandLast :: ExpandHidden -> Bool-isDontExpandLast = not . isExpandLast--toExpandLast :: Bool -> ExpandHidden-toExpandLast True = ExpandLast-toExpandLast False = DontExpandLast--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- , candidateOverlap :: OverlapMode- }- deriving (Show, Generic)--instance Free Candidate where- freeVars' (Candidate _ t u _) = freeVars' (t, u)--instance HasOverlapMode Candidate where- lensOverlapMode f x = f (candidateOverlap x) <&> \m -> x{ candidateOverlap = m }-------------------------------------------------------------------------------- ** Checking arguments------------------------------------------------------------------------------data CheckedArg = CheckedArg- { caElim :: Elim- -- ^ Checked and inserted argument.- , caRange :: Maybe Range- -- ^ Range of checked argument, where present.- -- E.g. inserted implicits have no correponding abstract syntax.- , caConstraint :: Maybe (Abs Constraint)- -- ^ Head constraint before applying the argument.- }- deriving Show--data ArgsCheckState a = ACState- { acCheckedArgs :: [CheckedArg]- -- ^ Checked and inserted arguments so far.- , acFun :: A.Expr- -- ^ The function applied to the already checked arguments.- , acType :: Type- -- ^ Type of the function (for checking the remaining arguments).- , 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 (List1 TerminationError)- | UnreachableClauses QName (List1 Range)- -- ^ @UnreachableClauses f rs@ means that the clauses in @f@ whose ranges are @rs@- -- are unreachable.- | CoverageIssue QName (List1 (Telescope, [NamedArg DeBruijnPattern]))- -- ^ `CoverageIssue f pss` means that `pss` are not covered in `f`- | CoverageNoExactSplit QName (List1 Clause)- | InlineNoExactSplit QName Clause- -- ^ 'Clause' was turned into copattern matching clause(s) by an @{-# INLINE constructor #-}@- -- and thus is not a definitional equality any more.- | NotStrictlyPositive QName (Seq OccursWhere)- | ConstructorDoesNotFitInData DataOrRecord_ QName Sort Sort TCErr- -- ^ Checking whether constructor 'QName' 'Sort' fits into @data@ 'Sort'- -- produced 'TCErr'.- | CoinductiveEtaRecord QName- -- ^ A record type declared as both @coinductive@ and having @eta-equality@.-- | UnsolvedMetaVariables (Set1 Range) -- ^ Do not use directly with 'warning'- | UnsolvedInteractionMetas (Set1 Range) -- ^ Do not use directly with 'warning'- | UnsolvedConstraints (List1 ProblemConstraint) -- no instance Ord ProblemConstraint- -- ^ Do not use directly with 'warning'- | InteractionMetaBoundaries (Set1 Range)- -- ^ Do not use directly with 'warning'-- | CantGeneralizeOverSorts (Set1 MetaId)- | AbsurdPatternRequiresAbsentRHS- | OldBuiltin BuiltinId BuiltinId- -- ^ In `OldBuiltin old new`, the BUILTIN old has been replaced by new.- | BuiltinDeclaresIdentifier BuiltinId- -- ^ The builtin declares a new identifier, so it should not be in scope.- | DuplicateRecordDirective C.RecordDirective- -- ^ The given record directive is conflicting with a prior one in the same record declaration.- | EmptyRewritePragma- -- ^ If the user wrote just @{-\# REWRITE \#-}@.- | EmptyWhere- -- ^ An empty @where@ block is dead code.- -- TODO: linearity- -- -- | FixingQuantity String Quantity Quantity- -- -- -- ^ Auto-correcting quantity pertaining to 'String' /from/ /to/.- | FixingRelevance String Relevance Relevance- -- ^ Auto-correcting relevance pertaining to 'String' /from/ /to/.- | FixingCohesion String Cohesion Cohesion- -- ^ Auto-correcting cohesion pertaining to 'String' /from/ /to/.- | FixingPolarity String PolarityModality PolarityModality- -- ^ Auto-correcting polarity pertaining to 'String' /from/ /to/.- | 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.- | InvalidCharacterLiteral Char- -- ^ A character literal Agda does not support, e.g. surrogate code points.- | ClashesViaRenaming NameOrModule (Set1 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.- | UselessPragma Range Doc- -- ^ Warning when pragma is useless and thus ignored.- -- 'Range' is for dead code highlighting.- | UselessPublic UselessPublicReason- -- ^ If the user opens a module public before the module header.- -- (See issue #2377.)- | UselessHiding (List1 C.ImportedName)- -- ^ Names in `hiding` directive that don't hide anything- -- imported by a `using` directive.- | UselessInline QName- | UselessTactic- -- ^ A tactic attribute applied to a non-hidden (visible or instance) argument.- | 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.-- -- Safe flag errors- | SafeFlagPostulate QName- | SafeFlagPragma (Set String)- -- ^ Unsafe OPTIONS.- | SafeFlagWithoutKFlagPrimEraseEquality- | WithoutKFlagPrimEraseEquality- | ConflictingPragmaOptions String String- -- ^ `ConflictingPragmaOptions a b`:- -- Inconsistent options `--a` and `--no-b`, since `--a` implies `--b`. Ignoring `--no-b`.- | 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] (List1 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- | ConfluenceCheckingIncompleteBecauseOfMeta QName- -- ^ Confluence checking incomplete because the definition of the 'QName'- -- contains unsolved metavariables.- | ConfluenceForCubicalNotSupported- -- ^ Confluence checking with @--cubical@ might be incomplete.- | NotARewriteRule C.QName IsAmbiguous- -- ^ 'IllegalRewriteRule' detected during scope checking.- | IllegalRewriteRule QName IllegalRewriteRuleReason- | 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.- | PragmaCompileList- -- ^ @COMPILE GHC@ pragma for lists; ignored.- | PragmaCompileMaybe- -- ^ @COMPILE GHC@ pragma for @MAYBE@; ignored.- | PragmaCompileUnparsable String- -- ^ @COMPILE GHC@ pragma 'String' not parsable; ignored.- | PragmaCompileWrong QName String- -- ^ Wrong @COMPILE GHC@ given for 'QName'; explanation is in 'String'.- | PragmaCompileWrongName C.QName IsAmbiguous- -- ^ @COMPILE@ pragma with name 'C.QName' that is not an unambiguous constructor or definition.- | PragmaExpectsDefinedSymbol String C.QName- -- ^ Pragma 'String' with name 'C.QName' that is not an 'A.Def'.- | PragmaExpectsUnambiguousConstructorOrFunction String C.QName IsAmbiguous- -- ^ Pragma 'String' with name 'C.QName' that is not an unambiguous constructor or definition.- -- General form of 'PragmaCompileWrongName' and 'NotARewriteRule'.- | PragmaExpectsUnambiguousProjectionOrFunction String C.QName IsAmbiguous- -- ^ Pragma 'String' with name 'C.QName' that is not an unambiguous projection or function.- | NoMain TopLevelModuleName- -- ^ Compiler run on module that does not have a @main@ function.- | NotInScopeW C.QName- -- ^ Out of scope error we can recover from.- | UnsupportedIndexedMatch Doc- -- ^ Was not able to compute a full equivalence when splitting.- | AsPatternShadowsConstructorOrPatternSynonym ConstructorOrPatternSynonym- -- ^ The as-name in an as-pattern may not shadow a constructor- -- or pattern synonym name,- -- because this can be confusing to read.- | PatternShadowsConstructor C.Name A.QName- -- ^ A pattern variable has the name of a constructor- -- (data constructor or matchable record constructor).- | PlentyInHardCompileTimeMode QωOrigin- -- ^ Explicit use of @@ω@ or @@plenty@ in hard compile-time mode.- | RecordFieldWarning RecordFieldWarning-- -- Opaque- | MissingTypeSignatureForOpaque QName IsOpaque- -- ^ An @abstract@ or @opaque@ definition lacks a type signature.- | NotAffectedByOpaque- | UnfoldingWrongName C.QName- -- ^ Name in @unfolding@ clause does not resolve to unambiguous defined name.- | UnfoldTransparentName QName- | UselessOpaque-- -- Recoverable scope-checking errors- | HiddenNotInArgumentPosition C.Expr- | InstanceNotInArgumentPosition C.Expr- | MacroInLetBindings- | AbstractInLetBindings-- -- Display form warnings- | InvalidDisplayForm QName String- -- ^ DISPLAY form for 'QName' is invalid because 'String'.- | UnusedVariablesInDisplayForm (List1 A.Name)- -- ^ The given names are bound in the lhs of the display form- -- but not used on the rhs.- -- This can indicate a user misunderstanding of display forms.-- -- Type checker warnings- | TooManyArgumentsToSort QName (List1 (NamedArg A.Expr))- -- ^ Extra arguments to sort (will be ignored).- | RewritesNothing- -- ^ A @rewrite@ expression that does not fire.- | WithClauseProjectionFixityMismatch- { withClausePattern :: NamedArg A.Pattern- , withClauseProjectionOrigin :: ProjOrigin- , parentPattern :: NamedArg DeBruijnPattern- , parentProjectionOrigin :: ProjOrigin- }- -- ^ The with-clause uses projection in a different fixity style- -- than the parent clause.-- -- Polarity warnings- | TooManyPolarities QName PragmaPolarities- -- ^ Too many polarities given in POLARITY pragma for 'QName'.- -- 'PragmaPolarities' contains the (likely) excessive polarities.- | TopLevelPolarity QName PolarityModality- -- ^ Definition with non-default polarity annotation.-- -- Cubical- | FaceConstraintCannotBeHidden ArgInfo- -- ^ Face constraint patterns @(i = 0)@ must be visible arguments.- | FaceConstraintCannotBeNamed NamedName- -- ^ Face constraint patterns @(i = 0)@ must be unnamed arguments.-- -- Not source code related- | CustomBackendWarning String Doc- -- ^ Used for backend-specific warnings. The string is the backend name.- deriving (Show, Generic)--recordFieldWarningToError :: RecordFieldWarning -> TypeError-recordFieldWarningToError = \case- W.DuplicateFields xrs -> DuplicateFields $ fmap fst xrs- W.TooManyFields q ys xrs -> TooManyFields q ys $ fmap 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- -- scope- and type-checking errors- AsPatternShadowsConstructorOrPatternSynonym{} -> AsPatternShadowsConstructorOrPatternSynonym_- PatternShadowsConstructor{} -> PatternShadowsConstructor_- AbsurdPatternRequiresAbsentRHS{} -> AbsurdPatternRequiresAbsentRHS_- CantGeneralizeOverSorts{} -> CantGeneralizeOverSorts_- CoverageIssue{} -> CoverageIssue_- CoverageNoExactSplit{} -> CoverageNoExactSplit_- InlineNoExactSplit{} -> InlineNoExactSplit_- DeprecationWarning{} -> DeprecationWarning_- DuplicateRecordDirective{} -> DuplicateRecordDirective_- EmptyRewritePragma -> EmptyRewritePragma_- EmptyWhere -> EmptyWhere_- -- TODO: linearity- -- FixingQuantity{} -> FixingQuantity_- FixingRelevance{} -> FixingRelevance_- FixingCohesion{} -> FixingCohesion_- FixingPolarity{} -> FixingPolarity_- IllformedAsClause{} -> IllformedAsClause_- WrongInstanceDeclaration{} -> WrongInstanceDeclaration_- InstanceWithExplicitArg{} -> InstanceWithExplicitArg_- InstanceNoOutputTypeName{} -> InstanceNoOutputTypeName_- InstanceArgWithExplicitArg{} -> InstanceArgWithExplicitArg_- DuplicateUsing{} -> DuplicateUsing_- FixityInRenamingModule{} -> FixityInRenamingModule_- InvalidCharacterLiteral{} -> InvalidCharacterLiteral_- UselessPragma{} -> UselessPragma_- InversionDepthReached{} -> InversionDepthReached_- InteractionMetaBoundaries{} -> InteractionMetaBoundaries_{}- ModuleDoesntExport{} -> ModuleDoesntExport_- NotInScopeW{} -> NotInScope_- NotStrictlyPositive{} -> NotStrictlyPositive_- ConstructorDoesNotFitInData{}-> ConstructorDoesNotFitInData_- CoinductiveEtaRecord{} -> CoinductiveEtaRecord_- UnsupportedIndexedMatch{} -> UnsupportedIndexedMatch_- OldBuiltin{} -> OldBuiltin_- BuiltinDeclaresIdentifier{} -> BuiltinDeclaresIdentifier_- SafeFlagPostulate{} -> SafeFlagPostulate_- SafeFlagPragma{} -> SafeFlagPragma_- SafeFlagWithoutKFlagPrimEraseEquality -> SafeFlagWithoutKFlagPrimEraseEquality_- ConflictingPragmaOptions{} -> ConflictingPragmaOptions_- WithoutKFlagPrimEraseEquality -> WithoutKFlagPrimEraseEquality_- TerminationIssue{} -> TerminationIssue_- UnreachableClauses{} -> UnreachableClauses_- UnsolvedInteractionMetas{} -> UnsolvedInteractionMetas_- UnsolvedConstraints{} -> UnsolvedConstraints_- UnsolvedMetaVariables{} -> UnsolvedMetaVariables_- UselessHiding{} -> UselessHiding_- UselessInline{} -> UselessInline_- UselessPublic{} -> UselessPublic_- UselessPatternDeclarationForRecord{} -> UselessPatternDeclarationForRecord_- UselessTactic{} -> UselessTactic_- ClashesViaRenaming{} -> ClashesViaRenaming_- UserWarning{} -> UserWarning_- InfectiveImport{} -> InfectiveImport_- CoInfectiveImport{} -> CoInfectiveImport_- ConfluenceCheckingIncompleteBecauseOfMeta{} -> ConfluenceCheckingIncompleteBecauseOfMeta_- ConfluenceForCubicalNotSupported{} -> ConfluenceForCubicalNotSupported_- IllegalRewriteRule _ reason -> illegalRewriteWarningName reason- NotARewriteRule{} -> NotARewriteRule_- RewriteNonConfluent{} -> RewriteNonConfluent_- RewriteMaybeNonConfluent{} -> RewriteMaybeNonConfluent_- RewriteAmbiguousRules{} -> RewriteAmbiguousRules_- RewriteMissingRule{} -> RewriteMissingRule_- PragmaCompileErased{} -> PragmaCompileErased_- PragmaCompileList{} -> PragmaCompileList_- PragmaCompileMaybe{} -> PragmaCompileMaybe_- PragmaCompileUnparsable{} -> PragmaCompileUnparsable_- PragmaCompileWrong{} -> PragmaCompileWrong_- PragmaCompileWrongName{} -> PragmaCompileWrongName_- PragmaExpectsDefinedSymbol{} -> PragmaExpectsDefinedSymbol_- PragmaExpectsUnambiguousConstructorOrFunction{} ->- PragmaExpectsUnambiguousConstructorOrFunction_- PragmaExpectsUnambiguousProjectionOrFunction{} ->- PragmaExpectsUnambiguousProjectionOrFunction_- NoMain{} -> NoMain_- PlentyInHardCompileTimeMode{}- -> PlentyInHardCompileTimeMode_- -- record field warnings- RecordFieldWarning w -> case w of- W.DuplicateFields{} -> DuplicateFields_- W.TooManyFields{} -> TooManyFields_-- -- opaque warnings- MissingTypeSignatureForOpaque{} -> MissingTypeSignatureForOpaque_- NotAffectedByOpaque{} -> NotAffectedByOpaque_- UselessOpaque{} -> UselessOpaque_- UnfoldingWrongName{} -> UnfoldingWrongName_- UnfoldTransparentName{} -> UnfoldTransparentName_-- -- Recoverable scope-checking errors- HiddenNotInArgumentPosition{} -> HiddenNotInArgumentPosition_- InstanceNotInArgumentPosition{} -> InstanceNotInArgumentPosition_- MacroInLetBindings{} -> MacroInLetBindings_- AbstractInLetBindings{} -> AbstractInLetBindings_-- -- Display forms- InvalidDisplayForm{} -> InvalidDisplayForm_- UnusedVariablesInDisplayForm{} -> UnusedVariablesInDisplayForm_-- -- Type checking- TooManyArgumentsToSort{} -> TooManyArgumentsToSort_- RewritesNothing{} -> RewritesNothing_- WithClauseProjectionFixityMismatch{} -> WithClauseProjectionFixityMismatch_-- -- Polarities- TooManyPolarities{} -> TooManyPolarities_- TopLevelPolarity{} -> TopLevelPolarity_-- -- Cubical- FaceConstraintCannotBeHidden{} -> FaceConstraintCannotBeHidden_- FaceConstraintCannotBeNamed{} -> FaceConstraintCannotBeNamed_-- -- Backend warnings- CustomBackendWarning{} -> CustomBackendWarning_--illegalRewriteWarningName :: IllegalRewriteRuleReason -> WarningName-illegalRewriteWarningName = \case- LHSNotDefinitionOrConstructor{} -> RewriteLHSNotDefinitionOrConstructor_- VariablesNotBoundByLHS{} -> RewriteVariablesNotBoundByLHS_- VariablesBoundMoreThanOnce{} -> RewriteVariablesBoundMoreThanOnce_- LHSReduces{} -> RewriteLHSReduces_- HeadSymbolIsProjectionLikeFunction{} -> RewriteHeadSymbolIsProjectionLikeFunction_- HeadSymbolIsTypeConstructor{} -> RewriteHeadSymbolIsTypeConstructor_- HeadSymbolContainsMetas{} -> RewriteHeadSymbolContainsMetas_- ConstructorParametersNotGeneral{} -> RewriteConstructorParametersNotGeneral_- ContainsUnsolvedMetaVariables{} -> RewriteContainsUnsolvedMetaVariables_- BlockedOnProblems{} -> RewriteBlockedOnProblems_- RequiresDefinitions{} -> RewriteRequiresDefinitions_- DoesNotTargetRewriteRelation -> RewriteDoesNotTargetRewriteRelation_- BeforeFunctionDefinition -> RewriteBeforeFunctionDefinition_- BeforeMutualFunctionDefinition{} -> RewriteBeforeMutualFunctionDefinition_- DuplicateRewriteRule -> DuplicateRewriteRule_---- | Should warnings of that type be serialized?------ Only when changes in the source code can silence or influence the warning.----isSourceCodeWarning :: WarningName -> Bool-isSourceCodeWarning = \case- WarningProblem_ -> False- _ -> True--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- , tcWarningDoc :: Doc- -- ^ The warning printed in the state and environment where it was raised- , tcWarningString :: String- -- ^ Caches @render tcWarningDoc@ for the sake of an 'Ord' instance.- , tcWarningCached :: Bool- -- ^ Should the warning be affected by caching.- }- deriving (Show, Generic)--tcWarningOrigin :: TCWarning -> SrcFile-tcWarningOrigin = rangeFile . tcWarningRange--instance HasRange TCWarning where- getRange = tcWarningRange--instance Eq TCWarning where- (==) = (==) `on` tcWarningRange &&& tcWarningString--instance Ord TCWarning where- compare = compare `on` tcWarningRange &&& tcWarningString-------------------------------------------------------------------------------- * 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.- , termErrGuardednessHelps :: GuardednessHelps- -- ^ Is the termination error resolved by activating @--guardedness@?- } 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 ErasedDatatypeReason (Closure Type)- -- ^ Data type, but in erased position.- | 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- = BlockedOnMeta TCState Blocker- | CannotDeclareHiddenFunction QName- -- ^ Attempt to @unquoteDecl@ with 'Hiding' other than 'NotHidden'.- | CommitAfterDef- | ConInsteadOfDef QName String String- | DefineDataNotData QName- | DefInsteadOfCon QName String String- | MissingDeclaration QName- | MissingDefinition QName- | NakedUnquote- | NonCanonical String I.Term- | PatLamWithoutClauses I.Term- | StaleMeta TopLevelModuleName MetaId- -- ^ Attempt to unquote a serialized meta.- | TooManyParameters Nat A.Expr- -- ^ Attempt to shave of 'Nat' many parameters from function type 'A.Expr'.- | UnboundName QName- deriving (Show, Generic)---- | Error when trying to call an external executable during reflection.-data ExecError- = ExeNotTrusted ExeName ExeMap- -- ^ The given executable is not listed as trusted.- | ExeNotFound ExeName FilePath- -- ^ The given executable could not be found under the given path.- | ExeNotExecutable ExeName FilePath- -- ^ The given file path does not have executable permissions.- deriving (Show, Generic)--data TypeError- = InternalError String- | NotImplemented String- | NotSupported String- | CompilationError String- | SyntaxError String- -- ^ Essential syntax error thrown after successful parsing.- -- Description in 'String'.- | OptionError OptionError- -- ^ Error thrown by the option parser.- | NicifierError DeclarationException'- -- ^ Error thrown in the nicifier phase 'Agda.Syntax.Concrete.Definitions'.- | DoNotationError String- -- ^ Error during unsugaring some @do@ notation.- -- Error message in 'String'.- | IdiomBracketError String- -- ^ Error during (operator) parsing and interpreting the contents of idiom brackets.- -- Error message in 'String'.- | NoKnownRecordWithSuchFields [C.Name]- -- ^ The user has given a record expression with the given fields,- -- but no record type known to type inference has all these fields.- -- The list can be empty.- | ShouldEndInApplicationOfTheDatatype Type- -- ^ The target of a constructor isn't an application of its- -- datatype. The 'Type' records what it does target.- | ConstructorPatternInWrongDatatype QName QName -- ^ constructor, datatype- | CantResolveOverloadedConstructorsTargetingSameDatatype QName (List1 QName)- -- ^ Datatype, constructors.- | ConstructorDoesNotTargetGivenType QName Type -- ^ constructor, type- | InvalidDottedExpression- -- ^ @.e@ in non-argument position.- | LiteralTooBig- -- ^ An integer literal that would be too costly to expand to unary.- | NegativeLiteralInPattern- -- ^ Negative literals are not supported in patterns.- | 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.- | WrongHidingInProjection QName- | IllegalHidingInPostfixProjection (NamedArg C.Expr)- | WrongNamedArgument (NamedArg A.Expr) (List1 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.- | WrongAnnotationInLambda- -- ^ Wrong user-given (lock/tick) annotation in lambda.- | WrongIrrelevanceInLambda- -- ^ Wrong user-given relevance annotation in lambda.- | WrongQuantityInLambda- -- ^ Wrong user-given quantity annotation in lambda.- | WrongCohesionInLambda- -- ^ Wrong user-given cohesion annotation in lambda.- | WrongPolarityInLambda- -- ^ Wrong user-given polarity 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 relevance.- | ForcedConstructorNotInstantiated A.Pattern- | IllformedProjectionPatternAbstract A.Pattern- | IllformedProjectionPatternConcrete C.Pattern- | CannotEliminateWithPattern (Maybe Blocker) (NamedArg A.Pattern) Type- | CannotEliminateWithProjection (Arg Type) Bool QName- | WrongNumberOfConstructorArguments QName Nat Nat- | ShouldBeEmpty Type [DeBruijnPattern]- -- ^ Type should be empty. The list gives possible patterns that match, but can be empty.- | 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- | CannotApply A.Expr Type- -- ^ The given expression is used as a function- -- but its type is not a function type.- | InvalidTypeSort Sort- -- ^ This sort is not a type expression.- | SplitOnCoinductive- | SplitOnIrrelevant (Dom Type)- | SplitOnUnusableCohesion (Dom Type)- | SplitOnUnusablePolarity (Dom Type)- -- UNUSED: -- | SplitOnErased (Dom Type)- | SplitOnNonVariable Term Type- | SplitOnNonEtaRecord QName- | SplitOnAbstract QName- | SplitOnUnchecked QName- | SplitOnPartial (Dom Type)- | SplitInProp DataOrRecordE- | DefinitionIsIrrelevant QName- | DefinitionIsErased QName- | ProjectionIsIrrelevant QName- | VariableIsIrrelevant Name- | VariableIsErased Name- | VariableIsOfUnusableCohesion Name Cohesion- | LambdaIsErased- | RecordIsErased- | InvalidModalTelescopeUse Term Modality Modality Definition- | VariableIsOfUnusablePolarity Name PolarityModality- | UnequalLevel Comparison Level Level- | UnequalTerms Comparison Term Term CompareAs- | 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.- | UnequalPolarity Comparison Term Term- -- ^ The two function types have different polarity.- | 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- | NotLeqSort Sort Sort- | MetaCannotDependOn MetaId Term Nat- -- ^ The arguments are the meta variable, the proposed solution,- -- and the parameter that it wants to depend on.- | MetaIrrelevantSolution MetaId Term- -- ^ When solving @'MetaId' ... := 'Term'@,- -- part of the 'Term' is invalid as it was created in an irrelevant context.- | MetaErasedSolution MetaId Term- -- ^ When solving @'MetaId' ... := 'Term'@,- -- part of the 'Term' is invalid as it was created in an erased context.- | GenericError String- | GenericDocError Doc- | SortOfSplitVarError (Maybe Blocker) Doc- -- ^ the meta is what we might be blocked on.- | WrongSharpArity A.QName- | BuiltinMustBeConstructor BuiltinId A.Expr- | BuiltinMustBeData BuiltinId Int- | BuiltinMustBeDef BuiltinId- | BuiltinMustBeFunction BuiltinId- | BuiltinMustBePostulate BuiltinId- | NoSuchBuiltinName String- | InvalidBuiltin String- | DuplicateBuiltinBinding BuiltinId Term Term- | NoBindingForBuiltin BuiltinId- | NoBindingForPrimitive PrimitiveId- | NoSuchPrimitiveFunction String- | DuplicatePrimitiveBinding PrimitiveId QName QName- | WrongArgInfoForPrimitive PrimitiveId ArgInfo ArgInfo- | ShadowedModule C.Name (List1 A.ModuleName)- | BuiltinInParameterisedModule BuiltinId- | IllegalDeclarationInDataDefinition (List1 C.Declaration)- -- ^ The declaration list comes from a single 'C.NiceDeclaration'.- | IllegalLetInTelescope C.TypedBinding- | IllegalPatternInTelescope C.Binder- | AbsentRHSRequiresAbsurdPattern- | TooManyFields QName [C.Name] (List1 C.Name)- -- ^ Record type, fields not supplied by user, possibly non-fields but supplied.- | DuplicateFields (List1 C.Name)- | DuplicateConstructors (List1 C.Name)- | DuplicateOverlapPragma QName OverlapMode OverlapMode- | WithOnFreeVariable A.Expr Term- | UnexpectedWithPatterns (List1 A.Pattern)- | WithClausePatternMismatch A.Pattern (NamedArg DeBruijnPattern)- | IllTypedPatternAfterWithAbstraction A.Pattern- | TooFewPatternsInWithClause- | TooManyPatternsInWithClause- | PathAbstractionFailed (Abs Type)- | FieldOutsideRecord- | ModuleArityMismatch A.ModuleName Telescope (Either (List1 (NamedArg A.Expr)) Args)- | GeneralizeCyclicDependency- | ReferencesFutureVariables Term (List1 Int) (Arg Term) Int- -- ^ The first term references the given list of variables,- -- which are in "the future" with respect to the given lock- -- (and its leftmost variable)- | DoesNotMentionTicks Term Type (Arg Term)- -- ^ Arguments: later term, its type, lock term. The lock term- -- does not mention any @lock variables.- | MismatchedProjectionsError QName QName- | AttributeKindNotEnabled String String String- | InvalidProjectionParameter (NamedArg A.Expr)- | TacticAttributeNotAllowed- | CannotRewriteByNonEquation Type- | MacroResultTypeMismatch Type- | NamedWhereModuleInRefinedContext [Term] [String]- -- ^ The lists should have the same length.- -- TODO: enforce this by construction.- | ComatchingDisabledForRecord QName- | IncorrectTypeForRewriteRelation Term IncorrectTypeForRewriteRelationReason- -- Cubical errors- | CannotGenerateHCompClause Type- -- ^ Cannot generate @hcomp@ clause because type is not fibrant.- | CannotGenerateTransportClause QName (Closure (Abs Type))- -- ^ Cannot generate transport clause because type is not fibrant.- | CubicalNotErasure QName- -- ^ Name was defined for @--cubical@- -- and for use in @--erased-cubical@ the option @--erasure@ is needed.- | CubicalPrimitiveNotFullyApplied QName- | ExpectedIntervalLiteral A.Expr- -- ^ Expected an interval literal (0 or 1) but found 'A.Expr'.- | FaceConstraintDisjunction- | FaceConstraintUnsatisfiable- | PatternInPathLambda- -- ^ Attempt to pattern match in an abstraction of interval type.- | PatternInSystem- -- ^ Attempt to pattern or copattern match in a system.- -- Data errors- | UnexpectedParameter A.LamBinding- | NoParameterOfName ArgName- | UnexpectedModalityAnnotationInParameter A.LamBinding- | ExpectedBindingForParameter (Dom Type) (Abs Type)- | UnexpectedTypeSignatureForParameter (List1 (NamedArg A.Binder))- | SortDoesNotAdmitDataDefinitions QName Sort- | SortCannotDependOnItsIndex QName Type- -- Modality errors- | UnusableAtModality WhyCheckModality Modality Term- -- Coverage errors--- UNUSED: | IncompletePatternMatching Term [Elim] -- can only happen if coverage checking is switched off- | SplitError SplitError- | ImpossibleConstructor QName NegativeUnification- -- Positivity and polarity errors- | DatatypeIndexPolarity- -- ^ An index of a data type has a polarity different from 'Mixed'.- | RecursiveRecordNeedsInductivity QName- -- ^ A record type inferred as recursive needs a manual declaration- -- whether it should be inductively or coinductively.-- -- Sized type errors- | CannotSolveSizeConstraints (List1 (ProblemConstraint, HypSizeConstraint)) Doc- -- ^ The list of constraints is given redundantly as pairs of- -- 'ProblemConstraint' (original constraint) and- -- 'HypSizeConstraint' (form with size assumptions in context spelled out).- -- The 'Doc' is some extra reason for why solving failed.- | ContradictorySizeConstraint (ProblemConstraint, HypSizeConstraint)- | EmptyTypeOfSizes Term- -- ^ This type, representing a type of sizes, might be empty.- | FunctionTypeInSizeUniv Term- -- ^ This term, a function type constructor, lives in- -- @SizeUniv@, which is not allowed.- | PostulatedSizeInModule- -- Import errors- | LibraryError LibErrors- -- ^ Collected errors when processing the @.agda-lib@ file.- | LibTooFarDown TopLevelModuleName AgdaLibFile- -- ^ The @.agda-lib@ file for the given module is not on the right level.- | 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 (List2 TopLevelModuleName)- -- ^ The cycle starts and ends with the same module.- | FileNotFound TopLevelModuleName [AbsolutePath]- -- ^ The list can be empty.- | OverlappingProjects AbsolutePath TopLevelModuleName TopLevelModuleName- | AmbiguousTopLevelModuleName TopLevelModuleName (List2 AbsolutePath)- -- ^ The given module has at least 2 file locations.- | ModuleNameUnexpected TopLevelModuleName TopLevelModuleName- -- ^ Found module name, expected module name.- | ModuleNameDoesntMatchFileName TopLevelModuleName [AbsolutePath]- -- ^ The list can be empty.- | ModuleDefinedInOtherFile TopLevelModuleName AbsolutePath AbsolutePath- -- ^ Module name, file from which it was loaded, file which- -- the include path says contains the module.- | InvalidFileName AbsolutePath InvalidFileNameReason- -- ^ The file name does not correspond to a module name.- | ModuleNameHashCollision RawTopLevelModuleName (Maybe RawTopLevelModuleName)- -- Scope errors- | BothWithAndRHS- | AbstractConstructorNotInScope A.QName- | CopatternHeadNotProjection C.QName- | NotAllowedInDotPatterns NotAllowedInDotPatterns- | NotInScope C.QName- | NoSuchModule C.QName- | AmbiguousName C.QName AmbiguousNameReason- | AmbiguousModule C.QName (List1 A.ModuleName)- | AmbiguousField C.Name (List2 A.ModuleName)- | AmbiguousConstructor QName (List2 QName)- -- ^ The list contains all interpretations of the name.- | ClashingDefinition C.QName A.QName (Maybe NiceDeclaration)- | ClashingModule A.ModuleName A.ModuleName- | DefinitionInDifferentModule A.QName- -- ^ The given data/record definition rests in a different module than its signature.- | DuplicateImports C.QName (List1 C.ImportedName)- | InvalidPattern C.Pattern- | InvalidPun ConstructorOrPatternSynonym C.QName- -- ^ Expected the identifier to be a variable, not a constructor or pattern synonym.- | RepeatedNamesInImportDirective (List1 (List2 C.ImportedName))- -- ^ Some names are bound several times by an @import@/@open@ directive.- | RepeatedVariablesInPattern (List1 C.Name)- | GeneralizeNotSupportedHere A.QName- | GeneralizedVarInLetOpenedModule A.QName- | MultipleFixityDecls (List1 (C.Name, Pair Fixity'))- | MultiplePolarityPragmas (List1 C.Name)- | ExplicitPolarityVsPragma QName- | ConstructorNameOfNonRecord ResolvedName- -- Concrete to Abstract errors- | CannotQuote CannotQuote- | CannotQuoteTerm CannotQuoteTerm- | DeclarationsAfterTopLevelModule- | IllegalDeclarationBeforeTopLevelModule- | MissingTypeSignature MissingTypeSignatureInfo- | NotAnExpression C.Expr- | NotAValidLetBinding (Maybe NotAValidLetBinding)- | NotAValidLetExpression NotAValidLetExpression- | NotValidBeforeField NiceDeclaration- | PrivateRecordField- | QualifiedLocalModule- -- Pattern synonym errors- | AsPatternInPatternSynonym- | DotPatternInPatternSynonym- | BadArgumentsToPatternSynonym A.AmbiguousQName- | TooFewArgumentsToPatternSynonym A.AmbiguousQName- | CannotResolveAmbiguousPatternSynonym (List1 (A.QName, A.PatternSynDefn))- | IllegalInstanceVariableInPatternSynonym C.Name- -- ^ This variable is bound in the lhs of the pattern synonym in instance position,- -- but not on the rhs.- -- This is forbidden because expansion of pattern synonyms would not be faithful- -- to availability of instances in instance search.- | PatternSynonymArgumentShadows ConstructorOrPatternSynonym C.Name (List1 AbstractName)- -- ^ A variable to be bound in the pattern synonym resolved on the rhs as name of- -- a constructor or a pattern synonym.- -- The resolvents are given in the list.- | UnusedVariableInPatternSynonym C.Name- -- ^ This variable is only bound on the lhs of the pattern synonym, not on the rhs.- | UnboundVariablesInPatternSynonym (List1 A.Name)- -- ^ These variables are only bound on the rhs of the pattern synonym, not on the lhs.- -- 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 (List2 C.Pattern)- -- ^ Pattern and its possible interpretations.- | AmbiguousProjection QName (List1 QName)- -- ^ The list contains alternative interpretations of the name.- | AmbiguousOverloadedProjection (List1 QName) Doc- | OperatorInformation [NotationSection] TypeError- -- ^ The list of notations can be empty.-{- UNUSED- | NoParseForPatternSynonym C.Pattern- | AmbiguousParseForPatternSynonym C.Pattern [C.Pattern]--}- -- Usage errors- -- Instance search errors- | InstanceNoCandidate Type [(Term, TCErr)]- -- ^ The list can be empty.- -- Reflection errors- | ExecError ExecError- | UnquoteFailed UnquoteError- | DeBruijnIndexOutOfScope Nat Telescope [Name]- -- ^ The list can be empty.- -- Language option errors- | NeedOptionAllowExec- | NeedOptionCopatterns- | NeedOptionCubical Cubical String- -- ^ Flavor of cubical needed for the given reason.- | NeedOptionPatternMatching- | NeedOptionProp- | NeedOptionRewriting- | NeedOptionSizedTypes String- -- ^ Need @--sized-types@ for the given reason.- | NeedOptionTwoLevel- | NeedOptionUniversePolymorphism- -- Failure associated to warnings- | NonFatalErrors (Set1 TCWarning)- -- Instance search errors- | InstanceSearchDepthExhausted Term Type Int- | TriedToCopyConstrainedPrim QName- | InvalidInstanceHeadType Type WhyInvalidInstanceType- -- Interaction errors- | InteractionError InteractionError- -- Backend errors- | BackendDoesNotSupportOnlyScopeChecking BackendName- -- ^ The given backend does not support @--only-scope-checking@.- | CubicalCompilationNotSupported Cubical- -- ^ NYI: Compilation of files using the given flavor of 'Cubical'.- | CustomBackendError BackendName Doc- -- ^ Used for backend-specific errors. The string is the backend name.- | GHCBackendError GHCBackendError- -- ^ Errors raised by the GHC backend.- | JSBackendError JSBackendError- -- ^ Errors raised by the JS backend.- | UnknownBackend BackendName (Set BackendName)- -- ^ Unknown backend requested, known ones are in the 'Set'.- deriving (Show, Generic)---- | Reason for why the instance type is invalid.-data WhyInvalidInstanceType- = ImproperInstHead- -- ^ The type isn't headed by a local, a definition, or a postulate- -- (e.g. it's a universe)- | ImproperInstTele- -- ^ The type we're looking for has a visible argument- deriving (Show, Generic)---- | Errors raised in @--interaction@ mode.-data InteractionError- = CannotGive A.Expr- -- ^ Failure of the 'give' interactive tactic.- | CannotRefine String- -- ^ Failure of the 'refine' interactive tactic.- | CaseSplitError Doc- -- ^ Failure of the 'makeCase' interactive tactic.- | ExpectedIdentifier C.Expr- -- ^ Expected the given expression to be an identifier.- | ExpectedApplication- -- ^ Expected an argument of the form @f e1 e2 .. en@.- | NoActionForInteractionPoint InteractionId- -- ^ Interaction point has not been reached during type checking.- | NoSuchInteractionPoint InteractionId- -- ^ 'InteractionId' does not resolve to an 'InteractionPoint'.- | UnexpectedWhere- -- ^ @where@ not allowed in hole.- deriving (Show, Generic)---- | Errors raised by the GHC backend.-data GHCBackendError- = ConstructorCountMismatch QName [QName] [String]- -- ^ The number of Haskell constructors ('String' list) does not match- -- the number of constructors of the given data type.- | NotAHaskellType Term WhyNotAHaskellType- -- ^ GHC backend fails to represent given Agda type in Haskell.- | WrongTypeOfMain QName Type- -- ^ The type of @main@ should be @IO _@ ('QName') but is instead 'Type'.- deriving (Show, Generic)---- | Errors raised by the JS backend.-data JSBackendError- = BadCompilePragma- deriving (Show, Generic)---- | Extra information for 'MissingTypeSignature' error.-data MissingTypeSignatureInfo- = MissingDataSignature C.Name- -- ^ The @data@ definition for 'C.Name' lacks a data signature.- | MissingRecordSignature C.Name- -- ^ The @record@ definition for 'C.Name' lacks a record signature.- | MissingFunctionSignature C.LHS- -- ^ The function lhs misses a type signature.- deriving (Show, Generic)---- | Extra information for 'NotAHaskellType' error.-data WhyNotAHaskellType- = NoPragmaFor QName- | WrongPragmaFor Range QName- | BadLambda Term- | BadMeta Term- | BadDontCare Term- | NotCompiled QName- deriving (Show, Generic)---- | Extra information for 'InvalidFileName' error.-data InvalidFileNameReason- = DoesNotCorrespondToValidModuleName- | RootNameModuleNotAQualifiedModuleName Text- deriving (Show, Generic)--type DataOrRecordE = DataOrRecord' InductionAndEta--data InductionAndEta = InductionAndEta- { recordInduction :: Maybe Induction- , recordEtaEquality :: EtaEquality- } deriving (Show, Generic)---- Reason, why rewrite rule is invalid-data IllegalRewriteRuleReason- = LHSNotDefinitionOrConstructor- | VariablesNotBoundByLHS IntSet- | VariablesBoundMoreThanOnce IntSet- | LHSReduces Term Term- | HeadSymbolIsProjectionLikeFunction QName- | HeadSymbolIsTypeConstructor QName- | HeadSymbolContainsMetas QName- | ConstructorParametersNotGeneral ConHead Args- | ContainsUnsolvedMetaVariables (Set1 MetaId)- | BlockedOnProblems (Set1 ProblemId)- | RequiresDefinitions (Set1 QName)- | DoesNotTargetRewriteRelation- | BeforeFunctionDefinition- | BeforeMutualFunctionDefinition QName- | DuplicateRewriteRule- deriving (Show, Generic)---- | Boolean flag whether a name is ambiguous.-data IsAmbiguous- = YesAmbiguous AmbiguousQName- | NotAmbiguous- deriving (Show, Generic)---- Reason, why type for rewrite rule is incorrect-data IncorrectTypeForRewriteRelationReason- = ShouldAcceptAtLeastTwoArguments- | FinalTwoArgumentsNotVisible- | TypeDoesNotEndInSort Type Telescope- deriving (Show, Generic)---- | Extra information for error 'CannotQuote'.-data CannotQuote- = CannotQuoteAmbiguous (List2 A.QName)- -- ^ @quote@ is applied to an ambiguous name.- | CannotQuoteExpression A.Expr- -- ^ @quote@ is applied to an expression that is not an unambiguous defined name.- | CannotQuoteHidden- -- ^ @quote@ is applied to a non-visible argument.- | CannotQuoteNothing- -- ^ @quote@ is unapplied.- | CannotQuotePattern (NamedArg C.Pattern)- -- ^ @quote@ is applied to a pattern that is not an unambiguous defined name.- deriving (Show, Generic)---- | Distinguish error message when parsing lhs or pattern synonym, resp.-data LHSOrPatSyn = IsLHS | IsPatSyn- deriving (Eq, Show, Generic, Bounded, Enum)---- | 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.- }- | ParserError ParseError- -- ^ Error raised by the Happy parser.- | GenericException String- -- ^ Unspecific error without 'Range'.- | IOException (Maybe 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 = \case- TypeError _ _ e -> prettyShow (envRange $ clEnv e) ++ ": " ++ show (clValue e)- ParserError e -> prettyShow e- GenericException msg -> msg- IOException _ r e -> prettyShow r ++ ": " ++ showIOException e- PatternErr{} -> "Pattern violation (you shouldn't see this)"--instance HasRange TCErr where- getRange (TypeError _ _ cl) = envRange $ clEnv cl- getRange (ParserError e) = getRange e- getRange GenericException{} = noRange- getRange (IOException _ r _) = r- getRange PatternErr{} = noRange--instance E.Exception TCErr---- | Assorted warnings and errors to be displayed to the user-data WarningsAndNonFatalErrors = WarningsAndNonFatalErrors- { tcWarnings :: Set TCWarning- , nonFatalErrors :: Set TCWarning- }--instance Null WarningsAndNonFatalErrors where- null (WarningsAndNonFatalErrors ws errs) = null ws && null errs- empty = WarningsAndNonFatalErrors empty empty---------------------------------------------------------------------------------- * Accessing options--------------------------------------------------------------------------------instance MonadIO m => HasOptions (TCMT m) where- pragmaOptions = useTC stPragmaOptions- {-# INLINE pragmaOptions #-}-- commandLineOptions = do- p <- useTC stPragmaOptions- cl <- stPersistentOptions . stPersistentState <$> getTC- return $ cl { optPragmaOptions = p }- {-# SPECIALIZE commandLineOptions :: TCM CommandLineOptions #-}---- HasOptions lifts through monad transformers--- (see default signatures in the HasOptions class).--sizedTypesOption :: HasOptions m => m Bool-sizedTypesOption = optSizedTypes <$> pragmaOptions-{-# INLINE sizedTypesOption #-}--guardednessOption :: HasOptions m => m Bool-guardednessOption = optGuardedness <$> pragmaOptions-{-# INLINE guardednessOption #-}--withoutKOption :: HasOptions m => m Bool-withoutKOption = optWithoutK <$> pragmaOptions-{-# INLINE withoutKOption #-}--cubicalOption :: HasOptions m => m (Maybe Cubical)-cubicalOption = optCubical <$> pragmaOptions-{-# INLINE cubicalOption #-}--cubicalCompatibleOption :: HasOptions m => m Bool-cubicalCompatibleOption = optCubicalCompatible <$> pragmaOptions-{-# INLINE cubicalCompatibleOption #-}--enableCaching :: HasOptions m => m Bool-enableCaching = optCaching <$> pragmaOptions-{-# INLINE enableCaching #-}---------------------------------------------------------------------------------- * 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) }-{-# INLINE mapRedEnv #-}--mapRedSt :: (TCState -> TCState) -> ReduceEnv -> ReduceEnv-mapRedSt f s = s { redSt = f (redSt s) }-{-# INLINE mapRedSt #-}--mapRedEnvSt :: (TCEnv -> TCEnv) -> (TCState -> TCState) -> ReduceEnv- -> ReduceEnv-mapRedEnvSt f g (ReduceEnv e s p) = ReduceEnv (f e) (g s) p-{-# INLINE mapRedEnvSt #-}---- Lenses-reduceEnv :: Lens' ReduceEnv TCEnv-reduceEnv f s = f (redEnv s) <&> \ e -> s { redEnv = e }-{-# INLINE reduceEnv #-}--reduceSt :: Lens' ReduceEnv TCState-reduceSt f s = f (redSt s) <&> \ e -> s { redSt = e }-{-# INLINE reduceSt #-}--newtype ReduceM a = ReduceM { unReduceM :: ReduceEnv -> a }--- deriving (Functor, Applicative, Monad)--unKleisli :: (a -> ReduceM b) -> ReduceM (a -> b)-unKleisli f = ReduceM $ \ env x -> unReduceM (f x) env--onReduceEnv :: (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a-onReduceEnv f (ReduceM m) = ReduceM (m . f)-{-# INLINE onReduceEnv #-}--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- (>>) = (*>)--instance 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)--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' TCState a -> m a-useR l = do- !x <- getTCState <&> (^. l)- return x-{-# INLINE useR #-}--askR :: ReduceM ReduceEnv-askR = ReduceM ask-{-# INLINE askR #-}--localR :: (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a-localR f = ReduceM . local f . unReduceM-{-# INLINE localR #-}--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--{-# INLINE asksTC #-}-asksTC :: MonadTCEnv m => (TCEnv -> a) -> m a-asksTC f = f <$> askTC--{-# INLINE viewTC #-}-viewTC :: MonadTCEnv m => Lens' TCEnv a -> m a-viewTC l = asksTC (^. l)--{-# INLINE locallyTC #-}--- | Modify the lens-indicated part of the @TCEnv@ in a subcomputation.-locallyTC :: MonadTCEnv m => Lens' TCEnv a -> (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)--{-# INLINE getsTC #-}--- ** @TCState@ accessors (no lenses)-getsTC :: ReadTCState m => (TCState -> a) -> m a-getsTC f = f <$> getTCState--{-# INLINE modifyTC' #-}--- | 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--{-# INLINE useTC #-}-useTC :: ReadTCState m => Lens' TCState a -> m a-useTC l = do- !x <- getsTC (^. l)- return x--infix 4 `setTCLens`--{-# INLINE setTCLens #-}--- | Overwrite the part of the 'TCState' focused on by the lens.-setTCLens :: MonadTCState m => Lens' TCState a -> a -> m ()-setTCLens l = modifyTC . set l--{-# INLINE setTCLens' #-}--- | Overwrite the part of the 'TCState' focused on by the lens--- (strictly).-setTCLens' :: MonadTCState m => Lens' TCState a -> a -> m ()-setTCLens' l = modifyTC' . set l--{-# INLINE modifyTCLens #-}--- | Modify the part of the 'TCState' focused on by the lens.-modifyTCLens :: MonadTCState m => Lens' TCState a -> (a -> a) -> m ()-modifyTCLens l = modifyTC . over l--{-# INLINE modifyTCLens' #-}--- | Modify the part of the 'TCState' focused on by the lens--- (strictly).-modifyTCLens' :: MonadTCState m => Lens' TCState a -> (a -> a) -> m ()-modifyTCLens' l = modifyTC' . over l--{-# INLINE modifyTCLensM #-}--- | Modify a part of the state monadically.------ This is an instance of 'Agda.Utils.Lens.%=='.-modifyTCLensM :: (MonadTCState m, ReadTCState m) => Lens' TCState a -> (a -> m a) -> m ()-modifyTCLensM l f = useTC l >>= f >>= setTCLens l- -- Note:- -- The implementation @getTC >>= l f >>= putTC@ loses state changes- -- contained in @f@, see https://github.com/agda/agda/pull/7470#discussion_r1747232483--{-# INLINE stateTCLens #-}--- | Modify the part of the 'TCState' focused on by the lens, and return some result.-stateTCLens :: (MonadTCState m, ReadTCState m) => Lens' TCState a -> (a -> (r , a)) -> m r-stateTCLens l f = stateTCLensM l $ return . f--{-# INLINE stateTCLensM #-}--- | Modify a part of the state monadically, and return some result.------ This is an instance of 'Agda.Utils.Lens.%%='.-stateTCLensM :: (MonadTCState m, ReadTCState m) => Lens' TCState a -> (a -> m (r , a)) -> m r-stateTCLensM l f = do- a <- useTC l- (result , a') <- f a- result <$ setTCLens l a'--------------------------------------------------------------------------------- ** 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, 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-{-# INLINE runBlocked #-}--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)-{-# INLINE pureTCM #-}---- 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; {-# INLINE fmap #-}--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; {-# INLINE pure #-}- (<*>) = apTCMT; {-# INLINE (<*>) #-}--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; {-# INLINE lift #-}---- We want a special monad implementation of fail.--- 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- return = pure; {-# INLINE return #-}- (>>=) = bindTCMT; {-# INLINE (>>=) #-}- (>>) = (*>); {-# INLINE (>>) #-}--instance (CatchIO m, MonadIO m) => 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 (Just s) r err--instance MonadIO m => MonadTCEnv (TCMT m) where- askTC = TCM $ \ _ e -> return e; {-# INLINE askTC #-}- localTC f (TCM m) = TCM $ \ s e -> m s (f e); {-# INLINE localTC #-}--instance MonadIO m => MonadTCState (TCMT m) where- getTC = TCM $ \ r _e -> liftIO (readIORef r); {-# INLINE getTC #-}- putTC s = TCM $ \ r _e -> liftIO (writeIORef r s); {-# INLINE putTC #-}- modifyTC f = putTC . f =<< getTC; {-# INLINE modifyTC #-}--instance MonadIO m => ReadTCState (TCMT m) where- getTCState = getTC; {-# INLINE getTCState #-}- locallyTCState l f = bracket_ (useTC l <* modifyTCLens l f) (setTCLens l); {-# INLINE locallyTCState #-}--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 (CatchIO m, MonadIO m) => MonadError TCErr (TCMT m) where- throwError = liftIO . E.throwIO- catchError m h = TCM $ \ r e -> do -- now we are in the monad m- oldState <- liftIO $ readIORef r- unTCM m r e `catchIO` \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; {-# INLINE liftReduce #-}--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- {-# INLINE liftTCM #-}--{-# RULES "liftTCM/id" liftTCM = id #-}-instance MonadIO m => MonadTCM (TCMT m) where- liftTCM = mapTCMT liftIO- {-# INLINE liftTCM #-}--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, MonadTCError m) => String -> m a-internalError s = withCallerCallStack $ \ loc ->- 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'_--interactionError :: (HasCallStack, MonadTCError m) => InteractionError -> m a-interactionError = locatedTypeError InteractionError--syntaxError :: (HasCallStack, MonadTCError m) => String -> m a-syntaxError = locatedTypeError SyntaxError--unquoteError :: (HasCallStack, MonadTCError m) => UnquoteError -> m a-unquoteError = locatedTypeError UnquoteFailed--execError :: (HasCallStack, MonadTCError m) => ExecError -> m a-execError = locatedTypeError ExecError---- | 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 =<< initStateIO- 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 () -> TCM ()-forkTCM m = do- s <- getTC- e <- askTC- liftIO $ void $ forkIO $ void $ runTCM e s m-------------------------------------------------------------------------------- * Interaction Callback-------------------------------------------------------------------------------- | Callback fuction to call when there is a response--- to give to the interactive frontend.------ Note that the response is given in pieces and incrementally,--- so the user can have timely response even during long computations.------ Typical 'InteractionOutputCallback' functions:------ * Convert the response into a 'String' representation and--- print it on standard output--- (suitable for inter-process communication).------ * Put the response into a mutable variable stored in the--- closure of the 'InteractionOutputCallback' function.--- (suitable for intra-process communication).--type InteractionOutputCallback = Response_boot TCErr TCWarning WarningsAndNonFatalErrors -> TCM ()---- | The default 'InteractionOutputCallback' function prints certain--- things to stdout (other things generate internal errors).--defaultInteractionOutputCallback :: InteractionOutputCallback-defaultInteractionOutputCallback = \case- Resp_HighlightingInfo {} -> __IMPOSSIBLE__- Resp_Status {} -> __IMPOSSIBLE__- Resp_JumpToError {} -> __IMPOSSIBLE__- Resp_InteractionPoints {} -> __IMPOSSIBLE__- Resp_GiveAction {} -> __IMPOSSIBLE__- Resp_MakeCase {} -> __IMPOSSIBLE__- Resp_SolveAll {} -> __IMPOSSIBLE__- Resp_Mimer {} -> __IMPOSSIBLE__- Resp_DisplayInfo {} -> __IMPOSSIBLE__- Resp_RunningInfo _ s -> liftIO $ do- putStr s- hFlush stdout- Resp_ClearRunningInfo {} -> __IMPOSSIBLE__- Resp_ClearHighlighting {} -> __IMPOSSIBLE__- Resp_DoneAborting {} -> __IMPOSSIBLE__- Resp_DoneExiting {} -> __IMPOSSIBLE__-------------------------------------------------------------------------------- * 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 = List.stripPrefix generalizedFieldName . prettyShow . nameConcrete . qnameName-------------------------------------------------------------------------------- * KillRange instances------------------------------------------------------------------------------instance KillRange Signature where- killRange (Sig secs defs rews inst) = killRangeN Sig secs defs rews inst--instance KillRange InstanceTable where- killRange (InstanceTable tree count) = killRangeN InstanceTable tree count--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) = killRangeN Section tel--instance KillRange InstanceInfo where- killRange :: KillRangeT InstanceInfo- killRange (InstanceInfo a b) = killRangeN InstanceInfo a b--instance KillRange Definition where- killRange (Defn ai name t pols occs gpars displ mut compiled inst copy ma nc inj copat blk lang def) =- killRangeN Defn ai name t pols occs 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) = killRangeN PVar x y- killRange (PDef x y) = killRangeN PDef x y- killRange (PLam x y) = killRangeN PLam x y- killRange (PPi x y) = killRangeN PPi x y- killRange (PSort x) = killRangeN PSort x- killRange (PBoundVar x y) = killRangeN PBoundVar x y- killRange (PTerm x) = killRangeN PTerm x--instance KillRange NLPType where- killRange (NLPType s a) = killRangeN NLPType s a--instance KillRange NLPSort where- killRange (PUniv u l) = killRangeN (PUniv u) l- killRange s@(PInf f n) = s- killRange PSizeUniv = PSizeUniv- killRange PLockUniv = PLockUniv- killRange PLevelUniv = PLevelUniv- killRange PIntervalUniv = PIntervalUniv--instance KillRange RewriteRule where- killRange (RewriteRule q gamma f es rhs t c top) =- killRangeN RewriteRule q gamma f es rhs t c top--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) = killRangeN ExtLamInfo m b sys--instance KillRange FunctionFlag where- killRange = id--instance KillRange CompKit where- killRange = id--instance KillRange ProjectionLikenessMissing where- killRange = id--instance KillRange BuiltinSort where- killRange = id--instance KillRange Defn where- killRange def =- case def of- Axiom a -> Axiom a- DataOrRecSig n -> DataOrRecSig n- GeneralizableVar a -> GeneralizableVar a- AbstractDefn{} -> __IMPOSSIBLE__ -- only returned by 'getConstInfo'!- Function a b c d e f g h i j k l m n ->- killRangeN Function a b c d e f g h i j k l m n- Datatype a b c d e f g h i j -> killRangeN 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 -> killRangeN 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 k -> killRangeN Constructor a b c d e f g h i j k- Primitive a b c d e f -> killRangeN Primitive a b c d e f- PrimitiveSort a b -> killRangeN 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) = killRangeN 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) = killRangeN 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 -> killRangeN DWithApp dt dts es- DCon q ci dts -> killRangeN DCon q ci dts- DDef q dts -> killRangeN DDef q dts- DDot' v es -> killRangeN DDot' v es- DTerm' v es -> killRangeN DTerm' v es--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 (ParserError a) = rnf a- rnf (GenericException a)= rnf a- 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 OpaqueBlock-instance NFData (BiMap RawTopLevelModuleName ModuleNameHash)-instance NFData PersistentTCState-instance NFData SessionTCState-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 InstanceTable-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 InstanceInfo-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-instance NFData ReduceDefs-instance NFData PrimFun-instance NFData c => NFData (FunctionInverse' c)-instance NFData TermHead-instance NFData Call-instance NFData BuiltinSort-instance NFData pf => NFData (Builtin pf)-instance NFData HighlightingLevel-instance NFData HighlightingMethod-instance NFData TCEnv-instance NFData LetBinding-instance NFData UnquoteFlags-instance NFData AbstractMode-instance NFData ExpandHidden-instance NFData CandidateKind-instance NFData Candidate-instance NFData Warning-instance NFData RecordFieldWarning-instance NFData TCWarning-instance NFData CallInfo-instance NFData TerminationError-instance NFData SplitError-instance NFData NegativeUnification-instance NFData UnificationFailure-instance NFData UnquoteError-instance NFData TypeError-instance NFData WhyInvalidInstanceType-instance NFData InvalidFileNameReason-instance NFData LHSOrPatSyn-instance NFData InductionAndEta-instance NFData IllegalRewriteRuleReason-instance NFData IncorrectTypeForRewriteRelationReason-instance NFData GHCBackendError-instance NFData JSBackendError-instance NFData MissingTypeSignatureInfo-instance NFData WhyNotAHaskellType-instance NFData InteractionError-instance NFData IsAmbiguous-instance NFData CannotQuote-instance NFData ExecError-instance NFData ConstructorDisambiguationData+-- Turning off DeepSubsumption for+-- SPECIALIZE mapTCMT :: (forall a. IO a -> IO a) -> TCM a -> TCM a+-- with GHC 9.14+{-# LANGUAGE NoDeepSubsumption #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UnboxedTuples #-}++module Agda.TypeChecking.Monad.Base+ ( module Agda.TypeChecking.Monad.Base+ , module Agda.TypeChecking.Monad.Base.Types+ , module X+ , module Agda.Utils.Lens+ , HasOptions (..)+ , RecordFieldWarning+ , UselessPublicReason(..)+ ) where++import Prelude hiding (null)++import Control.Applicative hiding (empty)+import Control.Concurrent (forkIO)+import Control.DeepSeq+import qualified Control.Exception as E++import qualified Control.Monad.Catch as Catch+import Control.Monad.Except ( MonadError(..), ExceptT(..), runExceptT )+import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Monad.State ( MonadState(..), modify, StateT(..), runStateT, evalStateT )+import Control.Monad.Reader ( MonadReader(..), ReaderT(..), runReaderT )+import Control.Monad.Writer ( WriterT(..), runWriterT )+import Control.Monad.Trans ( MonadTrans(..), lift )+import Control.Monad.Trans.Control ( MonadTransControl(..), liftThrough, MonadBaseControl )+import Control.Monad.Trans.Identity ( IdentityT(..), runIdentityT )+import Control.Monad.Trans.Maybe ( MaybeT(..) )++import Control.Parallel ( pseq )++import Data.Array (Ix)+import Data.Function (on)+import Data.Bits+import Data.Word+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import qualified Data.List as List+import Data.Maybe+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map -- hiding (singleton, null, empty)+import Data.Sequence (Seq)+import Data.Set (Set, toList, fromList)+import qualified Data.Set as Set -- hiding (singleton, null, empty)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HMap+import qualified Data.HashSet as HashSet+import Data.Hashable+import Data.HashSet (HashSet)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.String+import Data.Text (Text)+import qualified Data.Text.Lazy as TL+import Data.Semigroup (Sum, Max)++import GHC.Generics (Generic)+import GHC.Exts (oneShot, MutVar#, RealWorld)+import GHC.IORef (IORef(..))+import GHC.STRef (STRef(..))++import System.IO (hFlush, stdout)++import Agda.Benchmarking (Benchmark, Phase)++import Agda.Compiler.Backend.Base (Backend_boot, Backend'_boot)+import {-# SOURCE #-} Agda.Compiler.Treeless.Pretty () -- Instances only++import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty+import Agda.Syntax.Common.Pretty.ANSI (putDocTreeLn)+import Agda.Syntax.Builtin (SomeBuiltin, BuiltinId, PrimitiveId)+import qualified Agda.Syntax.Concrete as C+import Agda.Syntax.Concrete.Definitions+ (NiceDeclaration, DeclarationWarning, declarationWarningName)+import Agda.Syntax.Concrete.Definitions.Errors+ (DeclarationException')+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.Monad (ParseError, ParseWarning, 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 Agda.Syntax.Info ( MetaKind(InstanceMeta, UnificationMeta), MetaNameSuggestion, MutualInfo )++import Agda.TypeChecking.Monad.Base.Types+import Agda.TypeChecking.Monad.Base.Warning qualified as W+import Agda.TypeChecking.Monad.Base.Warning (RecordFieldWarning, UselessPublicReason(..))+import Agda.TypeChecking.SizedTypes.Syntax (HypSizeConstraint)++import Agda.TypeChecking.CompiledClause+import {-# SOURCE #-} Agda.TypeChecking.Conversion.Errors+import Agda.TypeChecking.Coverage.SplitTree+import Agda.TypeChecking.Positivity.Occurrence+import Agda.TypeChecking.Positivity.Warnings qualified as W+import Agda.TypeChecking.Free++import Agda.TypeChecking.DiscrimTree.Types++import Agda.Termination.Termination (GuardednessHelps(..))++import Agda.Interaction.Options+import Agda.Interaction.Options.Errors qualified as ErrorName+import Agda.Interaction.Options.Errors as X+ ( CannotQuoteTerm(..)+ , ErasedDatatypeReason(..)+ , NotAValidLetBinding(..)+ , NotAValidLetExpression(..)+ , NotAllowedInDotPatterns(..)+ )+import Agda.Interaction.Options.Warnings+import Agda.Interaction.Response.Base (Response_boot(..))+import Agda.Interaction.Highlighting.Precise+ (HighlightingInfo, NameKind)+import Agda.Interaction.Library+import Agda.Interaction.Library.Base ( ExeName, ExeMap, LibCache, LibErrors )++import Agda.Utils.Benchmark (MonadBench(..))+import Agda.Utils.BiMap (BiMap, HasTag(..))+import Agda.Utils.BiMap qualified as BiMap+import Agda.Utils.Boolean ( Boolean, IsBool, fromBool, toBool )+import Agda.Utils.CallStack ( CallStack, HasCallStack, withCallerCallStack )+import Agda.Utils.ExpandCase+import Agda.Utils.FileId ( FileDictBuilder, GetFileId(getFileId), GetIdFile(getIdFile) )+import Agda.Utils.FileId as X ( FileId, MonadFileId( idFromFile, fileFromId ) )+import Agda.Utils.FileName+import Agda.Utils.Functor+import Agda.Utils.Hash+import Agda.Utils.IO ( CatchIO, catchIO, showIOException )+import Agda.Utils.IORef.Strict qualified as Strict+import Agda.Utils.Lens+import Agda.Utils.List+import Agda.Utils.List1 (List1, pattern (:|))+import Agda.Utils.List1 qualified as List1+import Agda.Utils.List2 (List2, pattern List2)+import Agda.Utils.ListT+import Agda.Utils.Maybe.Strict qualified as Strict+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.Permutation+import Agda.Utils.Set1 (Set1)+import Agda.Utils.Singleton+import Agda.Utils.SmallSet (SmallSet, SmallSetElement)+import Agda.Utils.SmallSet qualified as SmallSet+import Agda.Utils.Tuple (Pair, (&&&) )+import Agda.Utils.Update+import Agda.Utils.VarSet (VarSet)+import Agda.Utils.VarSet qualified as VarSet+import Agda.Utils.Atomic+import Agda.Utils.StrictReader qualified as Strict+import Agda.Utils.StrictWriter qualified as Strict+import Agda.Utils.StrictState qualified as Strict+import Agda.Utils.Tuple.Strict qualified as Strict++import Agda.Utils.Impossible++----------------------------------------------------------------------------------------------------+-- * Type checking state+----------------------------------------------------------------------------------------------------++data TCState = TCSt+ { stPersistentState :: !PersistentTCState+ -- ^ State which persists while we build an Agda project (same main file).+ , stPreScopeState :: !PreScopeState+ -- ^ The state which is frozen after scope checking.+ , stPostScopeState :: !PostScopeState+ -- ^ The state which is modified after scope checking.+ }+ deriving Generic++-- | Class for monads which offer scoped access to the 'TCState', as+-- well as read-only access to the 'SessionState'.+class Monad m => ReadTCState m where+ -- | Read the current 'TCState'.+ getTCState :: m TCState++ -- | Scoped modification of the 'TCState': run the continuation where+ -- the part of the state targeted by the lens has its value altered by+ -- the given function, without modifying the state in the "enclosing"+ -- thread.+ locallyTCState :: Lens' TCState a -> (a -> a) -> m b -> m b++ -- | Read the current 'SessionState'.+ --+ -- Since the 'SessionState' is shared between threads, it is unwise to+ -- hold onto the result of this function for very long.+ getSessionState :: m SessionState++ withTCState :: (TCState -> TCState) -> m a -> m a+ withTCState = locallyTCState id++ {-# INLINE getTCState #-}+ default getTCState :: (MonadTrans t, ReadTCState n, t n ~ m) => m TCState+ getTCState = lift getTCState++ {-# INLINE locallyTCState #-}+ default locallyTCState+ :: (MonadTransControl t, ReadTCState n, t n ~ m)+ => Lens' TCState a -> (a -> a) -> m b -> m b+ locallyTCState l = liftThrough . locallyTCState l++ {-# INLINE getSessionState #-}+ default getSessionState :: (MonadTrans t, ReadTCState n, t n ~ m) => m SessionState+ getSessionState = lift getSessionState++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 ReadTCState m => ReadTCState (Strict.ReaderT r m)+instance ReadTCState m => ReadTCState (Strict.StateT s m)+instance (Monoid w, ReadTCState m) => ReadTCState (Strict.WriterT w m)++instance Show TCState where+ show _ = "TCSt{}"++type Backend = Backend_boot Definition TCM+type Backend' opts env menv mod def = Backend'_boot Definition TCM opts env menv mod def++type BackendForeignCode = Map BackendName ForeignCodeStack+type ImportedModules = Set TopLevelModuleName+type UserWarnings = Map QName Text++data PreScopeState = PreScopeState+ { stPreFileId :: !(Strict.Maybe FileId)+ -- ^ The file being type-checked, if any.+ , 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 must not be serialized!+ , stPreImportedModules :: !ImportedModules+ -- Andreas, 2023-08-05, issue #6750, don't make this a 'HashSet'+ -- because then the order of its @toList@ is undefined,+ -- leading to undefined deserialization order.+ -- ^ The top-level modules imported by the current module.+ , stPreImportedModulesTransitive :: !ImportedModules+ -- ^ The top-level modules transitively imported by the current module.+ , stPreVisitedModules :: !VisitedModules -- imports+ -- ^ Modules loaded so far.+ -- In contrast 'stDecodedModules', contains also modules that are only scope-checked.+ , 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 variables we wish to generalize over; used during scope checking of terms.+ -- If 'Nothing', we are in a position where we do not support generalization,+ -- and do not accept additions to this collection.+ , stPrePragmaOptions :: !PragmaOptions+ -- ^ Options applying to the current file. @OPTIONS@+ -- pragmas only affect this field.+ , stPreImportedBuiltins :: !BuiltinThings+ , stPreImportedDisplayForms :: !DisplayForms+ -- ^ Display forms added by someone else to imported identifiers+ , stPreFreshInteractionId :: !InteractionId+ , stPreImportedUserWarnings :: !UserWarnings+ -- ^ Imported @UserWarning@s, not to be stored in the @Interface@+ , stPreLocalUserWarnings :: !UserWarnings+ -- ^ 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@+ , stPreLibCache :: !LibCache+ -- ^ Cached @.agda-lib@ files.+ , stPreImportedMetaStore :: !RemoteMetaStore+ -- ^ Used for meta-variables from other modules.+ , stPreCopiedNames :: !(HashMap A.QName A.QName)+ -- ^ Associates a copied name (the key) to its original name (the+ -- value). Computed by the scope checker, used to compute opaque+ -- blocks.+ , stPreNameCopies :: !(HashMap A.QName (HashSet A.QName))+ -- ^ Associates an original name (the key) to all its copies (the+ -- value). Computed by the scope checker, used to compute opaque+ -- blocks.+ , stPreUnusedImportsState :: !UnusedImportsState+ -- ^ Information collected by the scope checker to generate warnings about unused imports.+ }+ deriving Generic++-- | Name disambiguation for the sake of highlighting.+data DisambiguatedName = DisambiguatedName NameKind A.QName+ deriving Generic++-- | Name from file position of occurrence to disambiguation.+type DisambiguatedNames = IntMap DisambiguatedName+type ConcreteNames = Map Name (List1 C.Name)++data PostNamesCheckpoints = PostNamesCheckpoints {+ stPostModuleCheckpoints :: !ModuleCheckpoints+ -- ^ For each module remember the checkpoint corresponding to the orignal+ -- context of the module parameters.+ , stPostFreshCheckpointId :: !CheckpointId+ } deriving (Generic)++data PostMetaState = PostMetaState {+ stPostFreshMetaId :: !MetaId+ , stPostFreshProblemId :: !ProblemId+ , stPostOpenMetaStore :: !LocalMetaStore+ -- ^ Used for open meta-variables.+ , stPostSolvedMetaStore :: !LocalMetaStore+ -- ^ Used for local, instantiated meta-variables.+ , stPostAwakeConstraints :: !Constraints+ , stPostSleepingConstraints :: !Constraints+ , 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.+ } deriving (Generic)++data PostColdState = PostColdState+ { stPostFlags :: !Flags64+ , 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.+ , stPostInteractionPoints :: !InteractionPoints -- scope checker first+ , stPostSignature :: !Signature+ -- ^ Declared identifiers of the current file.+ -- These will be serialized after successful type checking.+ , stPostImportsDisplayForms :: !DisplayForms+ -- ^ Display forms we add for imported identifiers+ , stPostForeignCode :: !BackendForeignCode+ -- ^ @{-\# FOREIGN \#-}@ code that should be included in the compiled output.+ -- Does not include code for imported modules.+ , stPostCurrentModule :: !(Strict.Maybe (Strict.Pair ModuleName TopLevelModuleName))+ -- ^ The current module is available after it has been type+ -- checked.+ , stPostPendingInstances :: !(Set QName)+ , stPostTemporaryInstances :: !(Set QName)+ , 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)+ , stPostStatistics :: !Statistics+ -- ^ Counters to collect various statistics about meta variables etc.+ -- Only for current file.+ , stPostTCWarnings :: !(Set TCWarning)+ , stPostMutualBlocks :: !MutualBlocks+ , stPostLocalBuiltins :: !BuiltinThings+ , stPostFreshMutualId :: !MutualId+ , stPostFreshInt :: !Int+ , stPostFreshNameId :: !NameId+ , stPostFreshOpaqueId :: !OpaqueId+ , stPostLocalPartialDefs :: !(Set QName)+ -- ^ Local partial definitions, to be stored in the @Interface@+ , stPostOpaqueBlocks :: !(Map OpaqueId OpaqueBlock)+ -- ^ Associates opaque identifiers to their actual blocks.+ , stPostOpaqueIds :: !(Map QName OpaqueId)+ -- ^ Associates each opaque QName to the block it was defined in.+ } deriving (Generic)++-- Flags+----------------------------------------------------------------------------------------------------++-- ^ Dirty when a constraint is added, used to prevent pointer update.+-- Currently unused.+{-# INLINE stPostDirty #-}+stPostDirty :: Lens' Flags64 Bool+stPostDirty = mkFlag 0++{-# INLINE stPostAreWeCaching #-}+stPostAreWeCaching :: Lens' Flags64 Bool+stPostAreWeCaching = mkFlag 1++{-# INLINE stPostPostponeInstanceSearch #-}+stPostPostponeInstanceSearch :: Lens' Flags64 Bool+stPostPostponeInstanceSearch = mkFlag 2++{-# INLINE stPostConsideringInstance #-}+stPostConsideringInstance :: Lens' Flags64 Bool+stPostConsideringInstance = mkFlag 3++-- | 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.+{-# INLINE stPostInstantiateBlocking #-}+stPostInstantiateBlocking :: Lens' Flags64 Bool+stPostInstantiateBlocking = mkFlag 4++{-# INLINE stPostInstanceHack #-}+-- ^ Is this a context where we should always try every possible+-- instance candidate? Used to support "inert improvement", see+-- @shouldBlockOverlap@ in InstanceArguments.+stPostInstanceHack :: Lens' Flags64 Bool+stPostInstanceHack = mkFlag 5++----------------------------------------------------------------------------------------------------++data PostScopeState = PostScopeState {+ stPostNamesCheckpoints :: !PostNamesCheckpoints+ , stPostMetaState :: !PostMetaState+ , stPostColdState :: !PostColdState+ } deriving (Generic)++-- | A part of the state that grows monotonically over the whole Agda session.+-- Shared between all threads, and never reset.+data SessionState = SessionState+ { stSessionBackends :: [Backend]+ -- ^ Backends with their options.+ , stSessionFileDict :: !FileDictWithBuiltins+ -- ^ Map file names to unique 'FileId' and back.+ -- Assuming we do not see terribly many different files during one Agda session,+ -- this map needs not be garbage-collected.+ --+ -- Also informs about whether a 'FileId' belongs to one of+ -- Agda's primitive and builtin modules.++ , stSessionModuleToSourceId :: !ModuleToSourceId+ -- ^ Maps 'TopLevelModuleNames' to the 'FileId's from which they+ -- were loaded.+ , stSessionInteractionOutputCallback :: InteractionOutputCallback+ -- ^ Callback function to call when there is a response+ -- to give to the interactive frontend.+ -- See the documentation of 'InteractionOutputCallback'.+ -- Set by the interactor (Terminal (default), Emacs, JSON),+ -- remaining fixed throughout the session.+ }+ deriving (Generic)++-- | A part of the state which is not reverted when an error is thrown+-- or the state is reset.+data PersistentTCState = PersistentTCSt+ { stPersistentSession :: !(Atomic SessionState)+ -- ^ State that persists for the whole Agda session.+ -- Grows monotonically, never sees any deletion.+ , stDecodedModules :: !DecodedModules+ -- ^ Type-checked modules we visited during our Agda session.+ -- A module gets dropped from this list if its source+ -- or the source of any of its dependencies changed,+ -- or when its identity or the identity of one of its dependencies changed+ -- due to a change of the include paths.+ , stPersistentTopLevelModuleNames ::+ !(BiMap RawTopLevelModuleName ModuleNameHash)+ -- ^ Module name hashes for top-level module names (and vice+ -- versa).+ , stPersistentOptions :: CommandLineOptions+ , stAccumStatistics :: !Statistics+ -- ^ Should be strict field.+ , stPersistLoadedFileCache :: !(Strict.Maybe LoadedFileCache)+ -- ^ Cached typechecking state from the last loaded file.+ -- Should be @Nothing@ when checking imports.+ }+ 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 !Erased !ModuleName !A.Telescope+ | LeaveSection !ModuleName+ | Decl !A.Declaration+ -- ^ Never a Section or ScopeDecl+ | Pragmas !PragmaOptions+ deriving (Generic)+++-- | Empty session state.++initFileDict :: AbsolutePath -> FileDictWithBuiltins+initFileDict primLibDir = FileDictWithBuiltins empty empty primLibDir++initSessionState :: AbsolutePath -> SessionState+initSessionState primLibDir = SessionState+ { stSessionFileDict = initFileDict primLibDir+ , stSessionBackends = empty+ , stSessionModuleToSourceId = empty+ , stSessionInteractionOutputCallback = defaultInteractionOutputCallback+ }++-- | Empty persistent state.++initPersistentStateFromSessionState :: Atomic SessionState -> PersistentTCState+initPersistentStateFromSessionState s = PersistentTCSt+ { stPersistentSession = s+ , stPersistentOptions = defaultOptions+ , stPersistentTopLevelModuleNames = empty+ , stDecodedModules = Map.empty+ , stAccumStatistics = empty+ , stPersistLoadedFileCache = empty+ }++-- | An initial 'MetaId'.++initialMetaId :: MetaId+initialMetaId = MetaId+ { metaId = 0+ , metaModule = noModuleNameHash+ }++-- | Empty state of type checker.++initPreScopeState :: PreScopeState+initPreScopeState = PreScopeState+ { stPreFileId = empty+ , stPreTokens = mempty+ , stPreImports = emptySignature+ , stPreImportedModules = empty+ , stPreImportedModulesTransitive = empty+ , stPreVisitedModules = Map.empty+ , stPreScope = emptyScopeInfo+ , stPrePatternSyns = Map.empty+ , stPrePatternSynImports = Map.empty+ , stPreGeneralizedVars = mempty+ , stPrePragmaOptions = defaultInteractionOptions+ , stPreImportedBuiltins = Map.empty+ , stPreImportedDisplayForms = HMap.empty+ , stPreFreshInteractionId = 0+ , stPreImportedUserWarnings = Map.empty+ , stPreLocalUserWarnings = Map.empty+ , stPreWarningOnImport = empty+ , stPreImportedPartialDefs = Set.empty+ , stPreLibCache = empty+ , stPreImportedMetaStore = HMap.empty+ , stPreCopiedNames = HMap.empty+ , stPreNameCopies = HMap.empty+ , stPreUnusedImportsState = empty+ }+++initPostNamesCheckpoints :: PostNamesCheckpoints+initPostNamesCheckpoints = PostNamesCheckpoints+ { stPostModuleCheckpoints = ModuleCheckpointsTop+ , stPostFreshCheckpointId = 1+ }++initPostMetaState :: PostMetaState+initPostMetaState = PostMetaState+ { stPostFreshMetaId = initialMetaId+ , stPostFreshProblemId = 1+ , stPostOpenMetaStore = Map.empty+ , stPostSolvedMetaStore = Map.empty+ , stPostAwakeConstraints = []+ , stPostSleepingConstraints = []+ , stPostOccursCheckDefs = Set.empty+ }++initPostFlags :: Flags64+initPostFlags = Flags64 0+ & stPostDirty .~ False+ & stPostAreWeCaching .~ False+ & stPostPostponeInstanceSearch .~ False+ & stPostConsideringInstance .~ False+ & stPostInstantiateBlocking .~ False+ & stPostInstanceHack .~ False++initPostColdState :: PostColdState+initPostColdState = PostColdState+ { stPostFlags = initPostFlags+ , stPostSyntaxInfo = mempty+ , stPostDisambiguatedNames = IntMap.empty+ , stPostInteractionPoints = empty+ , stPostSignature = emptySignature+ , stPostImportsDisplayForms = HMap.empty+ , stPostCurrentModule = empty+ , stPostPendingInstances = Set.empty+ , stPostTemporaryInstances = Set.empty+ , stPostConcreteNames = Map.empty+ , stPostStatistics = empty+ , stPostTCWarnings = empty+ , stPostMutualBlocks = empty+ , stPostLocalBuiltins = Map.empty+ , stPostFreshMutualId = 0+ , stPostFreshInt = 0+ , stPostFreshNameId = NameId 0 noModuleNameHash+ , stPostFreshOpaqueId = OpaqueId 0 noModuleNameHash+ , stPostLocalPartialDefs = Set.empty+ , stPostOpaqueBlocks = Map.empty+ , stPostOpaqueIds = Map.empty+ , stPostForeignCode = Map.empty+ }++initPostScopeState :: PostScopeState+initPostScopeState = PostScopeState+ { stPostNamesCheckpoints = initPostNamesCheckpoints+ , stPostMetaState = initPostMetaState+ , stPostColdState = initPostColdState+ }++initStateIO :: IO TCState+initStateIO = initState =<< getPrimitiveLibDir++initState :: AbsolutePath -> IO TCState+initState fp = initStateFromSessionState <$> newAtomic (initSessionState fp)++initStateFromSessionState :: Atomic SessionState -> TCState+initStateFromSessionState = initStateFromPersistentState . initPersistentStateFromSessionState++initStateFromPersistentState :: PersistentTCState -> TCState+initStateFromPersistentState s = TCSt+ { stPersistentState = s+ , stPreScopeState = initPreScopeState+ , stPostScopeState = initPostScopeState+ }++-- * Lenses for 'TCState'++-- ** Components of 'TCState'++{-# INLINE lensPersistentState #-}+lensPersistentState :: Lens' TCState PersistentTCState+lensPersistentState = \f s -> f (stPersistentState s) <&> \ x -> s { stPersistentState = x }++{-# INLINE lensPreScopeState #-}+lensPreScopeState :: Lens' TCState PreScopeState+lensPreScopeState = \f s -> f (stPreScopeState s) <&> \ x -> s { stPreScopeState = x }++{-# INLINE lensPostScopeState #-}+lensPostScopeState :: Lens' TCState PostScopeState+lensPostScopeState = \f s -> f (stPostScopeState s) <&> \ x -> s { stPostScopeState = x }++-- ** Components of 'SessionState'++lensBackends :: Lens' SessionState [Backend]+lensBackends f s = f (stSessionBackends s) <&> \ x -> s { stSessionBackends = x }++lensFileDict :: Lens' SessionState FileDictWithBuiltins+lensFileDict f s = f (stSessionFileDict s) <&> \ x -> s { stSessionFileDict = x }++lensModuleToSourceId :: Lens' SessionState ModuleToSourceId+lensModuleToSourceId f s = f (stSessionModuleToSourceId s) <&> \ x -> s { stSessionModuleToSourceId = x }++lensFileDictBuilder :: Lens' SessionState FileDictBuilder+lensFileDictBuilder = lensFileDict . lensFileDictFileDictBuilder++lensBuiltinModuleIds :: Lens' SessionState BuiltinModuleIds+lensBuiltinModuleIds = lensFileDict . lensFileDictBuiltinModuleIds++lensPrimitiveLibDir :: Lens' SessionState PrimitiveLibDir+lensPrimitiveLibDir = lensFileDict . lensFileDictPrimitiveLibDir++lensInteractionOutputCallback :: Lens' SessionState InteractionOutputCallback+lensInteractionOutputCallback f s = f (stSessionInteractionOutputCallback s) <&> \ x -> s { stSessionInteractionOutputCallback = x }++-- ** Components of 'PersistentTCState'++lensPersistentSession :: Lens' PersistentTCState (Atomic SessionState)+lensPersistentSession f s = f (stPersistentSession s) <&> \ x -> s { stPersistentSession = x }++lensLoadedFileCache :: Lens' PersistentTCState (Strict.Maybe LoadedFileCache)+lensLoadedFileCache f s = f (stPersistLoadedFileCache s) <&> \ x -> s { stPersistLoadedFileCache = x }++lensTopLevelModuleNames :: Lens' PersistentTCState (BiMap RawTopLevelModuleName ModuleNameHash)+lensTopLevelModuleNames f s =+ f (stPersistentTopLevelModuleNames s) <&> \ x -> s { stPersistentTopLevelModuleNames = x }++-- ** Components of 'PreScopeState'++lensPreFileId :: Lens' PreScopeState (Strict.Maybe FileId)+lensPreFileId f s = f (stPreFileId s) <&> \x -> s { stPreFileId = x }++lensPreTokens :: Lens' PreScopeState HighlightingInfo+lensPreTokens f s = f (stPreTokens s) <&> \ x -> s { stPreTokens = x }++lensImports :: Lens' PreScopeState Signature+lensImports f s = f (stPreImports s) <&> \ x -> s { stPreImports = x }++lensImportedModules :: Lens' PreScopeState ImportedModules+lensImportedModules f s = f (stPreImportedModules s) <&> \ x -> s { stPreImportedModules = x }++lensImportedModulesTransitive :: Lens' PreScopeState ImportedModules+lensImportedModulesTransitive f s = f (stPreImportedModulesTransitive s) <&> \ x -> s { stPreImportedModulesTransitive = x }++lensVisitedModules :: Lens' PreScopeState VisitedModules+lensVisitedModules f s = f (stPreVisitedModules s ) <&> \ x -> s { stPreVisitedModules = x }++lensScope :: Lens' PreScopeState ScopeInfo+lensScope f s = f (stPreScope s ) <&> \ x -> s { stPreScope = x }++lensPatternSyns :: Lens' PreScopeState A.PatternSynDefns+lensPatternSyns f s = f (stPrePatternSyns s ) <&> \ x -> s { stPrePatternSyns = x }++lensPatternSynImports :: Lens' PreScopeState A.PatternSynDefns+lensPatternSynImports f s = f (stPrePatternSynImports s ) <&> \ x -> s { stPrePatternSynImports = x }++lensGeneralizedVars :: Lens' PreScopeState (Strict.Maybe (Set QName))+lensGeneralizedVars f s = f (stPreGeneralizedVars s ) <&> \ x -> s { stPreGeneralizedVars = x }++instance LensPragmaOptions PreScopeState where+ {-# INLINE lensPragmaOptions #-}+ lensPragmaOptions = \f s -> f (stPrePragmaOptions s ) <&> \ x -> s { stPrePragmaOptions = x }++lensImportedBuiltins :: Lens' PreScopeState BuiltinThings+lensImportedBuiltins f s = f (stPreImportedBuiltins s ) <&> \ x -> s { stPreImportedBuiltins = x }++lensFreshInteractionId :: Lens' PreScopeState InteractionId+lensFreshInteractionId f s = f (stPreFreshInteractionId s ) <&> \ x -> s { stPreFreshInteractionId = x }++lensImportedUserWarnings :: Lens' PreScopeState UserWarnings+lensImportedUserWarnings f s = f (stPreImportedUserWarnings s ) <&> \ x -> s { stPreImportedUserWarnings = x }++lensLocalUserWarnings :: Lens' PreScopeState UserWarnings+lensLocalUserWarnings f s = f (stPreLocalUserWarnings s ) <&> \ x -> s { stPreLocalUserWarnings = x }++lensWarningOnImport :: Lens' PreScopeState (Strict.Maybe Text)+lensWarningOnImport f s = f (stPreWarningOnImport s) <&> \ x -> s { stPreWarningOnImport = x }++lensImportedPartialDefs :: Lens' PreScopeState (Set QName)+lensImportedPartialDefs f s = f (stPreImportedPartialDefs s) <&> \ x -> s { stPreImportedPartialDefs = x }++lensLibCache :: Lens' PreScopeState LibCache+lensLibCache f s = f (stPreLibCache s) <&> \ x -> s { stPreLibCache = x }++lensImportedMetaStore :: Lens' PreScopeState RemoteMetaStore+lensImportedMetaStore f s = f (stPreImportedMetaStore s) <&> \x -> s { stPreImportedMetaStore = x }++lensCopiedNames :: Lens' PreScopeState (HashMap QName QName)+lensCopiedNames f s = f (stPreCopiedNames s) <&> \ x -> s { stPreCopiedNames = x }++lensNameCopies :: Lens' PreScopeState (HashMap QName (HashSet QName))+lensNameCopies f s = f (stPreNameCopies s) <&> \ x -> s { stPreNameCopies = x }++lensUnusedImportsState :: Lens' PreScopeState UnusedImportsState+lensUnusedImportsState f s = f (stPreUnusedImportsState s) <&> \ !x -> s { stPreUnusedImportsState = x }++{-# INLINE lensImportedDisplayForms #-}+lensImportedDisplayForms :: Lens' PreScopeState DisplayForms+lensImportedDisplayForms = \f s -> f (stPreImportedDisplayForms s) <&> \ x -> s {stPreImportedDisplayForms = x}+++-- ** Components of PostScopeState++{-# INLINE lensCurrentModule #-}+lensCurrentModule :: Lens' PostScopeState (Strict.Maybe (Strict.Pair ModuleName TopLevelModuleName))+lensCurrentModule = \f s ->+ f (stPostCurrentModule $ stPostColdState s) <&> \ x -> s { stPostColdState = (stPostColdState s) {stPostCurrentModule = x}}++{-# INLINE lensForeignCode #-}+lensForeignCode :: Lens' PostScopeState BackendForeignCode+lensForeignCode = \f s ->+ f (stPostForeignCode $ stPostColdState s) <&> \ x -> s { stPostColdState = (stPostColdState s) {stPostForeignCode = x}}++{-# INLINE lensLocalPartialDefs #-}+lensLocalPartialDefs :: Lens' PostScopeState (Set QName)+lensLocalPartialDefs = \f s ->+ f (stPostLocalPartialDefs $ stPostColdState s) <&> \ x -> s { stPostColdState = (stPostColdState s) {stPostLocalPartialDefs = x}}++{-# INLINE lensFreshNameId #-}+lensFreshNameId :: Lens' PostScopeState NameId+lensFreshNameId = \f s ->+ f (stPostFreshNameId $ stPostColdState s) <&> \ x -> s { stPostColdState = (stPostColdState s) {stPostFreshNameId = x}}++{-# INLINE lensFreshOpaqueId #-}+lensFreshOpaqueId :: Lens' PostScopeState OpaqueId+lensFreshOpaqueId = \f s ->+ f (stPostFreshOpaqueId $ stPostColdState s) <&> \ x -> s { stPostColdState = (stPostColdState s) {stPostFreshOpaqueId = x}}++{-# INLINE lensOpaqueBlocks #-}+lensOpaqueBlocks :: Lens' PostScopeState (Map OpaqueId OpaqueBlock)+lensOpaqueBlocks = \f s ->+ f (stPostOpaqueBlocks $ stPostColdState s) <&> \ x -> s { stPostColdState = (stPostColdState s) {stPostOpaqueBlocks = x}}++{-# INLINE lensOpaqueIds #-}+lensOpaqueIds :: Lens' PostScopeState (Map QName OpaqueId)+lensOpaqueIds = \f s ->+ f (stPostOpaqueIds $ stPostColdState s) <&> \ x -> s { stPostColdState = (stPostColdState s) {stPostOpaqueIds = x}}++{-# INLINE lensSyntaxInfo #-}+lensSyntaxInfo :: Lens' PostScopeState HighlightingInfo+lensSyntaxInfo = \f s ->+ f (stPostSyntaxInfo $ stPostColdState s) <&> \ x -> s { stPostColdState = (stPostColdState s) {stPostSyntaxInfo = x}}++{-# INLINE lensDisambiguatedNames #-}+lensDisambiguatedNames :: Lens' PostScopeState DisambiguatedNames+lensDisambiguatedNames = \f s ->+ f (stPostDisambiguatedNames $ stPostColdState s) <&> \ x -> s { stPostColdState = (stPostColdState s) {stPostDisambiguatedNames = x}}++{-# INLINE lensOpenMetaStore #-}+lensOpenMetaStore :: Lens' PostScopeState LocalMetaStore+lensOpenMetaStore = \f s ->+ f (stPostOpenMetaStore $ stPostMetaState s) <&> \ x -> s { stPostMetaState = (stPostMetaState s) {stPostOpenMetaStore = x}}++{-# INLINE lensSolvedMetaStore #-}+lensSolvedMetaStore :: Lens' PostScopeState LocalMetaStore+lensSolvedMetaStore = \f s ->+ f (stPostSolvedMetaStore $ stPostMetaState s) <&> \ x -> s { stPostMetaState = (stPostMetaState s) {stPostSolvedMetaStore = x}}++{-# INLINE lensInteractionPoints #-}+lensInteractionPoints :: Lens' PostScopeState InteractionPoints+lensInteractionPoints = \f s ->+ f (stPostInteractionPoints $ stPostColdState s) <&> \ x -> s { stPostColdState = (stPostColdState s) {stPostInteractionPoints = x}}++{-# INLINE lensAwakeConstraints #-}+lensAwakeConstraints :: Lens' PostScopeState Constraints+lensAwakeConstraints = \f s ->+ f (stPostAwakeConstraints $ stPostMetaState s) <&> \ x -> s { stPostMetaState = (stPostMetaState s) {stPostAwakeConstraints = x}}++{-# INLINE lensSleepingConstraints #-}+lensSleepingConstraints :: Lens' PostScopeState Constraints+lensSleepingConstraints = \f s ->+ f (stPostSleepingConstraints $ stPostMetaState s) <&> \ x -> s { stPostMetaState = (stPostMetaState s) {stPostSleepingConstraints = x}}++{-# INLINE lensOccursCheckDefs #-}+lensOccursCheckDefs :: Lens' PostScopeState (Set QName)+lensOccursCheckDefs = \f s ->+ f (stPostOccursCheckDefs $ stPostMetaState s) <&> \ x -> s { stPostMetaState = (stPostMetaState s) {stPostOccursCheckDefs = x}}++{-# INLINE lensSignature #-}+lensSignature :: Lens' PostScopeState Signature+lensSignature = \f s ->+ f (stPostSignature $ stPostColdState s) <&> \ x -> s { stPostColdState = (stPostColdState s) {stPostSignature = x}}++{-# INLINE lensModuleCheckpoints #-}+lensModuleCheckpoints :: Lens' PostScopeState ModuleCheckpoints+lensModuleCheckpoints = \f s ->+ f (stPostModuleCheckpoints $ stPostNamesCheckpoints s) <&> \ x -> s { stPostNamesCheckpoints = (stPostNamesCheckpoints s) {stPostModuleCheckpoints = x}}++{-# INLINE lensImportsDisplayForms #-}+lensImportsDisplayForms :: Lens' PostScopeState DisplayForms+lensImportsDisplayForms = \f s ->+ f (stPostImportsDisplayForms $ stPostColdState s) <&> \ x -> s { stPostColdState = (stPostColdState s) {stPostImportsDisplayForms = x}}++{-# INLINE lensTemporaryInstances #-}+lensTemporaryInstances :: Lens' PostScopeState (Set QName)+lensTemporaryInstances = \f s ->+ f (stPostTemporaryInstances $ stPostColdState s) <&> \ x -> s { stPostColdState = (stPostColdState s) {stPostTemporaryInstances = x}}++{-# INLINE lensConcreteNames #-}+lensConcreteNames :: Lens' PostScopeState ConcreteNames+lensConcreteNames = \f s ->+ f (stPostConcreteNames $ stPostColdState s) <&> \ x -> s { stPostColdState = (stPostColdState s) {stPostConcreteNames = x}}++{-# INLINE lensStatistics #-}+lensStatistics :: Lens' PostScopeState Statistics+lensStatistics = \f s ->+ f (stPostStatistics $ stPostColdState s) <&> \ x -> s { stPostColdState = (stPostColdState s) {stPostStatistics = x}}++{-# INLINE lensTCWarnings #-}+lensTCWarnings :: Lens' PostScopeState (Set TCWarning)+lensTCWarnings = \f s ->+ f (stPostTCWarnings $ stPostColdState s) <&> \ x -> s { stPostColdState = (stPostColdState s) {stPostTCWarnings = x}}++{-# INLINE lensMutualBlocks #-}+lensMutualBlocks :: Lens' PostScopeState MutualBlocks+lensMutualBlocks = \f s ->+ f (stPostMutualBlocks $ stPostColdState s) <&> \ x -> s { stPostColdState = (stPostColdState s) {stPostMutualBlocks = x}}++{-# INLINE lensLocalBuiltins #-}+lensLocalBuiltins :: Lens' PostScopeState BuiltinThings+lensLocalBuiltins = \f s ->+ f (stPostLocalBuiltins $ stPostColdState s) <&> \ x -> s { stPostColdState = (stPostColdState s) {stPostLocalBuiltins = x}}++{-# INLINE lensFreshMetaId #-}+lensFreshMetaId :: Lens' PostScopeState MetaId+lensFreshMetaId = \f s ->+ f (stPostFreshMetaId $ stPostMetaState s) <&> \ x -> s { stPostMetaState = (stPostMetaState s) {stPostFreshMetaId = x}}++{-# INLINE lensFreshMutualId #-}+lensFreshMutualId :: Lens' PostScopeState MutualId+lensFreshMutualId = \f s ->+ f (stPostFreshMutualId $ stPostColdState s) <&> \ x -> s { stPostColdState = (stPostColdState s) {stPostFreshMutualId = x}}++{-# INLINE lensFreshProblemId #-}+lensFreshProblemId :: Lens' PostScopeState ProblemId+lensFreshProblemId = \f s ->+ f (stPostFreshProblemId $ stPostMetaState s) <&> \ x -> s { stPostMetaState = (stPostMetaState s) {stPostFreshProblemId = x}}++{-# INLINE lensFreshCheckpointId #-}+lensFreshCheckpointId :: Lens' PostScopeState CheckpointId+lensFreshCheckpointId = \f s ->+ f (stPostFreshCheckpointId $ stPostNamesCheckpoints s) <&> \ x -> s { stPostNamesCheckpoints = (stPostNamesCheckpoints s) {stPostFreshCheckpointId = x}}++{-# INLINE lensFreshInt #-}+lensFreshInt :: Lens' PostScopeState Int+lensFreshInt = \f s ->+ f (stPostFreshInt $ stPostColdState s) <&> \ x -> s { stPostColdState = (stPostColdState s) {stPostFreshInt = x}}+++-- Flags+----------------------------------------------------------------------------------------------------++{-# INLINE mkPostFlag #-}+mkPostFlag :: Int -> Lens' PostScopeState Bool+mkPostFlag i = \f s ->+ let old = getFlag i (stPostFlags (stPostColdState s)) in+ f old <&> \b ->+ -- avoiding copy on unchanged flags+ if b == old then s else+ s {stPostColdState = (stPostColdState s) {+ stPostFlags = setFlag i b (stPostFlags (stPostColdState s))}}++-- ^ Dirty when a constraint is added, used to prevent pointer update.+-- Currently unused.+{-# INLINE lensDirty #-}+lensDirty :: Lens' PostScopeState Bool+lensDirty = mkPostFlag 0++{-# INLINE lensAreWeCaching #-}+lensAreWeCaching :: Lens' PostScopeState Bool+lensAreWeCaching = mkPostFlag 1++{-# INLINE lensPostponeInstanceSearch #-}+lensPostponeInstanceSearch :: Lens' PostScopeState Bool+lensPostponeInstanceSearch = mkPostFlag 2++{-# INLINE lensConsideringInstance #-}+lensConsideringInstance :: Lens' PostScopeState Bool+lensConsideringInstance = mkPostFlag 3++-- | 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.+{-# INLINE lensInstantiateBlocking #-}+lensInstantiateBlocking :: Lens' PostScopeState Bool+lensInstantiateBlocking = mkPostFlag 4++{-# INLINE lensInstanceHack #-}+-- ^ Is this a context where we should always try every possible+-- instance candidate? Used to support "inert improvement", see+-- @shouldBlockOverlap@ in InstanceArguments.+lensInstanceHack :: Lens' PostScopeState Bool+lensInstanceHack = mkPostFlag 5+++-- * @st@-prefixed lenses+------------------------------------------------------------------------++-- ** Persistent state++stLoadedFileCache :: Lens' TCState (Maybe LoadedFileCache)+stLoadedFileCache = lensPersistentState . lensLoadedFileCache . Strict.lensMaybeLazy++stTopLevelModuleNames :: Lens' TCState (BiMap RawTopLevelModuleName ModuleNameHash)+stTopLevelModuleNames = lensPersistentState . lensTopLevelModuleNames++-- ** Pre scope state++stFileId :: Lens' TCState (Strict.Maybe FileId)+stFileId = lensPreScopeState . lensPreFileId++stTokens :: Lens' TCState HighlightingInfo+stTokens = lensPreScopeState . lensPreTokens++stImports :: Lens' TCState Signature+stImports = lensPreScopeState . lensImports++stImportedModules :: Lens' TCState ImportedModules+stImportedModules = lensPreScopeState . lensImportedModules++stImportedModulesTransitive :: Lens' TCState ImportedModules+stImportedModulesTransitive = lensPreScopeState . lensImportedModulesTransitive++stImportedModulesAndTransitive ::+ Lens' TCState (ImportedModules, ImportedModules)+stImportedModulesAndTransitive+ = lensProduct stImportedModules stImportedModulesTransitive++lensModuleToSource :: Lens' SessionState ModuleToSource+lensModuleToSource = lensProduct lensFileDict lensModuleToSourceId . lensPairModuleToSource++stVisitedModules :: Lens' TCState VisitedModules+stVisitedModules = lensPreScopeState . lensVisitedModules++stScope :: Lens' TCState ScopeInfo+stScope = lensPreScopeState . lensScope++stPatternSyns :: Lens' TCState A.PatternSynDefns+stPatternSyns = lensPreScopeState . lensPatternSyns++stPatternSynImports :: Lens' TCState A.PatternSynDefns+stPatternSynImports = lensPreScopeState . lensPatternSynImports++stGeneralizedVars :: Lens' TCState (Maybe (Set QName))+stGeneralizedVars = lensPreScopeState . lensGeneralizedVars . Strict.lensMaybeLazy++instance LensPragmaOptions TCState where+ {-# inline lensPragmaOptions #-}+ lensPragmaOptions = lensPreScopeState . lensPragmaOptions++stPragmaOptions :: Lens' TCState PragmaOptions+stPragmaOptions = lensPragmaOptions++stImportedBuiltins :: Lens' TCState BuiltinThings+stImportedBuiltins = lensPreScopeState . lensImportedBuiltins++stForeignCode :: Lens' TCState BackendForeignCode+stForeignCode = lensPostScopeState . lensForeignCode++stFreshInteractionId :: Lens' TCState InteractionId+stFreshInteractionId = lensPreScopeState . lensFreshInteractionId++stImportedUserWarnings :: Lens' TCState UserWarnings+stImportedUserWarnings = lensPreScopeState . lensImportedUserWarnings++stLocalUserWarnings :: Lens' TCState UserWarnings+stLocalUserWarnings = lensPreScopeState . lensLocalUserWarnings++getUserWarnings :: ReadTCState m => m UserWarnings+getUserWarnings = do+ iuw <- useR stImportedUserWarnings+ luw <- useR stLocalUserWarnings+ return $ iuw `Map.union` luw++stWarningOnImport :: Lens' TCState (Maybe Text)+stWarningOnImport = lensPreScopeState . lensWarningOnImport . Strict.lensMaybeLazy++stImportedPartialDefs :: Lens' TCState (Set QName)+stImportedPartialDefs = lensPreScopeState . lensImportedPartialDefs++stLibCache :: Lens' TCState LibCache+stLibCache = lensPreScopeState . lensLibCache++stImportedMetaStore :: Lens' TCState RemoteMetaStore+stImportedMetaStore = lensPreScopeState . lensImportedMetaStore++stCopiedNames :: Lens' TCState (HashMap QName QName)+stCopiedNames = lensPreScopeState . lensCopiedNames++stNameCopies :: Lens' TCState (HashMap QName (HashSet QName))+stNameCopies = lensPreScopeState . lensNameCopies++stImportedDisplayForms :: Lens' TCState DisplayForms+stImportedDisplayForms = lensPreScopeState . lensImportedDisplayForms++stUnusedImportsState :: Lens' TCState UnusedImportsState+stUnusedImportsState = lensPreScopeState . lensUnusedImportsState++-- ** Post scope state++stLocalPartialDefs :: Lens' TCState (Set QName)+stLocalPartialDefs = lensPostScopeState . lensLocalPartialDefs++getPartialDefs :: ReadTCState m => m (Set QName)+getPartialDefs = do+ ipd <- useR stImportedPartialDefs+ lpd <- useR stLocalPartialDefs+ return $ ipd `Set.union` lpd++stFreshNameId :: Lens' TCState NameId+stFreshNameId = lensPostScopeState . lensFreshNameId++stFreshOpaqueId :: Lens' TCState OpaqueId+stFreshOpaqueId = lensPostScopeState . lensFreshOpaqueId++stOpaqueBlocks :: Lens' TCState (Map OpaqueId OpaqueBlock)+stOpaqueBlocks = lensPostScopeState . lensOpaqueBlocks++stOpaqueIds :: Lens' TCState (Map QName OpaqueId)+stOpaqueIds = lensPostScopeState . lensOpaqueIds++stInstanceHack :: Lens' TCState Bool+stInstanceHack = lensPostScopeState . lensInstanceHack++stSyntaxInfo :: Lens' TCState HighlightingInfo+stSyntaxInfo = lensPostScopeState . lensSyntaxInfo++stDisambiguatedNames :: Lens' TCState DisambiguatedNames+stDisambiguatedNames = lensPostScopeState . lensDisambiguatedNames++stOpenMetaStore :: Lens' TCState LocalMetaStore+stOpenMetaStore = lensPostScopeState . lensOpenMetaStore++stSolvedMetaStore :: Lens' TCState LocalMetaStore+stSolvedMetaStore = lensPostScopeState . lensSolvedMetaStore++stInteractionPoints :: Lens' TCState InteractionPoints+stInteractionPoints = lensPostScopeState . lensInteractionPoints++stAwakeConstraints :: Lens' TCState Constraints+stAwakeConstraints = lensPostScopeState . lensAwakeConstraints++stSleepingConstraints :: Lens' TCState Constraints+stSleepingConstraints = lensPostScopeState . lensSleepingConstraints++stDirty :: Lens' TCState Bool+stDirty = lensPostScopeState . lensDirty++stOccursCheckDefs :: Lens' TCState (Set QName)+stOccursCheckDefs = lensPostScopeState . lensOccursCheckDefs++stSignature :: Lens' TCState Signature+stSignature = lensPostScopeState . lensSignature++stRewriteRules :: Lens' TCState GlobalRewriteRuleMap+stRewriteRules = stSignature . sigRewriteRules++stModuleCheckpoints :: Lens' TCState ModuleCheckpoints+stModuleCheckpoints = lensPostScopeState . lensModuleCheckpoints++stImportsDisplayForms :: Lens' TCState DisplayForms+stImportsDisplayForms = lensPostScopeState . lensImportsDisplayForms++stWarningSet :: Lens' TCState (Set WarningName)+stWarningSet = stPragmaOptions . lensOptWarningMode . warningSet++stCurrentModule :: Lens' TCState (Strict.Maybe (Strict.Pair ModuleName TopLevelModuleName))+stCurrentModule = lensPostScopeState . lensCurrentModule++{-# INLINE stInstanceDefs #-}+stInstanceDefs :: Lens' TCState TempInstanceTable+stInstanceDefs = \f s ->+ f ( s ^. stSignature . sigInstances+ , stPostPendingInstances (stPostColdState (stPostScopeState s))+ )+ <&> \(!t, !x) ->+ set (stSignature . sigInstances) t+ (s { stPostScopeState = (stPostScopeState s) {+ stPostColdState = (stPostColdState (stPostScopeState s)){+ stPostPendingInstances = x }}})++stTemporaryInstances :: Lens' TCState (Set QName)+stTemporaryInstances = lensPostScopeState . lensTemporaryInstances++stConcreteNames :: Lens' TCState ConcreteNames+stConcreteNames = lensPostScopeState . lensConcreteNames++stStatistics :: Lens' TCState Statistics+stStatistics = lensPostScopeState . lensStatistics++stTCWarnings :: Lens' TCState (Set TCWarning)+stTCWarnings = lensPostScopeState . lensTCWarnings++stMutualBlocks :: Lens' TCState MutualBlocks+stMutualBlocks = lensPostScopeState . lensMutualBlocks++stLocalBuiltins :: Lens' TCState BuiltinThings+stLocalBuiltins = lensPostScopeState . lensLocalBuiltins++stFreshMetaId :: Lens' TCState MetaId+stFreshMetaId = lensPostScopeState . lensFreshMetaId++stFreshMutualId :: Lens' TCState MutualId+stFreshMutualId = lensPostScopeState . lensFreshMutualId++stFreshProblemId :: Lens' TCState ProblemId+stFreshProblemId = lensPostScopeState . lensFreshProblemId++stFreshCheckpointId :: Lens' TCState CheckpointId+stFreshCheckpointId = lensPostScopeState . lensFreshCheckpointId++stFreshInt :: Lens' TCState Int+stFreshInt = lensPostScopeState . lensFreshInt++-- | use @areWeCaching@ from the Caching module instead.+stAreWeCaching :: Lens' TCState Bool+stAreWeCaching = lensPostScopeState . lensAreWeCaching++stPostponeInstanceSearch :: Lens' TCState Bool+stPostponeInstanceSearch = lensPostScopeState . lensPostponeInstanceSearch++stConsideringInstance :: Lens' TCState Bool+stConsideringInstance = lensPostScopeState . lensConsideringInstance++stInstantiateBlocking :: Lens' TCState Bool+stInstantiateBlocking = lensPostScopeState . lensInstantiateBlocking++stInstanceTree :: Lens' TCState (DiscrimTree QName)+stInstanceTree = stSignature . sigInstances . itableTree++stBuiltinThings :: TCState -> BuiltinThings+stBuiltinThings s = Map.unionWith unionBuiltin (s ^. stLocalBuiltins) (s ^. stImportedBuiltins)++-- | Union two 'Builtin's.+unionBuiltin :: Builtin a -> Builtin a -> Builtin a+unionBuiltin = curry $ \case+ (BuiltinRewriteRelations xs, BuiltinRewriteRelations ys) -> BuiltinRewriteRelations $ xs <> ys+ (x, _) -> x+++-- * Fresh things+------------------------------------------------------------------------++class Enum i => HasFresh i where+ freshLens :: Lens' TCState i+ nextFresh' :: i -> i+ nextFresh' = succ++{-# INLINE nextFresh #-}+nextFresh :: HasFresh i => TCState -> (i, TCState)+nextFresh s =+ let !c = s ^. freshLens+ !next = set freshLens (nextFresh' c) s+ in (c, next)++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 (ExceptT e m)+instance MonadFresh i m => MonadFresh i (MaybeT m)+instance MonadFresh i m => MonadFresh i (ReaderT r m)+instance MonadFresh i m => MonadFresh i (StateT s m)+instance (MonadFresh i m, Monoid w) => MonadFresh i (WriterT w 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+ {-# INLINE fresh #-}++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 OpaqueId where+ freshLens = stFreshOpaqueId++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_++instance FreshName Name where+ freshName_ (Name _ con can bs fix rn) = do+ i <- fresh+ pure $ Name i con can bs fix rn++instance FreshName C.Name where+ freshName_ c = do+ i <- fresh+ pure $ Name i c c noRange noFixity' False++----------------------------------------------------------------------------------------------------+-- * Module Checkpoints+--+-- During the course of typechecking, we often need to bounce between wildly+-- different contexts. To do this, we need to have access to a substitution+-- that describes how our current context was built. This is handled internally+-- via __checkpoints__. These are unique identifiers that index into a map+-- @'envCheckpoints'@ that translates @'CheckpointId'@s into @'Substitution'@s,+-- which allows us to cheaply look up the substitution that describes how to+-- enter some other context.+--+-- Agda also uses checkpoints to manage parameterised module telescopes.+-- This is a natural choice: we've already got a map of substitutions+-- in the typing environment, so if we are able to associate every module name+-- to a checkpoint, we can re-use this machinery to store substitutions+-- @Γ ⊢ ρ : Δm@ that map our current context @Γ@ into a module parameter+-- telescope @Δm@ for some module @m@.+--+-- However, things get a bit tricky when we enter and leave modules.+-- Consider the following code:+--+-- > module M1 (A : Set) where+-- > module M2 (ff : ⊥) where+-- > x : Nat+-- > x = ... -- Typechecking here+-- > ...+--+-- When we are typechecking the RHS of @x@, the substitution associated to+-- @M2@ ought to be a checkpoint pointing to the identity substitution+--+-- > A : Set, ff : ⊥ ⊢ A, ff : (A : Set, ff : ⊥).+--+-- Things only get tricky when we finish typechecking the body of @M2@, and+-- re-enter the outer module @M1@. When we are back in the body of @M1@, our+-- ambient context no longer contains a @ff : ⊥@, and the checkpoint associated to+-- @M2@ needs to point to:+--+-- > A : Set ⊢ A : (A : Set).+--+-- To manage this, we keep track of a stack that associates a set of @'ModuleName's@ to+-- a single @'CheckPointId'@. This makes it relatively efficient to determine when+-- we should update the checkpoint of a group of modules. Checkpoint ids are allocated+-- monotonically, so whenever a checkpoint goes out of scope, we can do batch updates of+-- checkpoint ids by walking back along the stack of module names until we hit the checkpoint+-- we are looking for.+----------------------------------------------------------------------------------------------------++-- | A stack of module checkpoints for the current module.+--+-- We use a hand-rolled stack over a list so that we can @UNPACK@ the @CheckpointId@+-- and make all the fields strict.+data ModuleCheckpoints+ = ModuleCheckpointsTop+ -- ^ We are in a top-level module, so we don't need to worry about checkpoints.+ | ModuleCheckpointsSection !ModuleCheckpoints !(Set ModuleName) {-# UNPACK #-} !CheckpointId+ -- ^ A group of modules that all share a single checkpoint.+ deriving (Generic)++-- All fields of @ModuleCheckpoints@ are strict, so we only need to force the outermost constructor.+instance NFData ModuleCheckpoints where+ rnf ModuleCheckpointsTop = ()+ rnf (ModuleCheckpointsSection _ _ _) = ()++instance Pretty ModuleCheckpoints where+ pretty (ModuleCheckpointsTop) = "[]"+ pretty (ModuleCheckpointsSection mchkpts mnames chkpt) =+ (pretty mchkpts <> comma) <+> parens (pretty mnames <+> colon <+> pretty chkpt)++----------------------------------------------------------------------------------------------------+-- * 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 =+ ifImpureConv (stateTCLensM stConcreteNames $ runStateT m) $ do+ concNames <- useR stConcreteNames+ evalStateT m concNames++-- | The concrete names get lost in case of an exception.+instance MonadStConcreteNames m => MonadStConcreteNames (ExceptT e m) where+ runStConcreteNames m = ExceptT $ runStConcreteNames $ StateT $ \ ns -> do+ runExceptT (runStateT m ns) <&> \case+ Left e -> (Left e, mempty)+ Right (x, ns') -> (Right x, ns')++instance MonadStConcreteNames m => MonadStConcreteNames (IdentityT m) where+ runStConcreteNames m = IdentityT $ runStConcreteNames $ StateT $ runIdentityT . runStateT m++instance MonadStConcreteNames m => MonadStConcreteNames (MaybeT m) where+ runStConcreteNames m = MaybeT $ runStConcreteNames $ StateT $ \ ns -> do+ runMaybeT (runStateT m ns) <&> \case+ Nothing -> (Nothing, mempty)+ Just (x, ns') -> (Just x, ns')++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')++instance (MonadStConcreteNames m, Monoid w) => MonadStConcreteNames (WriterT w m) where+ runStConcreteNames m = WriterT $ runStConcreteNames $ StateT $ \ ns -> do+ ((x,ns'),w) <- runWriterT $ runStateT m ns+ return ((x,w),ns')++----------------------------------------------------------------------------------------------------+-- * File handling+----------------------------------------------------------------------------------------------------++instance GetFileId FileDictWithBuiltins where+ getFileId = getFileId . fileDictBuilder++instance GetIdFile FileDictWithBuiltins where+ getIdFile = getIdFile . fileDictBuilder++-- | Get the file name of a 'SourceFile'.++srcFilePath :: MonadFileId m => SourceFile -> m AbsolutePath+srcFilePath (SourceFile fi) = fileFromId fi++-- | Get make a 'SourceFile' from a file name.+srcFromPath :: MonadFileId m => AbsolutePath -> m SourceFile+srcFromPath p = SourceFile <$> idFromFile p++instance Pretty ModuleToSource where+ pretty (ModuleToSource dict mods) = vcat+ [ hsep [ "-", pretty m, "->", pretty $ getIdFile dict i ]+ | (m, SourceFile i) <- Map.toList mods+ ]++-- | Lookup the path of a top level module name, which must be a known one.++topLevelModuleFilePath :: HasCallStack => ModuleToSource -> TopLevelModuleName -> AbsolutePath+topLevelModuleFilePath (ModuleToSource dict m2s) m =+ getIdFile dict $ srcFileId $ Map.findWithDefault __IMPOSSIBLE__ m m2s++----------------------------------------------------------------------------------------------------+-- * 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 :: Set 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"+ , miIsBuiltin :: !(Maybe IsBuiltinModule)+ -- ^ 'True' if the module is a primitive module, which should always+ -- be importable.+ , miMode :: ModuleCheckMode+ -- ^ The `ModuleCheckMode` used to create the `Interface`+ , miSourceFile :: SourceFile+ -- ^ The file belonging to the module.+ }+ deriving Generic++type VisitedModules = Map TopLevelModuleName ModuleInfo+type DecodedModules = Map TopLevelModuleName ModuleInfo++data ForeignCode = ForeignCode Range String+ deriving (Show, Generic)++-- | Foreign code fragments are stored in reversed order to support efficient appending:+-- head points to the latest pragma in module.+newtype ForeignCodeStack = ForeignCodeStack+ { getForeignCodeStack :: [ForeignCode]+ } deriving (Show, Generic, NFData)++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 :: UserWarnings+ -- ^ User warnings for imported identifiers+ , iImportWarning :: Maybe Text+ -- ^ Whether this module should raise a warning when imported+ , iBuiltin :: BuiltinThings' (PrimitiveId, QName)+ , iForeignCode :: Map BackendName ForeignCodeStack+ , 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 :: Set TCWarning+ , iPartialDefs :: Set QName+ , iOpaqueBlocks :: Map OpaqueId OpaqueBlock+ , iOpaqueNames :: Map QName OpaqueId+ }+ 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 oblocks onames) =++ 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+ , "opaque blocks:" <+> pretty oblocks+ , "opaque names" <+> pretty onames+ ]++-- | 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' Interface Signature+intSignature f i = f (iSignature i) <&> \s -> i { iSignature = s }++----------------------------------------------------------------------------------------------------+-- ** Closure+----------------------------------------------------------------------------------------------------++data Closure a = Closure+ { clSignature :: Signature+ , clEnv :: TCEnv+ , clScope :: ScopeInfo+ , clModuleCheckpoints :: ModuleCheckpoints+ , 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 b a | b -> a where+ lensClosure :: Lens' b (Closure a)++instance LensClosure (Closure a) a where+ lensClosure = id++instance LensTCEnv (Closure a) where+ lensTCEnv f cl = (f $! clEnv cl) <&> \ env -> cl { clEnv = env }++{-# SPECIALIZE buildClosure :: a -> TCM (Closure a) #-}+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 (Dom 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 Range MetaId (Maybe [Candidate])+ -- ^ the second argument is the instance argument and the third one is dhe list of candidates+ -- (or Nothing if we haven’t determined the list of candidates yet)+ | ResolveInstanceHead KwRange QName+ -- ^ Resolve the head symbol of the type that the given instance targets+ -- The 'KwRange' is the range of the @instance@ keyword.+ | CheckFunDef 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@.+ | RewConstraint LocalEquation+ -- ^ Does the local rewrite rule hold definitionally at the call-site?+ -- Essentially a 'ValueCmp' but with a more specific error message+ deriving (Show, Generic)++-- It's important to have a proper range for constraints that can remain unsolved+-- without a corresponding unsolved meta to point to the location of the constraint.+instance HasRange Constraint where+ getRange (IsEmpty r t) = r+ getRange (FindInstance r _ _) = r+ getRange ValueCmp{} = noRange+ getRange ElimCmp{} = noRange+ getRange SortCmp{} = noRange+ getRange LevelCmp{} = noRange+ getRange UnBlock{} = noRange+ getRange ValueCmpOnFace{} = noRange+ getRange HasBiggerSort{} = noRange+ getRange HasPTSRule{} = noRange+ getRange CheckDataSort{} = noRange+ getRange CheckMetaInst{} = noRange+ getRange CheckType{} = noRange+ getRange CheckSizeLtSat{} = noRange+ getRange CheckFunDef{} = noRange+ getRange ResolveInstanceHead{} = noRange+ getRange UnquoteTactic{} = noRange+ getRange CheckLockedVars{} = noRange+ getRange UsableAtModality{} = noRange+ getRange RewConstraint{} = noRange++instance Free Constraint where+ freeVars c = expand \ret -> case c of+ ValueCmp _ t u v -> ret $ freeVars (t, u, v)+ ValueCmpOnFace _ p t u v -> ret $ freeVars (p, t, u, v)+ ElimCmp _ _ t u es es' -> ret $ freeVars (t, u, es, es')+ SortCmp _ s s' -> ret $ freeVars (s, s')+ LevelCmp _ l l' -> ret $ freeVars (l, l')+ UnBlock _ -> ret $ mempty+ IsEmpty _ t -> ret $ freeVars t+ CheckSizeLtSat u -> ret $ freeVars u+ FindInstance _ _ cs -> ret $ freeVars cs+ ResolveInstanceHead _ _ -> ret $ mempty+ CheckFunDef{} -> ret $ mempty+ HasBiggerSort s -> ret $ freeVars s+ HasPTSRule a s -> ret $ freeVars (a , s)+ CheckLockedVars a b c d -> ret $ freeVars (a, b, c, d)+ UnquoteTactic t h g -> ret $ freeVars (t, h, g)+ CheckDataSort _ s -> ret $ freeVars s+ CheckMetaInst m -> ret $ mempty+ CheckType t -> ret $ freeVars t+ UsableAtModality _ ms mod t -> ret $ freeVars (ms, t)+ RewConstraint e -> ret $ freeVars e++{-# SPECIALIZE closed :: Constraint -> Bool #-}+{-# SPECIALIZE freeVarSet :: Constraint -> VarSet #-}++instance TermLike LocalEquation where+ foldTerm f (LocalEquation g t u a) = foldTerm f (g, t, u, a)++ traverseTermM f c = __IMPOSSIBLE__ -- Not yet implemented++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+ ResolveInstanceHead _ _ -> 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)+ RewConstraint e -> foldTerm f e++ traverseTermM f c = __IMPOSSIBLE__ -- Not yet implemented++instance AllMetas Constraint++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 ca = expand \ret -> case ca of+ (AsTermsOf a) -> ret $ freeVars a+ AsSizes -> ret $ mempty+ AsTypes -> ret $ 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" (on de Bruijn levels)+ -- 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)++-- | Solution status of meta.+data MetaInstantiation+ = InstV Instantiation -- ^ Solved by 'Instantiation'.+ | OpenMeta MetaKind -- ^ Unsolved (open to solutions).+ | BlockedConst Term -- ^ Solved, but solution blocked by unsolved constraints.+ | PostponedTypeCheckingProblem (Closure TypeCheckingProblem)+ -- ^ Meta stands for value of the expression that is still to be type checked.+ 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+ deriving Show++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++instance AllMetas PrincipalArgTypeMetas where+ allMetas f (PrincipalArgTypeMetas vs ty) = allMetas f (vs,ty)++data TypeCheckingProblem+ = CheckExpr Comparison A.Expr Type+ | CheckArgs Comparison ExpandHidden A.Expr [NamedArg A.Expr] Type Type (ArgsCheckState CheckedTarget -> TCM Term)+ | CheckProjAppToKnownPrincipalArg Comparison A.Expr ProjOrigin AmbiguousQName A.Expr 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'.+ | DisambiguateConstructor ConstructorDisambiguationData (ConHead -> TCM Term)+ -- ^ A stuck constructor disambiguation with the bits to retry it on and the success continuation.+ | DoQuoteTerm Comparison Term Type -- ^ Quote the given term and check type against `Term`+ deriving Generic++-- | Information we have constructored in the middle of disambiguating a constructor.+data ConstructorDisambiguationData = ConstructorDisambiguationData+ -- bcd for blocked constructor disambiguation+ { bcdConName :: QName+ -- ^ One of the eligible ambiguous names (for error messages).+ , bcdCandidates :: List1 (QName, Type, ConHead)+ -- ^ The possible candidates for disambiguation+ , bcdArguments :: A.Args+ -- ^ The arguments given to the constructor.+ , bcdType :: Type+ -- ^ The type of the constructor application+ } deriving Generic++instance Pretty MetaInstantiation where+ pretty = \case+ OpenMeta UnificationMeta -> "Open"+ OpenMeta InstanceMeta -> "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)++instance LensModalPolarity MetaInfo where+ getModalPolarity = getModalPolarity . getModality+ mapModalPolarity f = mapModality (mapModalPolarity f)++-- | Append an 'ArgName' to a 'MetaNameSuggestion', for computing the+-- name suggestions of eta-expansion metas. If the 'MetaNameSuggestion'+-- is empty or an underscore, the field name is taken as the suggestion.+suffixNameSuggestion :: MetaNameSuggestion -> ArgName -> MetaNameSuggestion+suffixNameSuggestion "_" field = field+suffixNameSuggestion "" field = field+suffixNameSuggestion record field = record ++ "." ++ field++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++{-# SPECIALIZE Map.insert :: MetaId -> v -> Map MetaId v -> Map MetaId v #-}+{-# SPECIALIZE Map.lookup :: MetaId -> Map MetaId v -> Maybe v #-}++-- | 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)++instance LensModalPolarity RemoteMetaVariable where+ mapModalPolarity f = mapModality (mapModalPolarity 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' MetaVariable Frozen+metaFrozen f mv = f (mvFrozen mv) <&> \ x -> mv { mvFrozen = x }++_mvInfo :: Lens' MetaVariable MetaInfo+_mvInfo f mv = (f $! mvInfo mv) <&> \ mi -> mv { mvInfo = mi }++-- Lenses onto Closure Range++instance LensClosure MetaInfo Range where+ lensClosure f mi = (f $! miClosRange mi) <&> \ cl -> mi { miClosRange = cl }++instance LensClosure MetaVariable Range 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 $ env ^. eAbstractMode))+ <&> \a -> env & eAbstractMode .~ aDefToMode a++instance LensIsAbstract (Closure a) where+ lensIsAbstract = lensTCEnv . lensIsAbstract++instance LensIsAbstract MetaInfo where+ lensIsAbstract = lensClosure . lensIsAbstract++instance LensIsAbstract MetaVariable where+ lensIsAbstract = _mvInfo . lensIsAbstract++instance LensIsOpaque TCEnv where+ lensIsOpaque f env =+ (f $! case env ^. eCurrentOpaqueId of { Just x -> OpaqueDef x ; Nothing -> TransparentDef })+ <&> \case OpaqueDef x -> env & eCurrentOpaqueId .~ Just x+ TransparentDef -> env & eCurrentOpaqueId .~ Nothing++----------------------------------------------------------------------------------------------------+-- ** 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.+ , ipBoundary :: IPBoundary+ }+ 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)++newtype IPBoundary' t = IPBoundary+ { getBoundary :: Map (IntMap Bool) t+ }+ 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 :: ClauseNumber -- ^ The number of the clause of this function.+ , ipcType :: Type -- ^ The type of the function+ , ipcWithSub :: IsWithFunction Substitution -- ^ Module parameter substitution+ , ipcClause :: A.SpineClause -- ^ The original AST clause.+ , ipcClosure :: Closure () -- ^ Environment for rechecking the clause.+ }+ | 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 :: GlobalRewriteRuleMap+ -- ^ The rewrite rules defined in this file.+ , _sigInstances :: InstanceTable+ }+ deriving (Show, Generic)++instance Null Signature where+ empty = Sig empty empty empty empty+ null (Sig a b c d) = null a && null b && null c && null d++sigSections :: Lens' Signature Sections+sigSections f s =+ f (_sigSections s) <&>+ \x -> s {_sigSections = x}++sigDefinitions :: Lens' Signature Definitions+sigDefinitions f s =+ f (_sigDefinitions s) <&>+ \x -> s {_sigDefinitions = x}++sigInstances :: Lens' Signature InstanceTable+sigInstances f s = f (_sigInstances s) <&> \x -> s {_sigInstances = x}++sigRewriteRules :: Lens' Signature GlobalRewriteRuleMap+sigRewriteRules f s =+ f (_sigRewriteRules s) <&>+ \x -> s {_sigRewriteRules = x}++type Sections = Map ModuleName Section+type Definitions = HashMap QName Definition+type GlobalRewriteRuleMap = HashMap QName GlobalRewriteRules+type DisplayForms = HashMap QName (List1 LocalDisplayForm)++{-# SPECIALIZE HMap.insert :: QName -> v -> HashMap QName v -> HashMap QName v #-}+{-# SPECIALIZE HMap.lookup :: QName -> HashMap QName v -> Maybe v #-}++newtype Section = Section { _secTelescope :: Telescope }+ deriving (Show, NFData)++instance Pretty Section where+ pretty = pretty . _secTelescope++secTelescope :: Lens' Section Telescope+secTelescope f s =+ f (_secTelescope s) <&>+ \x -> s {_secTelescope = x}++emptySignature :: Signature+emptySignature = Sig Map.empty HMap.empty HMap.empty mempty++-- | 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 (List1 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 Elims+ -- ^ @.(v es)@. See 'DTerm''.+ | DTerm' Term Elims+ -- ^ @v es@.+ -- This is a frozen elimination that is not always safe to run,+ -- because display forms may be ill-typed.+ -- (See issue #6476.)+ deriving (Show, Generic)++pattern DDot :: Term -> DisplayTerm+pattern DDot v = DDot' v []++pattern DTerm :: Term -> DisplayTerm+pattern DTerm v = DTerm' v []++instance Pretty DisplayTerm where+ prettyPrec p v =+ case v of+ DTerm v -> prettyPrec p v+ DTerm' v es -> prettyPrec 9 v `pApp` es+ DDot v -> "." <> prettyPrec 10 v+ DDot' v es -> "." <> parens (prettyPrec 9 v `pAp` es)+ 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 $ fmap (\ w -> "|" <+> pretty w) ws+ ])+ `pApp` es+ where+ pApp :: Pretty el => Doc -> [el] -> Doc+ pApp d els = mparens (not (null els) && p > 9) $ pAp d els+ pAp :: Pretty el => Doc -> [el] -> Doc+ pAp d els = 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 = []++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++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++instance TermLike NLPSort where+ traverseTermM f = \case+ PUniv u p -> PUniv u <$> traverseTermM f p+ s@PInf{} -> return s+ s@PSizeUniv{} -> return s+ s@PLockUniv{} -> return s+ s@PLevelUniv{} -> return s+ s@PIntervalUniv{} -> return s++ foldTerm f t = case t of+ PUniv _ p -> foldTerm f p+ s@PInf{} -> mempty+ s@PSizeUniv{} -> mempty+ s@PLockUniv{} -> mempty+ s@PLevelUniv{} -> mempty+ s@PIntervalUniv{} -> mempty++instance AllMetas NLPSort++type GlobalRewriteRules = [GlobalRewriteRule]++-- | Rewrite rules can be added independently from function clauses.+data GlobalRewriteRule = GlobalRewriteRule+ { grName :: QName -- ^ Name of rewrite rule @q : Γ → f ps ≡ rhs@+ -- where @≡@ is the rewrite relation.+ , grContext :: Telescope -- ^ @Γ@.+ , grHead :: QName -- ^ @f@.+ , grPats :: PElims -- ^ @Γ ⊢ f ps : t@.+ , grRHS :: Term -- ^ @Γ ⊢ rhs : t@.+ , grType :: Type -- ^ @Γ ⊢ t@.+ , grFromClause :: Bool -- ^ Was this rewrite rule created from a clause in+ -- the definition of the function?+ , grTopModule :: TopLevelModuleName+ -- ^ In which file is this rewrite rule defined?+ -- This information is used to eliminate rewrite rules that happen to be+ -- in 'stImports' but are not actually transitively imported.++ -- See issue #4343 (Andreas, 2025-06-05).+ }+ deriving (Show, Generic)++grHasProjectionPattern :: GlobalRewriteRule -> Bool+grHasProjectionPattern rew = any (isJust . isProjElim) $ grPats rew++type RewriteRules = [RewriteRule]++-- | Map from head symbols to local rewrite rules+-- While the head symbols need to be eagerly updated to live in the current+-- context, the rewrite rules do not. They instead each store a checkpoint id.+data LocalRewriteRuleMap = LocalRewriteRuleMap+ { defHeadedRews :: HashMap QName [Open RewriteRule]+ , varHeadedRews :: IntMap [Open RewriteRule]+ }+ deriving (Show, Generic)++{-# INLINE lrewsDefHeaded #-}+lrewsDefHeaded :: Lens' LocalRewriteRuleMap (HashMap QName [Open RewriteRule])+lrewsDefHeaded = \f rs -> f (defHeadedRews rs) <&> \ rs' -> rs { defHeadedRews = rs' }++{-# INLINE lrewsVarHeaded #-}+lrewsVarHeaded :: Lens' LocalRewriteRuleMap (IntMap [Open RewriteRule])+lrewsVarHeaded = \f rs -> f (varHeadedRews rs) <&> \ rs' -> rs { varHeadedRews = rs' }++instance Null LocalRewriteRuleMap where+ empty = LocalRewriteRuleMap empty empty+ null (LocalRewriteRuleMap rs1 rs2) = null rs1 && null rs2++-- | Information about an @instance@ definition.+data InstanceInfo = InstanceInfo+ { instanceClass :: QName -- ^ Name of the "class" this is an instance for+ , instanceOverlap :: OverlapMode -- ^ Does this instance have a specified overlap mode?+ }+ 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+ , 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 InstanceInfo+ -- ^ @Just q@ when this definition is an instance.+ , 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+ -- Does not account for local rewrite rules+ , 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?+ -- Does not account for local rewrite rules+ , 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.+ , defMightContainMetas :: !Bool+ -- ^ If this is 'False', the definition doesn't contain metavariables. If 'True', the definition+ -- may or may not contain metavariables. This field is updated by 'TypeChecking.DeadCode', and+ -- it's used to avoid unnecessary 'instantiateFull' on the definition before serialization.+ , 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+instance LensModalPolarity 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' Definition Defn+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 = []+ , 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+ , defMightContainMetas = True+ , theDef = def+ }++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++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 == Left _@.+ , 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++-- | Provenance of the eta equality.+-- Keep constructors in order @'EtaFromOption' < 'EtaFromDirective' < 'EtaFromPragma'@.+data EtaProvenance+ = EtaFromOption -- ^ Default stemming from option ('etaEnabled') and inductivity.+ | EtaFromDirective -- ^ User specified @(no-)eta-equality@ in record directive.+ | EtaFromPragma -- ^ User specified eta-equality through pragma, overruling safety checks.+ deriving (Eq, Ord, Show, Generic, Enum, Bounded)++-- | Should a record type admit eta-equality?+data EtaEquality = EtaEquality+ { theEtaEquality :: !HasEta -- ^ Eta or no eta?+ , etaProvenance :: !EtaProvenance -- ^ Where does this information come from?+ }+ 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 -- ^ New value. Must have higher provenance than old value.+ -> EtaEquality -- ^ Old value.+ -> EtaEquality -- ^ New value, or crash if invariant is violated.+setEtaEquality eta@(EtaEquality _ newProvenance) (EtaEquality _ oldProvenance)+ | newProvenance > oldProvenance = eta+ | otherwise = __IMPOSSIBLE__++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?+ | FunFirstOrder+ -- ^ Is this function @INJECTIVE_FOR_INFERENCE@?+ -- Indicates whether the first-order shortcut should be applied to the definition.+ | FunErasure+ -- ^ Was @--erasure@ in effect when the function was defined?+ -- (This can affect the type of a projection.)+ | FunAbstract+ -- ^ Is the function abstract?+ | FunProj+ -- ^ Is this function a descendant of a field (typically, a projection)?+ deriving (Eq, Ord, Enum, Show, Generic, Ix, Bounded)++instance SmallSetElement FunctionFlag+instance KillRange (SmallSet FunctionFlag) where killRange = id++data CompKit = CompKit+ { nameOfHComp :: Maybe QName+ , nameOfTransp :: Maybe QName+ }+ deriving (Eq, Ord, Show, Generic)++emptyCompKit :: CompKit+emptyCompKit = CompKit Nothing Nothing++-- | Is a constructor of a data type a path constructor (HIT constructor)+-- or an ordinary "point" constructor?+data IsPathCons = PathCons | PointCons+ deriving (Eq, Show, Generic)++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 @variable@ block).+ NumGeneralizableArgs+ -- ^ For a generalized variable, shows how many arguments should be generalised.+ | 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)++{-# COMPLETE+ Axiom, DataOrRecSig, GeneralizableVar, AbstractDefn,+ Function, Datatype, Record, Constructor, Primitive, PrimitiveSort #-}++data AxiomData = AxiomData+ { _axiomConstTransp :: Bool+ -- ^ Can transp for this postulate be constant?+ -- Set to @True@ for builtins like String.+ } deriving (Show, Generic)++pattern Axiom :: Bool -> Defn+pattern Axiom{ axiomConstTransp } = AxiomDefn (AxiomData axiomConstTransp)++data DataOrRecSigData = DataOrRecSigData+ { _datarecPars :: !Int+ -- ^ Number of parameters.+ , _datarecKind :: !DataOrRecord_+ -- ^ Is it a @data@ or @record@ signature?+ } deriving (Show, Generic)++pattern DataOrRecSig :: Int -> DataOrRecord_ -> Defn+pattern DataOrRecSig{ datarecPars, datarecKind } = DataOrRecSigDefn (DataOrRecSigData datarecPars datarecKind)++-- | 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).+ , _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 :: SmallSet FunctionFlag+ -- ^ Various boolean flags pertaining to the function definition, see '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 :: IsWithFunction 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?+ , _funOpaque :: IsOpaque+ -- ^ Is this function opaque? If so, and we're not in an opaque+ -- block that includes this function('s name), it will be treated+ -- abstractly.+ } deriving (Show, Generic)++pattern Function+ :: [Clause]+ -> Maybe CompiledClauses+ -> Maybe SplitTree+ -> Maybe Compiled+ -> [Clause]+ -> FunctionInverse+ -> Maybe [QName]+ -> Either ProjectionLikenessMissing Projection+ -> SmallSet FunctionFlag+ -> Maybe Bool+ -> Maybe ExtLamInfo+ -> IsWithFunction QName+ -> Maybe QName+ -> IsOpaque+ -> Defn+pattern Function+ { funClauses+ , funCompiled+ , funSplitTree+ , funTreeless+ , funCovering+ , funInv+ , funMutual+ , funProjection+ , funFlags+ , funTerminates+ , funExtLam+ , funWith+ , funIsKanOp+ , funOpaque+ } = FunctionDefn (FunctionData+ funClauses+ funCompiled+ funSplitTree+ funTreeless+ funCovering+ funInv+ funMutual+ funProjection+ funFlags+ funTerminates+ funExtLam+ funWith+ funIsKanOp+ funOpaque+ )++data DatatypeData = DatatypeData+ { _dataPars :: Nat+ -- ^ Number of parameters.+ , _dataIxs :: Nat+ -- ^ Number of indices.+ , _dataClause :: Maybe Term+ -- ^ Was this data type created by a module application (is it a /copy/)?+ -- If yes, this is its definition, linking back to the original data type:+ -- a term @t@ such that @D args@ equals @t \`applyE\` args@.+ -- It is kept eta-contracted, so that it also unfolds+ -- underapplied occurrences of @D@ (issue #8545).+ , _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).+ , _dataPositivityCheck:: PositivityCheck+ -- ^ Should positivity errors be reported for this data type?+ , _dataAbstr :: IsAbstract+ , _dataHIT :: !IsHIT+ -- ^ Does this data type have any path constructors,+ -- i.e., is it a higher inductive type (HIT)?+ , _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 Term)+ -> [QName]+ -> Sort+ -> Maybe [QName]+ -> PositivityCheck+ -> IsAbstract+ -> IsHIT+ -> Maybe QName+ -> Maybe QName+ -> Defn++pattern Datatype+ { dataPars+ , dataIxs+ , dataClause+ , dataCons+ , dataSort+ , dataMutual+ , dataPositivityCheck+ , dataAbstr+ , dataHIT+ , dataTranspIx+ , dataTransp+ } = DatatypeDefn (DatatypeData+ dataPars+ dataIxs+ dataClause+ dataCons+ dataSort+ dataMutual+ dataPositivityCheck+ dataAbstr+ dataHIT+ dataTranspIx+ dataTransp+ )++data RecordData = RecordData+ { _recPars :: Nat+ -- ^ Number of parameters.+ , _recClause :: Maybe Term+ -- ^ Was this record type created by a module application (is it a /copy/)?+ -- If yes, this is its definition, linking back to the original record type.+ -- See '_dataClause'.+ , _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).+ , _recPositivityCheck :: PositivityCheck+ -- ^ Should positivity errors be reported for this record type?+ , _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 Term+ -> ConHead+ -> Bool+ -> [Dom QName]+ -> Telescope+ -> Maybe [QName]+ -> PositivityCheck+ -> EtaEquality+ -> PatternOrCopattern+ -> Maybe Induction+ -> Maybe Bool+ -> IsAbstract+ -> CompKit+ -> Defn++pattern Record+ { recPars+ , recClause+ , recConHead+ , recNamedCon+ , recFields+ , recTel+ , recMutual+ , recPositivityCheck+ , recEtaEquality'+ , recPatternMatching+ , recInduction+ , recTerminates+ , recAbstr+ , recComp+ } = RecordDefn (RecordData+ recPars+ recClause+ recConHead+ recNamedCon+ recFields+ recTel+ recMutual+ recPositivityCheck+ 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+ , _conPathCons :: !IsPathCons+ -- ^ Is this a path constructor (HIT constructor)+ -- or an ordinary "point" constructor?+ , _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@.+ , _conErasure :: !Bool+ -- ^ Was @--erasure@ in effect when the constructor was defined?+ -- (This can affect the constructor's type.)+ , _conInline :: !Bool+ -- ^ Shall we translate the constructor on the root of the rhs into copattern matching on the lhs?+ -- Activated by INLINE pragma.+ } deriving (Show, Generic)++pattern Constructor+ :: Int+ -> Int+ -> ConHead+ -> QName+ -> IsAbstract+ -> IsPathCons+ -> CompKit+ -> Maybe [QName]+ -> [IsForced]+ -> Maybe [Bool]+ -> Bool+ -> Bool+ -> Defn+pattern Constructor+ { conPars+ , conArity+ , conSrcCon+ , conData+ , conAbstr+ , conPathCons+ , conComp+ , conProj+ , conForced+ , conErased+ , conErasure+ , conInline+ } = ConstructorDefn (ConstructorData+ conPars+ conArity+ conSrcCon+ conData+ conAbstr+ conPathCons+ conComp+ conProj+ conForced+ conErased+ conErasure+ conInline+ )++data PrimitiveData = PrimitiveData+ { _primAbstr :: IsAbstract+ , _primName :: PrimitiveId+ , _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.+ , _primOpaque :: IsOpaque+ -- ^ Primitives can also live in opaque blocks.+ } deriving (Show, Generic)++pattern Primitive+ :: IsAbstract+ -> PrimitiveId+ -> [Clause]+ -> FunctionInverse+ -> Maybe CompiledClauses+ -> IsOpaque+ -> Defn+pattern Primitive+ { primAbstr+ , primName+ , primClauses+ , primInv+ , primCompiled+ , primOpaque+ } = PrimitiveDefn (PrimitiveData+ primAbstr+ primName+ primClauses+ primInv+ primCompiled+ primOpaque+ )++data PrimitiveSortData = PrimitiveSortData+ { _primSortName :: BuiltinSort+ , _primSortSort :: Sort+ } deriving (Show, Generic)++pattern PrimitiveSort+ :: BuiltinSort+ -> Sort+ -> Defn+pattern PrimitiveSort+ { primSortName+ , primSortSort+ } = PrimitiveSortDefn (PrimitiveSortData+ primSortName+ primSortSort+ )++-- TODO: lenses for all Defn variants++lensDataOrRecSig :: Lens' Defn DataOrRecSigData+lensDataOrRecSig f = \case+ DataOrRecSigDefn d -> DataOrRecSigDefn <$> f d+ _ -> __IMPOSSIBLE__++lensFunction :: Lens' Defn FunctionData+lensFunction f = \case+ FunctionDefn d -> FunctionDefn <$> f d+ _ -> __IMPOSSIBLE__++lensConstructor :: Lens' Defn ConstructorData+lensConstructor f = \case+ ConstructorDefn d -> ConstructorDefn <$> f d+ _ -> __IMPOSSIBLE__++lensRecord :: Lens' Defn RecordData+lensRecord f = \case+ RecordDefn d -> RecordDefn <$> f d+ _ -> __IMPOSSIBLE__++-- Lenses for Record++lensRecTel :: Lens' RecordData Telescope+lensRecTel f r =+ f (_recTel r) <&> \ tel -> r { _recTel = tel }++lensRecEta :: Lens' RecordData EtaEquality+lensRecEta f r =+ f (_recEtaEquality' r) <&> \ eta -> r { _recEtaEquality' = eta }++-- 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 eta) = "DataOrRecSig" <+> pretty n <+> pretty eta++instance Pretty a => Pretty (DataOrRecord' a) where+ pretty = \case+ IsData -> "data"+ IsRecord a -> "record" <+> pretty a++instance Pretty a => Pretty (IsWithFunction a) where+ pretty = \case+ NoWithFunction -> "NoWithFunction"+ WithFunction a -> "WithFunction" <+> pretty a++instance Pretty ProjectionLikenessMissing where+ pretty MaybeProjection = "MaybeProjection"+ pretty NeverProjection = "NeverProjection"++instance Pretty FunctionData where+ pretty (FunctionData+ funClauses+ funCompiled+ funSplitTree+ funTreeless+ _funCovering+ funInv+ funMutual+ funProjection+ funFlags+ funTerminates+ _funExtLam+ funWith+ funIsKanOp+ funOpaque+ ) =+ "Function {" <?> vcat+ [ "funClauses =" <?> vcat (map pretty funClauses)+ , "funCompiled =" <?> pretty funCompiled+ , "funSplitTree =" <?> pretty funSplitTree+ , "funTreeless =" <?> pretty funTreeless+ , "funInv =" <?> pretty funInv+ , "funMutual =" <?> pshow funMutual+ , "funProjection =" <?> pretty funProjection+ , "funFlags =" <?> pshow funFlags+ , "funTerminates =" <?> pshow funTerminates+ , "funWith =" <?> pretty funWith+ , "funIsKanOp =" <?> pretty funIsKanOp+ , "funOpaque =" <?> pshow funOpaque+ ] <?> "}"++instance Pretty DatatypeData where+ pretty (DatatypeData+ dataPars+ dataIxs+ dataClause+ dataCons+ dataSort+ dataMutual+ _dataPositivityCheck+ _dataAbstr+ dataHIT+ _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+ , "dataHIT =" <?> pshow dataHIT+ ] <?> "}"++instance Pretty RecordData where+ pretty (RecordData+ recPars+ recClause+ recConHead+ recNamedCon+ recFields+ recTel+ recMutual+ _recPositivityCheck+ 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+ conPathCons+ _conComp+ _conProj+ _conForced+ conErased+ conErasure+ conInline+ ) =+ "Constructor {" <?> vcat+ [ "conPars =" <?> pshow conPars+ , "conArity =" <?> pshow conArity+ , "conSrcCon =" <?> pretty conSrcCon+ , "conData =" <?> pretty conData+ , "conAbstr =" <?> pshow conAbstr+ , "conPathCons =" <?> pshow conPathCons+ , "conErased =" <?> pshow conErased+ , "conErasure =" <?> pshow conErasure+ , "conInline =" <?> pshow conInline+ ] <?> "}"++instance Pretty PrimitiveData where+ pretty (PrimitiveData+ primAbstr+ primName+ primClauses+ _primInv+ primCompiled+ primOpaque+ ) =+ "Primitive {" <?> vcat+ [ "primAbstr =" <?> pshow primAbstr+ , "primName =" <?> pshow primName+ , "primClauses =" <?> pshow primClauses+ , "primCompiled =" <?> pshow primCompiled+ , "primOpaque =" <?> pshow primOpaque+ ] <?> "}"++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 (RecordDefn d) = recRecursive_ d+recRecursive _ = __IMPOSSIBLE__++recRecursive_ :: RecordData -> Bool+recRecursive_ RecordData{ _recMutual = Just qs } = not $ null qs+recRecursive_ _ = __IMPOSSIBLE__++recEtaEquality :: Defn -> HasEta+recEtaEquality = theEtaEquality . recEtaEquality'++_recEtaEquality :: RecordData -> HasEta+_recEtaEquality = theEtaEquality . _recEtaEquality'++-- | A template for creating 'Function' definitions, with sensible+-- defaults.+emptyFunctionData :: HasOptions m => m FunctionData+emptyFunctionData = emptyFunctionData_ . optErasure <$> pragmaOptions++emptyFunctionData_ :: Bool -> FunctionData+emptyFunctionData_ erasure = FunctionData+ { _funClauses = []+ , _funCompiled = Nothing+ , _funSplitTree = Nothing+ , _funTreeless = Nothing+ , _funInv = NotInjective+ , _funMutual = Nothing+ , _funProjection = Left MaybeProjection+ , _funFlags = SmallSet.fromList [ FunErasure | erasure ]+ , _funTerminates = Nothing+ , _funExtLam = Nothing+ , _funWith = empty+ , _funCovering = []+ , _funIsKanOp = Nothing+ , _funOpaque = TransparentDef+ }++emptyFunction :: HasOptions m => m Defn+emptyFunction = FunctionDefn <$> emptyFunctionData++emptyFunction_ :: Bool -> Defn+emptyFunction_ = FunctionDefn . emptyFunctionData_++funFlag_ :: FunctionFlag -> Lens' FunctionData Bool+funFlag_ flag f def@FunctionData{ _funFlags = flags } =+ f (SmallSet.member flag flags) <&>+ \ b -> def{ _funFlags = (if b then SmallSet.insert else SmallSet.delete) flag flags }++funFlag :: FunctionFlag -> Lens' Defn Bool+funFlag flag f = \case+ FunctionDefn d -> FunctionDefn <$> funFlag_ flag f d+ def -> f False $> def++funStatic, funInline, funMacro :: Lens' Defn Bool+funStatic = funFlag FunStatic+funInline = funFlag FunInline+funMacro = funFlag FunMacro++funMacro_ :: Lens' FunctionData Bool+funMacro_ = funFlag_ FunMacro++-- | Toggle the 'FunFirstOrder' flag.+funFirstOrder :: Lens' Defn Bool+funFirstOrder = funFlag FunFirstOrder++-- | Toggle the 'FunErasure' flag.+funErasure :: Lens' Defn Bool+funErasure = funFlag FunErasure++-- | Toggle the 'FunAbstract' flag.+funAbstract :: Lens' Defn Bool+funAbstract = funFlag FunAbstract++-- | Toggle the 'FunAbstract' flag.+funAbstr :: Lens' Defn IsAbstract+funAbstr = funAbstract . iso fromBool toBool++-- | Toggle the 'FunAbstract' flag.+funAbstract_ :: Lens' FunctionData Bool+funAbstract_ = funFlag_ FunAbstract++-- | Toggle the 'FunAbstract' flag.+funAbstr_ :: Lens' FunctionData IsAbstract+funAbstr_ = funAbstract_ . iso fromBool toBool++-- | Toggle the 'FunProj' flag.+funProj :: Lens' Defn Bool+funProj = funFlag FunProj++-- | Toggle the 'FunProj' flag.+funProj_ :: Lens' FunctionData Bool+funProj_ = funFlag_ FunProj++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++isExtendedLambda :: Defn -> Bool+isExtendedLambda def =+ case def of+ Function { funExtLam = Just{} } -> True+ _ -> False++isWithFunction :: Defn -> Bool+isWithFunction def =+ case def of+ Function { funWith = WithFunction{} } -> True+ _ -> False++isCopatternLHS :: Foldable f => f Clause -> Bool+isCopatternLHS = any (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 -> ReduceM b) ->+ (a' -> ReduceM (Reduced b b')) -> ReduceM (Reduced b b')+redBind ma f k = do+ r <- ma+ case r of+ NoReduction x -> 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.+ | RewriteNoMatchReductions -- ^ The primRewriteNoMatch primitive 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)++instance SmallSet.SmallSetElement AllowedReduction++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++{-# INLINE shouldReduceDef #-}+shouldReduceDef :: (MonadTCEnv m) => QName -> m Bool+shouldReduceDef f = viewTC eReduceDefs <&> \case+ OnlyReduceDefs defs -> f `Set.member` defs+ DontReduceDefs defs -> not $ f `Set.member` defs++toReduceDefs :: (Bool, [QName]) -> ReduceDefs+toReduceDefs (True, ns) = OnlyReduceDefs (Data.Set.fromList ns)+toReduceDefs (False, ns) = DontReduceDefs (Data.Set.fromList ns)++fromReduceDefs :: ReduceDefs -> (Bool, [QName])+fromReduceDefs (OnlyReduceDefs ns) = (True, toList ns)+fromReduceDefs (DontReduceDefs ns) = (False, toList ns)++locallyReconstructed :: MonadTCEnv m => m a -> m a+locallyReconstructed = locallyTC eReconstructed . const $ True++isReconstructed :: (MonadTCEnv m) => m Bool+isReconstructed = viewTC eReconstructed++-- | Primitives++data PrimitiveImpl = PrimImpl Type PrimFun++data PrimFun = PrimFun+ { primFunName :: QName+ , primFunArity :: Arity+ , primFunArgOccurrences :: [Occurrence]+ -- ^ See 'defArgOccurrences'.+ , 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 _ = []++-- | The definition of a data or record type copy (created by a module+-- application), if the given definition is such a copy.+defCopyClause :: Definition -> Maybe Term+defCopyClause Defn{theDef = Datatype{dataClause = v}} = v+defCopyClause Defn{theDef = Record {recClause = v}} = v+defCopyClause _ = Nothing++defCompiled :: Definition -> Maybe CompiledClauses+defCompiled Defn{theDef = Function {funCompiled = mcc}} = mcc+defCompiled Defn{theDef = Primitive{primCompiled = mcc}} = mcc+defCompiled _ = Nothing++-- | How a constant is defined: either it is a data or record type copy,+-- defined by a term ('defCopyClause'), or it is defined by clauses+-- ('defClauses'), possibly with a compiled form ('defCompiled').+-- Never both.+defCopyOrClauses :: Definition -> Either Term ([Clause], Maybe CompiledClauses)+defCopyOrClauses def = case defCopyClause def of+ Just v -> Left v+ Nothing -> Right (defClauses def, defCompiled def)++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++-- | 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 def = case theDef def of+ AxiomDefn _ -> ConcreteDef+ DataOrRecSigDefn _ -> ConcreteDef+ GeneralizableVar _ -> ConcreteDef+ AbstractDefn _ -> AbstractDef+ FunctionDefn d -> d ^. funAbstr_+ DatatypeDefn d -> _dataAbstr d+ RecordDefn d -> _recAbstr d+ ConstructorDefn d -> _conAbstr d+ PrimitiveDefn d -> _primAbstr d+ PrimitiveSortDefn _ -> ConcreteDef++defOpaque :: Definition -> IsOpaque+defOpaque d = case theDef d of+ -- These two can be opaque:+ Function{funOpaque=o} -> o+ Primitive{primOpaque=o} -> o++ -- Doesn't matter whether or not it's opaque:+ Axiom{} -> TransparentDef+ -- Concreteness is orthogonal to opacity:+ AbstractDefn{} -> TransparentDef++ -- None of these are supported in opaque blocks:+ DataOrRecSig{} -> TransparentDef+ GeneralizableVar{} -> TransparentDef+ Datatype{} -> TransparentDef+ Record{} -> TransparentDef+ Constructor{} -> TransparentDef+ PrimitiveSort{} -> TransparentDef++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 = MutualId Word32+ deriving (Eq, Ord, Show, Num, Enum, NFData)++instance Pretty MutualId where+ pretty (MutualId i) = pretty i++-- | Map 'MutualId' to 'MutualBlock'.+type MutualBlocks = IntMap MutualBlock++-- | A mutual block of names in the signature.+data MutualBlock = MutualBlock+ { mutualInfo :: MutualInfo+ -- ^ The original info of the mutual block.+ , mutualNames :: Set QName+ } deriving (Show, Eq, Generic)++instance Null MutualBlock where+ empty = MutualBlock empty empty++----------------------------------------------------------------------------------------------------+-- ** Statistics+----------------------------------------------------------------------------------------------------++-- | 'Statistics' is a collection of arbitrary string counters. The keys+-- that can be found in the map depend on what profiling options were+-- given.+data Statistics = Statistics+ { statTicks :: !(HashMap String (Sum Word64))+ -- ^ Tally counters, which should be added when merging.+ , statMaxes :: !(HashMap String (Max Word64))+ -- ^ Record counters, which+ }+ deriving (Show, Eq, Generic)++instance Semigroup Statistics where+ Statistics a b <> Statistics a' b' = Statistics+ (HMap.unionWith (<>) a a')+ (HMap.unionWith (<>) b b')++instance Null Statistics where+ empty = Statistics empty empty++ null (Statistics a b) = HMap.null a && HMap.null b++instance Monoid Statistics where+ mempty = empty++----------------------------------------------------------------------------------------------------+-- ** 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 A.Expr [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+ | CheckConArgFitsIn QName Bool Type Sort+ | CheckFunDefCall Range QName 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+ | CheckModuleParameters ModuleName A.Telescope+ | CheckWithFunctionType Type+ | CheckSectionApplication Range Erased 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+ | CheckLocalRewriteConstraint LocalEquation (Maybe (Closure Call))+ | ScopeCheckExpr C.Expr+ | ScopeCheckDeclaration NiceDeclaration+ | ScopeCheckLHS C.QName C.Pattern+ | NoHighlighting+ | ModuleContents -- ^ Interaction command: show module contents.+ | SetRange Range -- ^ used by 'setCurrentRange'+ deriving (Generic, Show)++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 CheckConArgFitsIn{} = "CheckConArgFitsIn"+ pretty CheckFunDefCall{} = "CheckFunDefCall"+ pretty CheckPragma{} = "CheckPragma"+ pretty CheckPrimitive{} = "CheckPrimitive"+ pretty CheckModuleParameters{} = "CheckModuleParameters"+ 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"+ pretty CheckLocalRewriteConstraint{} = "CheckLocalRewriteConstraint"++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 fun _ _ _) = getRange fun+ getRange (CheckMetaSolution r _ _ _) = r+ getRange (CheckTargetType r _ _) = r+ getRange (CheckDataDef i _ _ _) = getRange i+ getRange (CheckRecDef i _ _ _) = getRange i+ getRange (CheckConstructor _ _ _ c) = getRange c+ getRange (CheckConArgFitsIn c _ _ _) = getRange c+ getRange (CheckFunDefCall i _ _) = getRange i+ getRange (CheckPragma r _) = r+ getRange (CheckPrimitive i _ _) = getRange i+ getRange (CheckModuleParameters _ tel) = getRange tel+ 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+ getRange (CheckLocalRewriteConstraint _ _) = noRange++----------------------------------------------------------------------------------------------------+-- ** Instance table+----------------------------------------------------------------------------------------------------++-- | Records information about the instances in the signature. Does not+-- deal with local instances.+data InstanceTable = InstanceTable+ { _itableTree :: DiscrimTree QName+ -- ^ The actual discrimination tree for looking up instances with++ , _itableCounts :: Map QName Int+ -- ^ For profiling, we store the number of instances on a per-class+ -- basis. This lets us compare the result from the discrimination+ -- tree with all the instances in scope, thus informing us how many+ -- validity checks were skipped.+ }+ deriving (Show, Generic)++instance Semigroup InstanceTable where+ InstanceTable t i <> InstanceTable t' i' = InstanceTable+ { _itableTree = t <> t'+ , _itableCounts = Map.unionWith (+) i i'+ }++instance Monoid InstanceTable where+ mempty = InstanceTable mempty mempty++instance Null InstanceTable where+ empty = mempty+ null (InstanceTable a b) = null a && null b++itableTree :: Lens' InstanceTable (DiscrimTree QName)+itableTree f s = f (_itableTree s) <&> \x -> s { _itableTree = x }++itableCounts :: Lens' InstanceTable (Map QName Int)+itableCounts f s = f (_itableCounts s) <&> \x -> s { _itableCounts = x }++-- | 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 BuiltinSort+ = SortUniv Univ+ | SortOmega Univ+ | SortIntervalUniv+ | SortLevelUniv+ deriving (Show, Eq, Generic)++pattern SortProp, SortSet, SortStrictSet, SortPropOmega, SortSetOmega, SortStrictSetOmega :: BuiltinSort+pattern SortProp = SortUniv UProp+pattern SortSet = SortUniv UType+pattern SortStrictSet = SortUniv USSet+pattern SortPropOmega = SortOmega UProp+pattern SortSetOmega = SortOmega UType+pattern SortStrictSetOmega = SortOmega USSet++{-# COMPLETE+ SortProp, SortSet, SortStrictSet,+ SortPropOmega, SortSetOmega, SortStrictSetOmega,+ SortIntervalUniv, SortLevelUniv #-}++data BuiltinDescriptor+ = BuiltinData (TCM Type) [BuiltinId]+ | BuiltinDataCons (TCM Type)+ | BuiltinPrim PrimitiveId (Term -> TCM ())+ | BuiltinSort BuiltinSort+ | 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 :: BuiltinId+ , builtinDesc :: BuiltinDescriptor }++type BuiltinThings = BuiltinThings' PrimFun+type BuiltinThings' pf = Map SomeBuiltin (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+----------------------------------------------------------------------------------------------------++-- | @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 ((e ^. eHighlightingLevel) >= l || b) $+ case e ^. eImportStack 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++----------------------------------------------------------------------------------------------------+-- * Boolean flag storage+----------------------------------------------------------------------------------------------------++newtype Flags64 = Flags64 Word64 deriving (Eq, Generic, NFData)++{-# INLINE mkFlag #-}+mkFlag :: Int -> Lens' Flags64 Bool+mkFlag !i = \f fs -> f (getFlag i fs) <&> \x -> setFlag i x fs++{-# INLINE setFlag #-}+setFlag :: Int -> Bool -> Flags64 -> Flags64+setFlag i b (Flags64 fs) =+ if b then Flags64 (unsafeShiftL 1 i .|. fs)+ else Flags64 (complement (unsafeShiftL 1 i) .&. fs)++{-# INLINE getFlag #-}+getFlag :: Int -> Flags64 -> Bool+getFlag !i (Flags64 !fs) = toEnum (fromIntegral (unsafeShiftR fs i .&. 1))++----------------------------------------------------------------------------------------------------+-- * Type checking environment+----------------------------------------------------------------------------------------------------+++data TCEnv = TCEnv {+ envTCContext :: !TCContext+ , envActiveProblems :: !(Set ProblemId)+ , envModalEnv :: !ModalEnv+ , envFlags :: !Flags64+ , envColdEnv :: !ColdEnv+ } deriving Generic++data TCContext = TCContext {+ envContext :: !Context+ , envCurrentCheckpoint :: !CheckpointId+ -- ^ Checkpoints track the evolution of the context as we go+ -- under binders or refine it by pattern matching.+ , envLocalRewriteRules :: LocalRewriteRuleMap+ , envCheckpoints :: Map CheckpointId Substitution+ -- ^ Keeps the substitution from each previous checkpoint to+ -- the current context.+ , envAppDef :: !(Maybe QName)+ -- ^ We are reducing an application of this function.+ -- (For tracking of incomplete matches.)+ } deriving Generic++data ModalEnv = ModalEnv {+ envRelevance :: !Relevance+ -- ^ Are we checking an irrelevant argument? (=@Irrelevant@)+ -- Then top-level irrelevant declarations are enabled.+ -- Other value: @Relevant@, then only relevant decls. are available.+ , envQuantity :: !Quantity+ -- ^ Are we checking a runtime-irrelevant thing? (='Quantity0')+ -- Then runtime-irrelevant things are usable.+ , envLetBindings :: !LetBindings+ , envAllowedReductions :: !AllowedReductions+ } deriving Generic+++data ColdEnv = ColdEnv {+ envCurrentModule :: ModuleName+ , 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'.+ , envCurrentPath :: Maybe FileId+ -- ^ 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+ , envImportStack :: [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+ , envCheckingWhere :: !C.WhereClause_+ -- ^ Have we stepped into the where-declarations of a clause?+ -- Everything under a @where@ will be checked with this flag on.+ , envUnquoteProblem :: !(Maybe ProblemId)+ -- ^ If inside a `runUnquoteM` call, stores the top-level problem id assigned to the+ -- invokation. We use this to decide which instance constraints originate from the+ -- current call and which come from the outside, for the purpose of a+ -- `solveInstanceConstraints` inside `noConstraints` only failing for local instance+ -- constraints.+ , 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.+ , 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.+ , envSimplification :: !Simplification+ -- ^ Did we encounter a simplification (proper match)+ -- during the current reduction process?+ , envReduceDefs :: !ReduceDefs+ , envInjectivityDepth :: !Int+ -- ^ Injectivity can cause non-termination for unsolvable contraints+ -- (#431, #3067). Keep a limit on the nesting depth of injectivity+ -- uses.+ , envUnquoteFlags :: !UnquoteFlags+ , envInstanceDepth :: !Int+ -- ^ Until we get a termination checker for instance search (#1743) we+ -- limit the search depth to ensure termination.+ , 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.+ , 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 TEnv@ is not derivable.+ -- The actual backend can be obtained from the name via 'stBackends'.+ , envCurrentOpaqueId :: !(Maybe OpaqueId)+ -- ^ Unique identifier of the opaque block we are+ -- currently under, if any. Used by the scope checker+ -- (to associate definitions to blocks), and by the type+ -- checker (for unfolding control).+ , envChasePrefix :: !(Maybe String)+ -- ^ A string to be used as the prefix for module chasing+ -- (Checking, Loading, etc.) messages. If unset, the length+ -- of the import stack is used.+ } deriving Generic++-- Bool Flags+----------------------------------------------------------------------------------------------------++{-# INLINE envReconstructed #-}+envReconstructed :: Lens' Flags64 Bool+envReconstructed = mkFlag 0++-- | 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.+{-# INLINE envCompareBlocked #-}+envCompareBlocked :: Lens' Flags64 Bool+envCompareBlocked = mkFlag 1++-- | When @True@, types will be omitted from printed pi types if they+-- can be inferred.+{-# INLINE envPrintDomainFreePi #-}+envPrintDomainFreePi :: Lens' Flags64 Bool+envPrintDomainFreePi = mkFlag 2++-- | 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@.+{-# INLINE envPrintMetasBare #-}+envPrintMetasBare :: Lens' Flags64 Bool+envPrintMetasBare = mkFlag 3++-- | Used by the scope checker to make sure that certain forms+-- of expressions are not used inside dot patterns: extended+-- lambdas and let-expressions.+{-# INLINE envInsideDotPattern #-}+envInsideDotPattern :: Lens' Flags64 Bool+envInsideDotPattern = mkFlag 4++{-# INLINE envIsDebugPrinting #-}+envIsDebugPrinting :: Lens' Flags64 Bool+envIsDebugPrinting = mkFlag 5++-- | Use call-by-need evaluation for reductions.+{-# INLINE envCallByNeed #-}+envCallByNeed :: Lens' Flags64 Bool+envCallByNeed = mkFlag 6++-- | are we inside a make-case (if so, ignore forcing analysis in unifier)+{-# INLINE envMakeCase #-}+envMakeCase :: Lens' Flags64 Bool+envMakeCase = mkFlag 7++-- | Are we currently in the process of solving active constraints?+{-# INLINE envSolvingConstraints #-}+envSolvingConstraints :: Lens' Flags64 Bool+envSolvingConstraints = mkFlag 8++-- | Are we allowed to assign metas?+{-# INLINE envAssignMetas #-}+envAssignMetas :: Lens' Flags64 Bool+envAssignMetas = mkFlag 9++-- | Is the \"hard\" compile-time mode enabled? In+-- this mode the quantity component of the environment+-- is always zero, and every new definition is treated+-- as erased.+{-# INLINE envHardCompileTimeMode #-}+envHardCompileTimeMode :: Lens' Flags64 Bool+envHardCompileTimeMode = mkFlag 10++-- | 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.+{-# INLINE envSplitOnStrict #-}+envSplitOnStrict :: Lens' Flags64 Bool+envSplitOnStrict = mkFlag 11++-- | Sometimes we want to disable display forms.+{-# INLINE envDisplayFormsEnabled #-}+envDisplayFormsEnabled :: Lens' Flags64 Bool+envDisplayFormsEnabled = mkFlag 12++-- | Fold let-bindings when printing terms (default: True)+{-# INLINE envFoldLetBindings #-}+envFoldLetBindings :: Lens' Flags64 Bool+envFoldLetBindings = mkFlag 13++-- | Are we currently computing the overlap between+-- two rewrite rules for the purpose of confluence checking?+{-# INLINE envConflComputingOverlap #-}+envConflComputingOverlap :: Lens' Flags64 Bool+envConflComputingOverlap = mkFlag 14++-- | Are we currently in the process of executing an+-- elaborate-and-give interactive command?+{-# INLINE envCurrentlyElaborating #-}+envCurrentlyElaborating :: Lens' Flags64 Bool+envCurrentlyElaborating = mkFlag 15++-- | Are we working on types? Turned on by 'workOnTypes'.+{-# INLINE envWorkingOnTypes #-}+envWorkingOnTypes :: Lens' Flags64 Bool+envWorkingOnTypes = mkFlag 16++-- | Are we doing pure conversion?+{-# INLINE envPureConversion #-}+envPureConversion :: Lens' Flags64 Bool+envPureConversion = mkFlag 17++-- | Are we doing implicit importing of primitive modules?+{-# INLINE envImplPrimitiveImporting #-}+envImplPrimitiveImporting :: Lens' Flags64 Bool+envImplPrimitiveImporting = mkFlag 18++-- | Choose between behavior in pure conversion and impure conversion.+-- The first branch is the impure case.+ifImpureConv :: TCM a -> TCM a -> TCM a+ifImpureConv impure pure = viewTC ePureConversion >>= \case+ True -> pure+ _ -> impure+{-# INLINE ifImpureConv #-}++-- Initial environment+----------------------------------------------------------------------------------------------------++initEnvFlags :: Flags64+initEnvFlags = Flags64 0+ & envAssignMetas .~ True+ & envSolvingConstraints .~ False+ & envReconstructed .~ False+ & envCompareBlocked .~ False+ & envPrintDomainFreePi .~ False+ & envPrintMetasBare .~ False+ & envInsideDotPattern .~ False+ & envIsDebugPrinting .~ False+ & envCallByNeed .~ True+ & envConflComputingOverlap .~ False+ & envCurrentlyElaborating .~ False+ & envHardCompileTimeMode .~ False+ & envSplitOnStrict .~ False+ & envDisplayFormsEnabled .~ True+ & envFoldLetBindings .~ True+ & envMakeCase .~ False+ & envPureConversion .~ False+ & envImplPrimitiveImporting .~ False++initTCContext :: TCContext+initTCContext = TCContext {+ envContext = CxEmpty+ , envCurrentCheckpoint = 0+ , envCheckpoints = Map.singleton 0 IdS+ , envLocalRewriteRules = empty+ , envAppDef = Nothing+ }++initModalEnv :: ModalEnv+initModalEnv = ModalEnv {+ envRelevance = unitRelevance+ , envQuantity = unitQuantity+ , envLetBindings = Map.empty+ , envAllowedReductions = allReductions+ }++initColdEnv :: ColdEnv+initColdEnv = ColdEnv {+ envCurrentModule = noModuleName+ , envCurrentPath = Nothing+ , envSyntacticEqualityFuel = Strict.Nothing+ , envAnonymousModules = []+ , envImportStack = []+ , envMutualBlock = Nothing+ , envTerminationCheck = TerminationCheck+ , envCoverageCheck = YesCoverageCheck+ , envCheckingWhere = C.NoWhere_+ , envUnquoteProblem = Nothing+ , 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').+ , envRange = noRange+ , envHighlightingRange = noRange+ , envClause = IPNoClause+ , envCall = Nothing+ , envHighlightingLevel = None+ , envHighlightingMethod = Indirect+ , envExpandLast = ExpandLast+ , envSimplification = NoSimplification+ , envReduceDefs = reduceAllDefs+ , envInjectivityDepth = 0+ , envUnquoteFlags = defaultUnquoteFlags+ , envInstanceDepth = 0+ , envPrintingPatternLambdas = []+ , envGeneralizeMetas = NoGeneralize+ , envGeneralizedVars = Map.empty+ , envActiveBackendName = Nothing+ , envCurrentOpaqueId = Nothing+ , envChasePrefix = Nothing+ }++initEnv :: TCEnv+initEnv = TCEnv {+ envTCContext = initTCContext+ , envFlags = initEnvFlags+ , envActiveProblems = Set.empty+ , envModalEnv = initModalEnv+ , envColdEnv = initColdEnv+ }+++-- * e-prefixed lenses+----------------------------------------------------------------------------------------------------++{-# INLINE eUnquoteProblem #-}+eUnquoteProblem :: Lens' TCEnv (Maybe ProblemId)+eUnquoteProblem = \f e ->+ f (envUnquoteProblem (envColdEnv e)) <&> \ !x -> e {envColdEnv = (envColdEnv e){envUnquoteProblem = x}}++{-# INLINE eClause #-}+eClause :: Lens' TCEnv IPClause+eClause = \f e ->+ f (envClause (envColdEnv e)) <&> \ !x -> e {envColdEnv = (envColdEnv e){envClause = x}}++{-# INLINE eSyntacticEqualityFuel #-}+eSyntacticEqualityFuel :: Lens' TCEnv (Strict.Maybe Int)+eSyntacticEqualityFuel = \f e ->+ f (envSyntacticEqualityFuel (envColdEnv e)) <&> \ !x -> e {envColdEnv = (envColdEnv e) {envSyntacticEqualityFuel = x}}++{-# INLINE eCurrentOpaqueId #-}+eCurrentOpaqueId :: Lens' TCEnv (Maybe OpaqueId)+eCurrentOpaqueId = \f e ->+ f (envCurrentOpaqueId (envColdEnv e)) <&> \ !x -> e {envColdEnv = (envColdEnv e){envCurrentOpaqueId = x}}++{-# INLINE eChasePrefix #-}+eChasePrefix :: Lens' TCEnv (Maybe String)+eChasePrefix = \f e ->+ f (envChasePrefix (envColdEnv e)) <&> \ !x -> e {envColdEnv = (envColdEnv e){envChasePrefix = x}}++{-# INLINE eContext #-}+eContext :: Lens' TCEnv Context+eContext = \f e ->+ f (envContext (envTCContext e)) <&> \ !x -> e {envTCContext = (envTCContext e){envContext = x}}++{-# INLINE eLetBindings #-}+eLetBindings :: Lens' TCEnv LetBindings+eLetBindings = \f e ->+ f (envLetBindings (envModalEnv e)) <&> \ !x -> e {envModalEnv = (envModalEnv e){envLetBindings = x}}++{-# INLINE eCurrentModule #-}+eCurrentModule :: Lens' TCEnv ModuleName+eCurrentModule = \f e ->+ f (envCurrentModule (envColdEnv e)) <&> \ !x -> e {envColdEnv = (envColdEnv e){envCurrentModule = x}}++{-# INLINE eCurrentPath #-}+eCurrentPath :: Lens' TCEnv (Maybe FileId)+eCurrentPath = \f e ->+ f (envCurrentPath $ envColdEnv e) <&> \ !x -> e {envColdEnv = (envColdEnv e){ envCurrentPath = x }}++{-# INLINE eAnonymousModules #-}+eAnonymousModules :: Lens' TCEnv [(ModuleName, Nat)]+eAnonymousModules = \f e ->+ f (envAnonymousModules $ envColdEnv e) <&> \ !x -> e {envColdEnv = (envColdEnv e) {envAnonymousModules = x }}++{-# INLINE eImportStack #-}+eImportStack :: Lens' TCEnv [TopLevelModuleName]+eImportStack = \f e ->+ f (envImportStack $ envColdEnv e) <&> \ !x -> e {envColdEnv = (envColdEnv e){ envImportStack = x }}++{-# INLINE eMutualBlock #-}+eMutualBlock :: Lens' TCEnv (Maybe MutualId)+eMutualBlock = \f e ->+ f (envMutualBlock $ envColdEnv e) <&> \ !x -> e {envColdEnv = (envColdEnv e){ envMutualBlock = x }}++{-# INLINE eTerminationCheck #-}+eTerminationCheck :: Lens' TCEnv (TerminationCheck ())+eTerminationCheck = \f e ->+ f (envTerminationCheck $ envColdEnv e) <&> \ !x -> e {envColdEnv = (envColdEnv e) { envTerminationCheck = x }}++{-# INLINE eCoverageCheck #-}+eCoverageCheck :: Lens' TCEnv CoverageCheck+eCoverageCheck = \f e ->+ f (envCoverageCheck $ envColdEnv e) <&> \ !x -> e {envColdEnv = (envColdEnv e){ envCoverageCheck = x }}++{-# INLINE eCheckingWhere #-}+eCheckingWhere :: Lens' TCEnv C.WhereClause_+eCheckingWhere = \f e ->+ f (envCheckingWhere $ envColdEnv e) <&> \ !x -> e {envColdEnv = (envColdEnv e){ envCheckingWhere = x }}++{-# INLINE eActiveProblems #-}+eActiveProblems :: Lens' TCEnv (Set ProblemId)+eActiveProblems = \f e ->+ f (envActiveProblems e) <&> \ !x -> e { envActiveProblems = x }++{-# INLINE eAbstractMode #-}+eAbstractMode :: Lens' TCEnv AbstractMode+eAbstractMode = \f e ->+ f (envAbstractMode $ envColdEnv e) <&> \ !x -> e {envColdEnv = (envColdEnv e){ envAbstractMode = x }}++{-# INLINE eRelevance #-}+eRelevance :: Lens' TCEnv Relevance+eRelevance = \f e ->+ f (envRelevance $ envModalEnv e) <&> \ !x -> e {envModalEnv = (envModalEnv e){ envRelevance = x }}++{-# INLINE eRange #-}+eRange :: Lens' TCEnv Range+eRange = \f e -> f (envRange $ envColdEnv e) <&> \ x -> e {envColdEnv = (envColdEnv e){ envRange = x }}++{-# INLINE eHighlightingRange #-}+eHighlightingRange :: Lens' TCEnv Range+eHighlightingRange = \f e ->+ f (envHighlightingRange $ envColdEnv e) <&> \ x -> e {envColdEnv = (envColdEnv e){ envHighlightingRange = x }}++{-# INLINE eCall #-}+eCall :: Lens' TCEnv (Maybe (Closure Call))+eCall = \f e -> f (envCall $ envColdEnv e) <&> \ x -> e {envColdEnv = (envColdEnv e){ envCall = x }}++{-# INLINE eHighlightingLevel #-}+eHighlightingLevel :: Lens' TCEnv HighlightingLevel+eHighlightingLevel = \f e ->+ f (envHighlightingLevel $ envColdEnv e) <&> \ !x -> e {envColdEnv = (envColdEnv e){ envHighlightingLevel = x }}++{-# INLINE eHighlightingMethod #-}+eHighlightingMethod :: Lens' TCEnv HighlightingMethod+eHighlightingMethod = \f e ->+ f (envHighlightingMethod $ envColdEnv e) <&> \ !x -> e {envColdEnv = (envColdEnv e){ envHighlightingMethod = x }}++{-# INLINE eExpandLast #-}+eExpandLast :: Lens' TCEnv ExpandHidden+eExpandLast = \f e ->+ f (envExpandLast $ envColdEnv e) <&> \ !x -> e {envColdEnv = (envColdEnv e){ envExpandLast = x }}++{-# INLINE eExpandLastBool #-}+eExpandLastBool :: Lens' TCEnv Bool+eExpandLastBool = \f e ->+ f (isExpandLast $ envExpandLast $ envColdEnv e) <&> \ x -> e {envColdEnv = (envColdEnv e){ envExpandLast = toExpandLast x }}++{-# INLINE eAppDef #-}+eAppDef :: Lens' TCEnv (Maybe QName)+eAppDef = \f e ->+ f (envAppDef $ envTCContext e) <&> \ x -> e {envTCContext = (envTCContext e){ envAppDef = x }}++{-# INLINE eSimplification #-}+eSimplification :: Lens' TCEnv Simplification+eSimplification = \f e ->+ f (envSimplification $ envColdEnv e) <&> \ x -> e {envColdEnv = (envColdEnv e){ envSimplification = x }}++{-# INLINE eAllowedReductions #-}+eAllowedReductions :: Lens' TCEnv AllowedReductions+eAllowedReductions = \f e ->+ f (envAllowedReductions $ envModalEnv e) <&> \ x -> e {envModalEnv = (envModalEnv e) {envAllowedReductions = x }}++{-# INLINE eReduceDefs #-}+eReduceDefs :: Lens' TCEnv ReduceDefs+eReduceDefs = \f e ->+ f (envReduceDefs $ envColdEnv e) <&> \ x -> e {envColdEnv = (envColdEnv e){ envReduceDefs = x }}++{-# INLINE eReduceDefsPair #-}+eReduceDefsPair :: Lens' TCEnv (Bool, [QName])+eReduceDefsPair = \f e ->+ f (fromReduceDefs $ envReduceDefs $ envColdEnv e) <&> \ x -> e {envColdEnv = (envColdEnv e){ envReduceDefs = toReduceDefs x }}++{-# INLINE eInjectivityDepth #-}+eInjectivityDepth :: Lens' TCEnv Int+eInjectivityDepth = \f e ->+ f (envInjectivityDepth $ envColdEnv e) <&> \ x -> e {envColdEnv = (envColdEnv e){ envInjectivityDepth = x }}++{-# INLINE eUnquoteFlags #-}+eUnquoteFlags :: Lens' TCEnv UnquoteFlags+eUnquoteFlags = \f e ->+ f (envUnquoteFlags $ envColdEnv e) <&> \ x -> e {envColdEnv = (envColdEnv e){ envUnquoteFlags = x }}++{-# INLINE eInstanceDepth #-}+eInstanceDepth :: Lens' TCEnv Int+eInstanceDepth = \f e ->+ f (envInstanceDepth $ envColdEnv e) <&> \ x -> e {envColdEnv = (envColdEnv e){ envInstanceDepth = x }}++{-# INLINE ePrintingPatternLambdas #-}+ePrintingPatternLambdas :: Lens' TCEnv [QName]+ePrintingPatternLambdas = \f e ->+ f (envPrintingPatternLambdas $ envColdEnv e) <&> \ x -> e {envColdEnv = (envColdEnv e){ envPrintingPatternLambdas = x }}++{-# INLINE eCurrentCheckpoint #-}+eCurrentCheckpoint :: Lens' TCEnv CheckpointId+eCurrentCheckpoint = \f e ->+ f (envCurrentCheckpoint $ envTCContext e) <&> \ x -> e {envTCContext = (envTCContext e){ envCurrentCheckpoint = x }}++{-# INLINE eLocalRewriteRules #-}+eLocalRewriteRules :: Lens' TCEnv LocalRewriteRuleMap+eLocalRewriteRules = \f e ->+ f (envLocalRewriteRules $ envTCContext e) <&> \ x -> e {envTCContext = (envTCContext e){ envLocalRewriteRules = x }}++{-# INLINE eCheckpoints #-}+eCheckpoints :: Lens' TCEnv (Map CheckpointId Substitution)+eCheckpoints = \f e ->+ f (envCheckpoints $ envTCContext e) <&> \ x -> e {envTCContext = (envTCContext e){ envCheckpoints = x }}++{-# INLINE eGeneralizeMetas #-}+eGeneralizeMetas :: Lens' TCEnv DoGeneralize+eGeneralizeMetas = \f e ->+ f (envGeneralizeMetas $ envColdEnv e) <&> \ x -> e {envColdEnv = (envColdEnv e){ envGeneralizeMetas = x }}++{-# INLINE eGeneralizedVars #-}+eGeneralizedVars :: Lens' TCEnv (Map QName GeneralizedValue)+eGeneralizedVars = \f e ->+ f (envGeneralizedVars $ envColdEnv e) <&> \ x -> e {envColdEnv = (envColdEnv e){ envGeneralizedVars = x }}++{-# INLINE eActiveBackendName #-}+eActiveBackendName :: Lens' TCEnv (Maybe BackendName)+eActiveBackendName = \f e ->+ f (envActiveBackendName $ envColdEnv e) <&> \ x -> e {envColdEnv = (envColdEnv e){ envActiveBackendName = x }}++{-# INLINE eQuantity #-}+eQuantity :: Lens' TCEnv Quantity+eQuantity = \f e ->+ f (envQuantity $ envModalEnv e) <&> \ x -> e {envModalEnv = (envModalEnv e){ envQuantity = x }}++----------------------------------------------------------------------------------------------------++{-# INLINE mkEnvFlag #-}+mkEnvFlag :: Int -> Lens' TCEnv Bool+mkEnvFlag i = \f s ->+ let old = getFlag i (envFlags s) in+ f old <&> \b ->+ -- avoiding copy on unchanged flags+ if b == old then s else s {envFlags = setFlag i b (envFlags s)}++{-# INLINE eReconstructed #-}+eReconstructed :: Lens' TCEnv Bool+eReconstructed = mkEnvFlag 0++{-# INLINE eCompareBlocked #-}+eCompareBlocked :: Lens' TCEnv Bool+eCompareBlocked = mkEnvFlag 1++{-# INLINE ePrintDomainFreePi #-}+ePrintDomainFreePi :: Lens' TCEnv Bool+ePrintDomainFreePi = mkEnvFlag 2++{-# INLINE ePrintMetasBare #-}+ePrintMetasBare :: Lens' TCEnv Bool+ePrintMetasBare = mkEnvFlag 3++{-# INLINE eInsideDotPattern #-}+eInsideDotPattern :: Lens' TCEnv Bool+eInsideDotPattern = mkEnvFlag 4++{-# INLINE eIsDebugPrinting #-}+eIsDebugPrinting :: Lens' TCEnv Bool+eIsDebugPrinting = mkEnvFlag 5++{-# INLINE eCallByNeed #-}+eCallByNeed :: Lens' TCEnv Bool+eCallByNeed = mkEnvFlag 6++{-# INLINE eMakeCase #-}+eMakeCase :: Lens' TCEnv Bool+eMakeCase = mkEnvFlag 7++{-# INLINE eSolvingConstraints #-}+eSolvingConstraints :: Lens' TCEnv Bool+eSolvingConstraints = mkEnvFlag 8++{-# INLINE eAssignMetas #-}+eAssignMetas :: Lens' TCEnv Bool+eAssignMetas = mkEnvFlag 9++{-# INLINE eHardCompileTimeMode #-}+eHardCompileTimeMode :: Lens' TCEnv Bool+eHardCompileTimeMode = mkEnvFlag 10++{-# INLINE eSplitOnStrict #-}+eSplitOnStrict :: Lens' TCEnv Bool+eSplitOnStrict = mkEnvFlag 11++{-# INLINE eDisplayFormsEnabled #-}+eDisplayFormsEnabled :: Lens' TCEnv Bool+eDisplayFormsEnabled = mkEnvFlag 12++{-# INLINE eFoldLetBindings #-}+eFoldLetBindings :: Lens' TCEnv Bool+eFoldLetBindings = mkEnvFlag 13++{-# INLINE eConflComputingOverlap #-}+eConflComputingOverlap :: Lens' TCEnv Bool+eConflComputingOverlap = mkEnvFlag 14++{-# INLINE eCurrentlyElaborating #-}+eCurrentlyElaborating :: Lens' TCEnv Bool+eCurrentlyElaborating = mkEnvFlag 15++{-# INLINE eWorkingOnTypes #-}+eWorkingOnTypes :: Lens' TCEnv Bool+eWorkingOnTypes = mkEnvFlag 16++{-# INLINE ePureConversion #-}+ePureConversion :: Lens' TCEnv Bool+ePureConversion = mkEnvFlag 17++{-# INLINE eImplPrimitiveImporting #-}+eImplPrimitiveImporting :: Lens' TCEnv Bool+eImplPrimitiveImporting = mkEnvFlag 18+++----------------------------------------------------------------------------------------------------++++{-# INLINE eQuantityZeroHardCompile #-}+-- | Note that this lens does not satisfy all lens laws: If hard+-- compile-time mode is enabled, then quantities other than zero are+-- replaced by '__IMPOSSIBLE__'.+eQuantityZeroHardCompile :: Lens' TCEnv Quantity+eQuantityZeroHardCompile f e =+ if e ^. eHardCompileTimeMode+ then f (check (e ^. eQuantity)) <&> \ !x -> e & eQuantity .~ check x+ else f (e ^. eQuantity) <&> \ !x -> e & eQuantity .~ x+ where+ check q+ | hasQuantity0 q = q+ | otherwise = __IMPOSSIBLE__++----------------------------------------------------------------------------------------------------++class LensTCEnv a where+ lensTCEnv :: Lens' a TCEnv++instance LensTCEnv TCEnv where+ lensTCEnv = id++data UnquoteFlags = UnquoteFlags { _unquoteNormalise :: Bool }+ deriving Generic++defaultUnquoteFlags :: UnquoteFlags+defaultUnquoteFlags = UnquoteFlags+ { _unquoteNormalise = False }++unquoteNormalise :: Lens' UnquoteFlags Bool+unquoteNormalise f e = f (_unquoteNormalise e) <&> \ x -> e { _unquoteNormalise = x }++eUnquoteNormalise :: Lens' TCEnv Bool+eUnquoteNormalise = eUnquoteFlags . unquoteNormalise++{-# SPECIALISE currentModality :: TCM Modality #-}+-- | The current modality.+-- Note that the returned cohesion component is always 'unitCohesion'.+currentModality :: MonadTCEnv m => m Modality+currentModality = do+ r <- viewTC eRelevance+ q <- viewTC eQuantityZeroHardCompile+ return Modality+ { modRelevance = r+ , modPolarity = defaultPolarity+ , modQuantity = q+ , modCohesion = unitCohesion+ }++----------------------------------------------------------------------------------------------------+-- ** Let bindings+----------------------------------------------------------------------------------------------------++type LetBindings = Map Name (Open LetBinding)++data LetBinding = LetBinding+ { letAxiom :: IsAxiom -- ^ Does this let binding origin from a 'LetAxiom'?+ , letOrigin :: Origin+ , letTerm :: Term+ , letType :: Dom Type+ }+ deriving (Show, Generic)++onLetBindingType :: (Dom Type -> Dom Type) -> LetBinding -> LetBinding+onLetBindingType f b = b { letType = f $ letType b }++data IsAxiom+ = YesAxiom+ | NoAxiom+ deriving (Eq, Show, Generic)++----------------------------------------------------------------------------------------------------+-- ** 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++----------------------------------------------------------------------------------------------------+-- ** Opaque blocks+----------------------------------------------------------------------------------------------------++-- | A block of opaque definitions.+data OpaqueBlock = OpaqueBlock+ { opaqueId :: {-# UNPACK #-} !OpaqueId+ -- ^ Unique identifier for this block.+ , opaqueUnfolding :: HashSet QName+ -- ^ Set of names we are allowed to unfold. After scope-checking,+ -- this set should be transitively closed.+ , opaqueDecls :: HashSet QName+ -- ^ Declarations contained in this abstract block.+ , opaqueParent :: Maybe OpaqueId+ -- ^ Pointer to an enclosing opaque block, if one exists.+ , opaqueRange :: Range+ -- ^ Where is this opaque block?+ } deriving (Show, Generic)++instance Pretty OpaqueBlock where+ pretty (OpaqueBlock _ uf ds p _) = vcat+ $ [ "opaque (extends " <> pretty p <> ") {"+ , nest 2 "unfolds"+ ]+ ++ [ nest 4 (pretty n <> ",") | n <- List.sort $ HashSet.toList uf ]+ -- Andreas, 2023-08-10, https://github.com/agda/agda/pull/6628#discussion_r1285078454+ -- The HashSet.toList is non-deterministic, order may depend on version of @hashable@.+ -- Thus, we sort the list, so that the output isn't dependent on the specific build.+ ++ [ nest 2 "declares" ]+ ++ [ nest 4 (pretty n <+> ": _") | n <- List.sort $ HashSet.toList ds ]+ ++ [ "}" ]++instance Eq OpaqueBlock where+ xs == ys = opaqueId xs == opaqueId ys++instance Hashable OpaqueBlock where+ hashWithSalt s = hashWithSalt s . opaqueId++----------------------------------------------------------------------------------------------------+-- ** 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)++isExpandLast :: ExpandHidden -> Bool+isExpandLast ExpandLast = True+isExpandLast DontExpandLast = False+isExpandLast ReallyDontExpandLast = False++isDontExpandLast :: ExpandHidden -> Bool+isDontExpandLast = not . isExpandLast++toExpandLast :: Bool -> ExpandHidden+toExpandLast True = ExpandLast+toExpandLast False = DontExpandLast++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+ , candidateOverlap :: OverlapMode+ }+ deriving (Show, Generic)++instance Free Candidate where+ freeVars c = expand \ret -> case c of+ Candidate _ t u _ -> ret $ freeVars (t, u)++instance HasOverlapMode Candidate where+ lensOverlapMode f x = f (candidateOverlap x) <&> \m -> x{ candidateOverlap = m }++----------------------------------------------------------------------------------------------------+-- ** Checking arguments+----------------------------------------------------------------------------------------------------++data CheckedArg = CheckedArg+ { caElim :: Elim+ -- ^ Checked and inserted argument.+ , caRange :: Range+ -- ^ Range of checked argument, where present.+ -- E.g. inserted implicits have no correponding abstract syntax.+ , caConstraint :: Maybe (Abs Constraint)+ -- ^ Head constraint before applying the argument.+ }+ deriving Show++data ArgsCheckState a = ACState+ { acCheckedArgs :: [CheckedArg]+ -- ^ Checked and inserted arguments so far.+ , acFun :: A.Expr+ -- ^ The function applied to the already checked arguments.+ , acType :: Type+ -- ^ Type of the function (for checking the remaining arguments).+ , 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 (List1 TerminationError)+ | UnreachableClauses QName (List1 Range)+ -- ^ @UnreachableClauses f rs@ means that the clauses in @f@ whose ranges are @rs@+ -- are unreachable.+ | CoverageIssue QName (List1 (Telescope, [NamedArg DeBruijnPattern]))+ -- ^ `CoverageIssue f pss` means that `pss` are not covered in `f`+ | CoverageNoExactSplit QName (List1 Clause)+ | InlineNoExactSplit QName Clause+ -- ^ 'Clause' was turned into copattern matching clause(s) by an @{-# INLINE constructor #-}@+ -- and thus is not a definitional equality any more.+ | NotStrictlyPositive QName (Seq W.OccursWhere)+ | ConstructorDoesNotFitInData DataOrRecord_ QName Sort Sort TCErr+ -- ^ Checking whether constructor 'QName' 'Sort' fits into @data@ 'Sort'+ -- produced 'TCErr'.+ | CoinductiveEtaRecord QName+ -- ^ A record type declared as both @coinductive@ and having @eta-equality@.+ | UnguardedEtaRecordW QName+ -- ^ A record type with @eta-equality@ which unguarded.+ -- This warning can be switched off via the @ETA_EQUALITY@ pragma.++ | UnsolvedMetaVariables (Set1 Range) -- ^ Do not use directly with 'warning'+ | UnsolvedInteractionMetas (Set1 Range) -- ^ Do not use directly with 'warning'+ | UnsolvedConstraints (List1 ProblemConstraint) -- no instance Ord ProblemConstraint+ -- ^ Do not use directly with 'warning'+ | InteractionMetaBoundaries (Set1 Range)+ -- ^ Do not use directly with 'warning'++ | CantGeneralizeOverSorts (Set1 MetaId)+ | AbsurdPatternRequiresAbsentRHS+ | OldBuiltin BuiltinId BuiltinId+ -- ^ In `OldBuiltin old new`, the BUILTIN old has been replaced by new.+ | BuiltinDeclaresIdentifier BuiltinId+ -- ^ The builtin declares a new identifier, so it should not be in scope.+ | DuplicateRecordDirective C.RecordDirective+ -- ^ The given record directive is conflicting with a prior one in the same record declaration.+ | EmptyRewritePragma+ -- ^ If the user wrote just @{-\# REWRITE \#-}@.+ | EmptyWhere+ -- ^ An empty @where@ block is dead code.+ -- TODO: linearity+ -- -- | FixingQuantity String Quantity Quantity+ -- -- -- ^ Auto-correcting quantity pertaining to 'String' /from/ /to/.+ | FixingRelevance String Relevance Relevance+ -- ^ Auto-correcting relevance pertaining to 'String' /from/ /to/.+ | FixingCohesion String Cohesion Cohesion+ -- ^ Auto-correcting cohesion pertaining to 'String' /from/ /to/.+ | FixingPolarity String PolarityModality PolarityModality+ -- ^ Auto-correcting polarity pertaining to 'String' /from/ /to/.+ | IgnoringRew String RewriteAnn+ -- ^ Auto-correcting rewrite pertaining to 'String' by ignoring it+ | 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.+ | InvalidCharacterLiteral Char+ -- ^ A character literal Agda does not support, e.g. surrogate code points.+ | ClashesViaRenaming NameOrModule (Set1 C.Name)+ -- ^ If a `renaming' import directive introduces a name or module name clash+ -- in the exported names of a module.+ -- (See issue #4154.)+ | UnusedImports A.ModuleName (Maybe (List1 C.ImportedName))+ -- ^ The given module was opened but the names and modules in the list were not used.+ -- They are given as they are in scope after the opening,+ -- with the ranges from the opening directive (if any).+ -- If 'Nothing', then none of the imported names and modules was used.+ | UselessPatternDeclarationForRecord String+ -- ^ The 'pattern' declaration is useless in the presence+ -- of either @coinductive@ or @eta-equality@.+ -- Content of 'String' is "coinductive" or "eta", resp.+ | UselessPragma Range Doc+ -- ^ Warning when pragma is useless and thus ignored.+ -- 'Range' is for dead code highlighting.+ | UselessPublic UselessPublicReason+ -- ^ If the user opens a module public before the module header.+ -- (See issue #2377.)+ | UselessHiding (List1 C.ImportedName)+ -- ^ Names in `hiding` directive that don't hide anything+ -- imported by a `using` directive.+ | UselessInline QName+ | UselessTactic+ -- ^ A tactic attribute applied to a non-hidden (visible or instance) argument.+ | WrongInstanceDeclaration KwRange+ -- ^ The 'KwRange' is the range of the @instance@ keyword.+ | InstanceWithExplicitArg KwRange QName+ -- ^ An instance was declared with an implicit argument, which means it+ -- will never actually be considered by instance search.+ -- The 'KwRange' is the range of the @instance@ keyword.+ | 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.++ -- Safe flag errors+ | SafeFlagPostulate QName+ | SafeFlagPragma (Set String)+ -- ^ Unsafe OPTIONS.+ | SafeFlagWithoutKFlagPrimEraseEquality+ | WithoutKFlagPrimEraseEquality+ | ConflictingPragmaOptions String String+ -- ^ `ConflictingPragmaOptions a b`:+ -- Inconsistent options `--a` and `--no-b`, since `--a` implies `--b`. Ignoring `--no-b`.+ | OptionWarning OptionWarning+ | ParseWarning ParseWarning+ | LibraryWarning LibWarning+ | DeprecationWarning String (Maybe String) String+ -- ^ @DeprecationWarning old new version@:+ -- @old@ is deprecated, use @new@ instead (if given).+ -- This will be an error in @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] (List1 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+ | ConfluenceCheckingIncompleteBecauseOfMeta QName+ -- ^ Confluence checking incomplete because the definition of the 'QName'+ -- contains unsolved metavariables.+ | ConfluenceForCubicalNotSupported+ -- ^ Confluence checking with @--cubical@ might be incomplete.+ | NotARewriteRule C.QName IsAmbiguous+ -- ^ 'IllegalRewriteRule' detected during scope checking.+ | IllegalRewriteRule SerialisableRewriteSource IllegalRewriteRuleReason+ | 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)@.+ | InferredLocalRewrite MetaId Term+ -- ^ Inferred that some meta should be solved with an @rewrite function+ -- (We never infer local rewrite rules)+ | PragmaCompileErased BackendName QName+ -- ^ COMPILE directive for an erased symbol.+ | PragmaCompileList+ -- ^ @COMPILE GHC@ pragma for lists; ignored.+ | PragmaCompileMaybe+ -- ^ @COMPILE GHC@ pragma for @MAYBE@; ignored.+ | PragmaCompileUnparsable String+ -- ^ @COMPILE GHC@ pragma 'String' not parsable; ignored.+ | PragmaCompileWrong QName String+ -- ^ Wrong @COMPILE GHC@ given for 'QName'; explanation is in 'String'.+ | PragmaCompileWrongName C.QName IsAmbiguous+ -- ^ @COMPILE@ pragma with name 'C.QName' that is not an unambiguous constructor or definition.+ | PragmaExpectsDefinedSymbol String C.QName+ -- ^ Pragma 'String' with name 'C.QName' that is not an 'A.Def'.+ | PragmaExpectsUnambiguousConstructorOrFunction String C.QName IsAmbiguous+ -- ^ Pragma 'String' with name 'C.QName' that is not an unambiguous constructor or definition.+ -- General form of 'PragmaCompileWrongName' and 'NotARewriteRule'.+ | PragmaExpectsUnambiguousProjectionOrFunction String C.QName IsAmbiguous+ -- ^ Pragma 'String' with name 'C.QName' that is not an unambiguous projection or function.+ | UnknownJSPrimitive String+ -- ^ A primitive was compiled to @Undefined@ by the JS backend+ -- because it was not listed in the known or intentionally+ -- undefined primitives.+ | NoMain TopLevelModuleName+ -- ^ Compiler run on module that does not have a @main@ function.+ | NotInScopeW C.QName+ -- ^ Out of scope error we can recover from.+ | UnsupportedIndexedMatch Doc+ -- ^ Was not able to compute a full equivalence when splitting.+ | AsPatternShadowsConstructorOrPatternSynonym ConstructorOrPatternSynonym+ -- ^ The as-name in an as-pattern may not shadow a constructor+ -- or pattern synonym name,+ -- because this can be confusing to read.+ | PatternShadowsConstructor C.Name A.QName+ -- ^ A pattern variable has the name of a constructor+ -- (data constructor or matchable record constructor).+ | PlentyInHardCompileTimeMode QωOrigin+ -- ^ Explicit use of @@ω@ or @@plenty@ in hard compile-time mode.+ | RecordFieldWarning RecordFieldWarning++ -- Opaque+ | MissingTypeSignatureForOpaque QName IsOpaque+ -- ^ An @abstract@ or @opaque@ definition lacks a type signature.+ | NotAffectedByOpaque+ | UnfoldingWrongName C.QName+ -- ^ Name in @unfolding@ clause does not resolve to unambiguous defined name.+ | UnfoldTransparentName QName+ | UselessOpaque++ -- Recoverable scope-checking errors+ | HiddenNotInArgumentPosition C.Expr+ | InstanceNotInArgumentPosition C.Expr+ | MacroInLetBindings+ | AbstractInLetBindings+ | IllegalDeclarationInDataDefinition (List1 C.Declaration)+ -- ^ The declaration list comes from a single 'C.NiceDeclaration'.++ -- Display form warnings+ | InvalidDisplayForm QName String+ -- ^ DISPLAY form for 'QName' is invalid because 'String'.+ | UnusedVariablesInDisplayForm (List1 A.Name)+ -- ^ The given names are bound in the lhs of the display form+ -- but not used on the rhs.+ -- This can indicate a user misunderstanding of display forms.++ -- Type checker warnings+ | ShouldBeEtaRecordPattern+ -- ^ Irrefutable match (match in binder) on a non-eta record pattern.+ -- Some expected definitional equalities will not hold.+ | TooManyArgumentsToSort QName (List1 (NamedArg A.Expr))+ -- ^ Extra arguments to sort (will be ignored).+ | DefinitionBeforeDeclaration A.AbstractName+ -- ^ A definition appears before its declaration in a @mutual@ block.+ | RewritesNothing+ -- ^ A @rewrite@ expression that does not fire.+ | WithClauseProjectionFixityMismatch+ { withClausePattern :: NamedArg A.Pattern+ , withClauseProjectionOrigin :: ProjOrigin+ , parentPattern :: NamedArg DeBruijnPattern+ , parentProjectionOrigin :: ProjOrigin+ }+ -- ^ The with-clause uses projection in a different fixity style+ -- than the parent clause.+ | RecursiveRecordNeedsInductivity QName+ -- ^ A record type inferred as recursive needs a manual declaration+ -- whether it should be inductively or coinductively.++ -- Polarity warnings+ | TooManyPolarities QName PragmaPolarities+ -- ^ Too many polarities given in POLARITY pragma for 'QName'.+ -- 'PragmaPolarities' contains the (likely) excessive polarities.+ | TopLevelPolarity QName PolarityModality+ -- ^ Definition with non-default polarity annotation.++ -- Cubical+ | FaceConstraintCannotBeHidden ArgInfo+ -- ^ Face constraint patterns @(i = 0)@ must be visible arguments.+ | FaceConstraintCannotBeNamed NamedName+ -- ^ Face constraint patterns @(i = 0)@ must be unnamed arguments.++ -- Not source code related+ | CustomBackendWarning String Doc+ -- ^ Used for backend-specific warnings. The string is the backend name.+ deriving (Show, Generic)++recordFieldWarningToError :: RecordFieldWarning -> TypeError+recordFieldWarningToError = \case+ W.DuplicateFields xrs -> DuplicateFields $ fmap fst xrs+ W.TooManyFields q ys xrs -> TooManyFields q ys $ fmap 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+ -- scope- and type-checking errors+ AsPatternShadowsConstructorOrPatternSynonym{} -> AsPatternShadowsConstructorOrPatternSynonym_+ PatternShadowsConstructor{} -> PatternShadowsConstructor_+ AbsurdPatternRequiresAbsentRHS{} -> AbsurdPatternRequiresAbsentRHS_+ CantGeneralizeOverSorts{} -> CantGeneralizeOverSorts_+ CoverageIssue{} -> CoverageIssue_+ CoverageNoExactSplit{} -> CoverageNoExactSplit_+ InlineNoExactSplit{} -> InlineNoExactSplit_+ DeprecationWarning{} -> DeprecationWarning_+ DuplicateRecordDirective{} -> DuplicateRecordDirective_+ EmptyRewritePragma -> EmptyRewritePragma_+ EmptyWhere -> EmptyWhere_+ -- TODO: linearity+ -- FixingQuantity{} -> FixingQuantity_+ FixingRelevance{} -> FixingRelevance_+ FixingCohesion{} -> FixingCohesion_+ FixingPolarity{} -> FixingPolarity_+ IgnoringRew{} -> MisplacedRewrite_+ IllformedAsClause{} -> IllformedAsClause_+ WrongInstanceDeclaration{} -> WrongInstanceDeclaration_+ InstanceWithExplicitArg{} -> InstanceWithExplicitArg_+ InstanceNoOutputTypeName{} -> InstanceNoOutputTypeName_+ InstanceArgWithExplicitArg{} -> InstanceArgWithExplicitArg_+ DuplicateUsing{} -> DuplicateUsing_+ FixityInRenamingModule{} -> FixityInRenamingModule_+ InvalidCharacterLiteral{} -> InvalidCharacterLiteral_+ UnusedImports{} -> UnusedImports_+ UselessPragma{} -> UselessPragma_+ InversionDepthReached{} -> InversionDepthReached_+ InteractionMetaBoundaries{} -> InteractionMetaBoundaries_+ ModuleDoesntExport{} -> ModuleDoesntExport_+ NotInScopeW{} -> NotInScope_+ NotStrictlyPositive{} -> NotStrictlyPositive_+ ConstructorDoesNotFitInData{}-> ConstructorDoesNotFitInData_+ CoinductiveEtaRecord{} -> CoinductiveEtaRecord_+ UnguardedEtaRecordW{} -> UnguardedEtaRecordW_+ UnsupportedIndexedMatch{} -> UnsupportedIndexedMatch_+ OldBuiltin{} -> OldBuiltin_+ BuiltinDeclaresIdentifier{} -> BuiltinDeclaresIdentifier_+ SafeFlagPostulate{} -> SafeFlagPostulate_+ SafeFlagPragma{} -> SafeFlagPragma_+ SafeFlagWithoutKFlagPrimEraseEquality -> SafeFlagWithoutKFlagPrimEraseEquality_+ ConflictingPragmaOptions{} -> ConflictingPragmaOptions_+ WithoutKFlagPrimEraseEquality -> WithoutKFlagPrimEraseEquality_+ TerminationIssue{} -> TerminationIssue_+ UnreachableClauses{} -> UnreachableClauses_+ UnsolvedInteractionMetas{} -> UnsolvedInteractionMetas_+ UnsolvedConstraints{} -> UnsolvedConstraints_+ UnsolvedMetaVariables{} -> UnsolvedMetaVariables_+ UselessHiding{} -> UselessHiding_+ UselessInline{} -> UselessInline_+ UselessPublic{} -> UselessPublic_+ UselessPatternDeclarationForRecord{} -> UselessPatternDeclarationForRecord_+ UselessTactic{} -> UselessTactic_+ ClashesViaRenaming{} -> ClashesViaRenaming_+ UserWarning{} -> UserWarning_+ InfectiveImport{} -> InfectiveImport_+ CoInfectiveImport{} -> CoInfectiveImport_+ ConfluenceCheckingIncompleteBecauseOfMeta{} -> ConfluenceCheckingIncompleteBecauseOfMeta_+ ConfluenceForCubicalNotSupported{} -> ConfluenceForCubicalNotSupported_+ IllegalRewriteRule _ reason -> illegalRewriteWarningName reason+ NotARewriteRule{} -> NotARewriteRule_+ RewriteNonConfluent{} -> RewriteNonConfluent_+ RewriteMaybeNonConfluent{} -> RewriteMaybeNonConfluent_+ RewriteAmbiguousRules{} -> RewriteAmbiguousRules_+ RewriteMissingRule{} -> RewriteMissingRule_+ InferredLocalRewrite{} -> InferredLocalRewrite_+ PragmaCompileErased{} -> PragmaCompileErased_+ PragmaCompileList{} -> PragmaCompileList_+ PragmaCompileMaybe{} -> PragmaCompileMaybe_+ PragmaCompileUnparsable{} -> PragmaCompileUnparsable_+ PragmaCompileWrong{} -> PragmaCompileWrong_+ PragmaCompileWrongName{} -> PragmaCompileWrongName_+ PragmaExpectsDefinedSymbol{} -> PragmaExpectsDefinedSymbol_+ PragmaExpectsUnambiguousConstructorOrFunction{} ->+ PragmaExpectsUnambiguousConstructorOrFunction_+ PragmaExpectsUnambiguousProjectionOrFunction{} ->+ PragmaExpectsUnambiguousProjectionOrFunction_+ UnknownJSPrimitive{} -> UnknownJSPrimitive_+ NoMain{} -> NoMain_+ PlentyInHardCompileTimeMode{}+ -> PlentyInHardCompileTimeMode_+ -- record field warnings+ RecordFieldWarning w -> case w of+ W.DuplicateFields{} -> DuplicateFields_+ W.TooManyFields{} -> TooManyFields_++ -- opaque warnings+ MissingTypeSignatureForOpaque{} -> MissingTypeSignatureForOpaque_+ NotAffectedByOpaque{} -> NotAffectedByOpaque_+ UselessOpaque{} -> UselessOpaque_+ UnfoldingWrongName{} -> UnfoldingWrongName_+ UnfoldTransparentName{} -> UnfoldTransparentName_++ -- Recoverable scope-checking errors+ HiddenNotInArgumentPosition{} -> HiddenNotInArgumentPosition_+ InstanceNotInArgumentPosition{} -> InstanceNotInArgumentPosition_+ MacroInLetBindings{} -> MacroInLetBindings_+ AbstractInLetBindings{} -> AbstractInLetBindings_+ IllegalDeclarationInDataDefinition{} -> IllegalDeclarationInDataDefinition_++ -- Display forms+ InvalidDisplayForm{} -> InvalidDisplayForm_+ UnusedVariablesInDisplayForm{} -> UnusedVariablesInDisplayForm_++ -- Type checking+ ShouldBeEtaRecordPattern{} -> ShouldBeEtaRecordPattern_+ TooManyArgumentsToSort{} -> TooManyArgumentsToSort_+ DefinitionBeforeDeclaration{} -> DefinitionBeforeDeclaration_+ RecursiveRecordNeedsInductivity{} -> RecursiveRecordNeedsInductivity_+ RewritesNothing{} -> RewritesNothing_+ WithClauseProjectionFixityMismatch{} -> WithClauseProjectionFixityMismatch_++ -- Polarities+ TooManyPolarities{} -> TooManyPolarities_+ TopLevelPolarity{} -> TopLevelPolarity_++ -- Cubical+ FaceConstraintCannotBeHidden{} -> FaceConstraintCannotBeHidden_+ FaceConstraintCannotBeNamed{} -> FaceConstraintCannotBeNamed_++ -- Backend warnings+ CustomBackendWarning{} -> CustomBackendWarning_++illegalRewriteWarningName :: IllegalRewriteRuleReason -> WarningName+illegalRewriteWarningName = \case+ LHSNotDefinitionOrConstructor{} -> RewriteLHSNotDefinitionOrConstructor_+ VariablesNotBoundByLHS{} -> RewriteVariablesNotBoundByLHS_+ VariablesBoundMoreThanOnce{} -> RewriteVariablesBoundMoreThanOnce_+ VariablesBoundInSingleton{} -> RewriteVariablesBoundInSingleton_+ LHSReduces{} -> RewriteLHSReduces_+ HeadSymbolIsProjectionLikeFunction{} -> RewriteHeadSymbolIsProjectionLikeFunction_+ HeadSymbolIsTypeConstructor{} -> RewriteHeadSymbolIsTypeConstructor_+ HeadSymbolContainsMetas{} -> RewriteHeadSymbolContainsMetas_+ ConstructorParametersNotGeneral{} -> RewriteConstructorParametersNotGeneral_+ ContainsUnsolvedMetaVariables{} -> RewriteContainsUnsolvedMetaVariables_+ BlockedOnProblems{} -> RewriteBlockedOnProblems_+ RequiresDefinitions{} -> RewriteRequiresDefinitions_+ DoesNotTargetRewriteRelation -> RewriteDoesNotTargetRewriteRelation_+ BeforeFunctionDefinition -> RewriteBeforeFunctionDefinition_+ BeforeMutualFunctionDefinition{} -> RewriteBeforeMutualFunctionDefinition_+ DuplicateRewriteRule -> DuplicateRewriteRule_+ LocalRewriteOutsideTelescope -> LocalRewriteOutsideTelescope_++-- | Should warnings of that type be serialized?+--+-- Only when changes in the source code can silence or influence the warning.+--+isSourceCodeWarning :: WarningName -> Bool+isSourceCodeWarning = \case+ WarningProblem_ -> False+ _ -> True++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+ , tcWarningDoc :: Doc -- DocTree+ -- ^ The warning printed in the state and environment where it was raised+ , tcWarningString :: String+ -- ^ Caches @render tcWarningDoc@ for the sake of an 'Ord' instance.+ , tcWarningCached :: Bool+ -- ^ Should the warning be affected by caching.+ }+ deriving (Show, Generic)++tcWarningOrigin :: TCWarning -> SrcFile+tcWarningOrigin = rangeFile . tcWarningRange++instance HasRange TCWarning where+ getRange = tcWarningRange++instance Eq TCWarning where+ (==) = (==) `on` tcWarningRange &&& tcWarningString++instance Ord TCWarning where+ compare = compare `on` tcWarningRange &&& tcWarningString++----------------------------------------------------------------------------------------------------+-- * 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.+ , termErrGuardednessHelps :: GuardednessHelps+ -- ^ Is the termination error resolved by activating @--guardedness@?+ } 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 ErasedDatatypeReason (Closure Type)+ -- ^ Data type, but in erased position.+ | 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.+ }+ | 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"+ | UnifyVarInRewrite Telescope Type Int Term -- ^ Can't solve equation because variable occurs in a local rewrite rule+ | UnifyVarInRewriteEta Telescope Int -- ^ Can't eta-expand variable because variable occurs in a local rewrite rule+ deriving (Show, Generic)++data UnquoteError+ = BlockedOnMeta TCState Blocker+ | CannotDeclareHiddenFunction QName+ -- ^ Attempt to @unquoteDecl@ with 'Hiding' other than 'NotHidden'.+ | CommitAfterDef+ | ConInsteadOfDef QName String String+ | DefineDataNotData QName+ | DefInsteadOfCon QName String String+ | EscapingVariable (Closure Term)+ -- ^ Given meta-program produces unbound variable under @extendContext@.+ | MissingDeclaration QName+ | MissingDefinition (List1 QName)+ -- ^ These names should have been defined by the meta-program, but were not.+ | NakedUnquote+ | NonCanonical String I.Term+ | PatLamWithoutClauses I.Term+ | StaleMeta TopLevelModuleName MetaId+ -- ^ Attempt to unquote a serialized meta.+ | TooManyParameters Nat A.Expr+ -- ^ Attempt to shave of 'Nat' many parameters from function type 'A.Expr'.+ | UnboundName QName+ deriving (Show, Generic)++-- | Error when trying to call an external executable during reflection.+data ExecError+ = ExeNotTrusted ExeName ExeMap+ -- ^ The given executable is not listed as trusted.+ | ExeNotFound ExeName FilePath+ -- ^ The given executable could not be found under the given path.+ | ExeNotExecutable ExeName FilePath+ -- ^ The given file path does not have executable permissions.+ deriving (Show, Generic)++data TypeError+ = InternalError String+ | NotImplemented String+ | NotSupported String+ | CompilationError String+ | SyntaxError String+ -- ^ Essential syntax error thrown after successful parsing.+ -- Description in 'String'.+ | OptionError OptionError+ -- ^ Error thrown by the option parser.+ | NicifierError DeclarationException'+ -- ^ Error thrown in the nicifier phase 'Agda.Syntax.Concrete.Definitions'.+ | DoNotationError String+ -- ^ Error during unsugaring some @do@ notation.+ -- Error message in 'String'.+ | IdiomBracketError String+ -- ^ Error during (operator) parsing and interpreting the contents of idiom brackets.+ -- Error message in 'String'.+ | NoKnownRecordWithSuchFields [C.Name]+ -- ^ The user has given a record expression with the given fields,+ -- but no record type known to type inference has all these fields.+ -- The list can be empty.+ | ShouldEndInApplicationOfTheDatatype Type+ -- ^ The target of a constructor isn't an application of its+ -- datatype. The 'Type' records what it does target.+ | ConstructorPatternInWrongDatatype+ QName -- ^ Name of the constructor.+ QName -- ^ Name of the data or record type.+ DataOrRecord_ -- ^ Whether it is a data or a record type.+ | CantResolveOverloadedConstructorsTargetingSameDatatype QName (List1 QName)+ -- ^ Datatype, constructors.+ | ConstructorDoesNotTargetGivenType QName Type -- ^ constructor, type+ | InvalidDottedExpression+ -- ^ @.e@ in non-argument position.+ | LiteralTooBig+ -- ^ An integer literal that would be too costly to expand to unary.+ | NegativeLiteralInPattern+ -- ^ Negative literals are not supported in patterns.+ | 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.+ | WrongHidingInProjection QName+ | IllegalHidingInPostfixProjection (NamedArg C.Expr)+ | WrongNamedArgument (NamedArg A.Expr) (List1 NamedName)+ -- ^ A function is applied to a hidden\/instance named argument it does not have.+ -- The list contains names of possible hidden\/instance arguments at this point.+ | WrongNamedArgumentInLHS Hiding ArgName [ArgName]+ -- ^ A left hand side (or lambda) has a hidden\/instance named argument+ -- that the function type does not have.+ -- The list contains names of possible hidden\/instance arguments at this point.+ | WrongAnnotationInLambda+ -- ^ Wrong user-given (lock/tick) annotation in lambda.+ | WrongIrrelevanceInLambda+ -- ^ Wrong user-given relevance annotation in lambda.+ | WrongQuantityInLambda+ -- ^ Wrong user-given quantity annotation in lambda.+ | WrongCohesionInLambda+ -- ^ Wrong user-given cohesion annotation in lambda.+ | WrongPolarityInLambda+ -- ^ Wrong user-given polarity 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 relevance.+ | ForcedConstructorNotInstantiated A.Pattern+ | IllformedProjectionPatternAbstract A.Pattern+ | IllformedProjectionPatternConcrete C.Pattern+ | CannotEliminateWithPattern (Maybe Blocker) (NamedArg A.Pattern) Type+ | CannotEliminateWithProjection (Maybe Blocker) (Arg Type) Bool QName+ | WrongNumberOfConstructorArguments QName Nat Nat+ | ShouldBeEmpty Type [DeBruijnPattern]+ -- ^ Type should be empty. The list gives possible patterns that match, but can be empty.+ | 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+ | EtaPragmaVsNoEtaEquality+ -- ^ A record has been declared as both @ETA_EQUALITY@ and @no-eta-equality@.+ | CannotApply A.Expr Type+ -- ^ The given expression is used as a function+ -- but its type is not a function type.+ | InvalidTypeSort Sort+ -- ^ This sort is not a type expression.+ | SplitOnCoinductive+ | SplitOnIrrelevant (Dom Type)+ | SplitOnUnusableCohesion (Dom Type)+ | SplitOnUnusablePolarity (Dom Type)+ -- UNUSED: -- | SplitOnErased (Dom Type)+ | SplitOnNonVariable Term Type+ | SplitOnNonEtaRecord QName+ | SplitOnAbstract QName+ | SplitOnUnchecked QName+ | SplitOnPartial (Dom Type)+ | SplitInProp DataOrRecordE+ | DefinitionIsIrrelevant QName+ | DefinitionIsErased QName+ | ProjectionIsIrrelevant QName+ | VariableIsIrrelevant Name+ | VariableIsErased Name+ | VariableIsOfUnusableCohesion Name Cohesion+ | LambdaIsErased+ | RecordIsErased+ | InvalidModalTelescopeUse Term Modality Modality Definition+ | VariableIsOfUnusablePolarity Name PolarityModality+ | ConversionError_ ConversionError+ | NotLeqSort Sort Sort+ | MetaCannotDependOn MetaId Term Nat+ -- ^ The arguments are the meta variable, the proposed solution,+ -- and the parameter that it wants to depend on.+ | MetaIrrelevantSolution MetaId Term+ -- ^ When solving @'MetaId' ... := 'Term'@,+ -- part of the 'Term' is invalid as it was created in an irrelevant context.+ | MetaErasedSolution MetaId Term+ -- ^ When solving @'MetaId' ... := 'Term'@,+ -- part of the 'Term' is invalid as it was created in an erased context.+ | UserError Doc+ -- ^ Error message produced by a meta program.+ | SortOfSplitVarError (Maybe Blocker) Doc+ -- ^ the meta is what we might be blocked on.+ | WrongSharpArity A.QName+ | BuiltinMustBeConstructor BuiltinId A.Expr+ | BuiltinMustBeData BuiltinId Int+ | BuiltinMustBeDef BuiltinId+ | BuiltinMustBeFunction BuiltinId+ | BuiltinMustBePostulate BuiltinId+ | NoSuchBuiltinName String+ | InvalidBuiltin String+ | DuplicateBuiltinBinding BuiltinId Term Term+ | NoBindingForBuiltin BuiltinId+ | NoBindingForPrimitive PrimitiveId+ | NoSuchPrimitiveFunction String+ | DuplicatePrimitiveBinding PrimitiveId QName QName+ | WrongArgInfoForPrimitive PrimitiveId ArgInfo ArgInfo+ | TrustedBuiltin BuiltinId+ | TrustedPrimitive QName+ | ShadowedModule C.Name (List1 A.ModuleName)+ | BuiltinInParameterisedModule BuiltinId+ | IllegalLetInTelescope C.TypedBinding+ | IllegalPatternInTelescope C.Binder+ | AbsentRHSRequiresAbsurdPattern+ | TooManyFields QName [C.Name] (List1 C.Name)+ -- ^ Record type, fields not supplied by user, possibly non-fields but supplied.+ | DuplicateFields (List1 C.Name)+ | DuplicateConstructors (List1 C.Name)+ | DuplicateOverlapPragma QName OverlapMode OverlapMode+ | WithOnFreeVariable A.Expr Term+ | UnexpectedWithPatterns (List1 A.Pattern)+ | WithClausePatternMismatch A.Pattern (NamedArg DeBruijnPattern)+ | IllTypedPatternAfterWithAbstraction A.Pattern+ | TooFewPatternsInWithClause+ | TooManyPatternsInWithClause+ | PathAbstractionFailed (Abs Type)+ | FieldOutsideRecord+ | ModuleArityMismatch A.ModuleName Telescope (Either (List1 (NamedArg A.Expr)) Args)+ | GeneralizeCyclicDependency+ | ReferencesFutureVariables Term (List1 Int) (Arg Term) Int+ -- ^ The first term references the given list of variables,+ -- which are in "the future" with respect to the given lock+ -- (and its leftmost variable)+ | DoesNotMentionTicks Term Type (Arg Term)+ -- ^ Arguments: later term, its type, lock term. The lock term+ -- does not mention any @lock variables.+ | MismatchedProjectionsError QName QName+ | AttributeKindNotEnabled String String String+ | InvalidProjectionParameter (NamedArg A.Expr)+ | TacticAttributeNotAllowed+ | CannotRewriteByNonEquation Type+ | MacroResultTypeMismatch Type+ | NamedWhereModuleInRefinedContext [Term] [String]+ -- ^ The lists should have the same length.+ -- TODO: enforce this by construction.+ | NamedWhereModuleUnderWith+ -- ^ A named @where@ module in a @with@ or @rewrite@ clause.+ -- Disallowed since Agda 2.9.0, see issue #8698.+ | ComatchingDisabledForRecord QName+ -- Rewriting errors+ | IlltypedRewriteRule Doc+ -- TODO: split this into finer errors rather than using 'Doc',+ -- and add reproducers for all the shades of this error to the testsuite.+ -- ^ When constructing a rewrite rule from a type,+ -- an error occurred, possibly due to non-confluence of rewrite rules.+ -- This was a @GenericDocError@ before.+ | IncorrectTypeForRewriteRelation Term IncorrectTypeForRewriteRelationReason+ -- Cubical errors+ | CannotGenerateHCompClause Type+ -- ^ Cannot generate @hcomp@ clause because type is not fibrant.+ | CannotGenerateTransportClause QName (Closure (Abs Type))+ -- ^ Cannot generate transport clause because type is not fibrant.+ | CubicalNotErasure QName+ -- ^ Name was defined for @--cubical[=full]@+ -- and for use in @--cubical=erased@ the option @--erasure@ is needed.+ | CubicalPrimitiveNotFullyApplied QName+ | ExpectedIntervalLiteral A.Expr+ -- ^ Expected an interval literal (0 or 1) but found 'A.Expr'.+ | FaceConstraintDisjunction+ | FaceConstraintUnsatisfiable+ | PatternInPathLambda+ -- ^ Attempt to pattern match in an abstraction of interval type.+ | PatternInSystem+ -- ^ Attempt to pattern or copattern match in a system.+ | CannotGenerateTransportLocalRewrite QName+ -- ^ Cannot generate transport for data or record type because there+ -- is a local rewrite rule in the telescope.+ -- Data errors+ | UnexpectedParameter A.LamBinding+ | NoParameterOfName ArgName [ArgName]+ | UnexpectedModalityAnnotationInParameter A.LamBinding+ | ExpectedBindingForParameter (Dom Type) (Abs Type)+ | UnexpectedTypeSignatureForParameter (List1 (NamedArg A.Binder))+ | SortDoesNotAdmitDataDefinitions QName Sort+ | SortCannotDependOnItsIndex QName Type+ -- Modality errors+ | UnusableAtModality WhyCheckModality Modality Term+ -- Coverage errors+ | SplitError SplitError+ | ImpossibleConstructor QName NegativeUnification+ -- Positivity and polarity errors+ | DatatypeIndexPolarity+ -- ^ An index of a data type has a polarity different from 'Mixed'.+ | UnguardedEtaRecord QName++ -- Sized type errors+ | CannotSolveSizeConstraints (List1 (ProblemConstraint, HypSizeConstraint)) Doc+ -- ^ The list of constraints is given redundantly as pairs of+ -- 'ProblemConstraint' (original constraint) and+ -- 'HypSizeConstraint' (form with size assumptions in context spelled out).+ -- The 'Doc' is some extra reason for why solving failed.+ | ContradictorySizeConstraint (ProblemConstraint, HypSizeConstraint)+ | EmptyTypeOfSizes Term+ -- ^ This type, representing a type of sizes, might be empty.+ | FunctionTypeInSizeUniv Term+ -- ^ This term, a function type constructor, lives in+ -- @SizeUniv@, which is not allowed.+ | PostulatedSizeInModule+ -- Import errors+ | LibraryError LibErrors+ -- ^ Collected errors when processing the @.agda-lib@ file.+ | LibTooFarDown TopLevelModuleName AgdaLibFile+ -- ^ The @.agda-lib@ file for the given module is not on the right level.+ | SolvedButOpenHoles TopLevelModuleNameWithSourceFile+ -- ^ Some interaction points (holes) in the given module have not been filled by the user.+ -- These are not 'UnsolvedMetas' since unification solved them.+ -- This is an error, since interaction points are never filled+ -- without user interaction.+ | CyclicModuleDependency (List2 TopLevelModuleName)+ -- ^ The cycle starts and ends with the same module.+ | FileNotFound TopLevelModuleName (List1 AbsolutePath)+ -- ^ No file for the module was found when searching+ -- in the given list of include directories.+ | OverlappingProjects AbsolutePath TopLevelModuleName TopLevelModuleName+ | AmbiguousTopLevelModuleName TopLevelModuleName (List2 AbsolutePath)+ -- ^ The given module has at least 2 file locations.+ | ModuleNameUnexpected TopLevelModuleNameWithSourceFile TopLevelModuleName+ -- ^ Found module name, expected module name.+ | ModuleNameDoesntMatchFileName TopLevelModuleName (List1 AbsolutePath)+ -- ^ No matching file for the module was found when searching+ -- in the given list of include directories.+ | ModuleDefinedInOtherFile TopLevelModuleName AbsolutePath AbsolutePath+ -- ^ Module name, file from which it was loaded, file which+ -- the include path says contains the module.+ | InvalidFileName AbsolutePath InvalidFileNameReason+ -- ^ The file name does not correspond to a module name.+ | ModuleNameHashCollision RawTopLevelModuleName (Maybe RawTopLevelModuleName)+ -- Scope errors+ | BothWithAndRHS+ | AbstractConstructorNotInScope A.QName+ | CopatternHeadNotProjection C.QName+ | NotAllowedInDotPatterns NotAllowedInDotPatterns+ | NotInScope C.QName+ | NoSuchModule C.QName+ | AmbiguousName C.QName AmbiguousNameReason+ | AmbiguousModule C.QName (List1 A.ModuleName)+ | AmbiguousField C.Name (List2 A.ModuleName)+ | AmbiguousConstructor QName (List2 QName)+ -- ^ The list contains all interpretations of the name.+ | ClashingDefinition C.QName ClashingName (Maybe NiceDeclaration)+ | ClashingModule A.ModuleName A.ModuleName+ | DefinitionInDifferentModule A.QName+ -- ^ The given data/record definition rests in a different module than its signature.+ | DuplicateImports C.QName (List1 C.ImportedName)+ | InvalidPattern C.Pattern+ | InvalidPun ConstructorOrPatternSynonym C.QName+ -- ^ Expected the identifier to be a variable, not a constructor or pattern synonym.+ | RepeatedNamesInImportDirective (List1 (List2 C.ImportedName))+ -- ^ Some names are bound several times by an @import@/@open@ directive.+ | RepeatedVariablesInPattern (List1 C.Name)+ | CannotGeneralizeEtaExpandable A.QName Type+ | GeneralizationFailed Doc+ | GeneralizationPrepruneErrorRefinedContext (Closure MetaId)+ | GeneralizationPrepruneErrorCyclicDependencies (Closure MetaId)+ | GeneralizationPrepruneErrorFailedToInstantiate (Closure MetaId)+ | GeneralizeNotSupportedHere A.QName+ | GeneralizedVarInLetOpenedModule A.QName+ | MultipleFixityDecls (List1 (C.Name, Pair Fixity'))+ | MultiplePolarityPragmas (List1 C.Name)+ | ExplicitPolarityVsPragma QName+ | ConstructorNameOfNonRecord ResolvedName+ -- Concrete to Abstract errors+ | CannotQuote CannotQuote+ | CannotQuoteTerm CannotQuoteTerm+ | DeclarationsAfterTopLevelModule+ | IllegalDeclarationBeforeTopLevelModule+ | MissingTypeSignature MissingTypeSignatureInfo+ | NotAnExpression C.Expr+ | NotAValidLetBinding (Maybe NotAValidLetBinding)+ | NotAValidLetExpression NotAValidLetExpression+ | NotValidBeforeField NiceDeclaration+ | PrivateRecordField+ | QualifiedLocalModule+ -- Pattern synonym errors+ | AsPatternInPatternSynonym+ | DotPatternInPatternSynonym+ | BadArgumentsToPatternSynonym A.AmbiguousQName+ | TooFewArgumentsToPatternSynonym A.AmbiguousQName+ | CannotResolveAmbiguousPatternSynonym (List1 (A.QName, A.PatternSynDefn))+ | IllegalInstanceVariableInPatternSynonym C.Name+ -- ^ This variable is bound in the lhs of the pattern synonym in instance position,+ -- but not on the rhs.+ -- This is forbidden because expansion of pattern synonyms would not be faithful+ -- to availability of instances in instance search.+ | PatternSynonymArgumentShadows ConstructorOrPatternSynonym C.Name (List1 AbstractName)+ -- ^ A variable to be bound in the pattern synonym resolved on the rhs as name of+ -- a constructor or a pattern synonym.+ -- The resolvents are given in the list.+ | UnusedVariableInPatternSynonym C.Name+ -- ^ This variable is only bound on the lhs of the pattern synonym, not on the rhs.+ | UnboundVariablesInPatternSynonym (List1 A.Name)+ -- ^ These variables are only bound on the rhs of the pattern synonym, not on the lhs.+ -- 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 (List2 C.Pattern)+ -- ^ Pattern and its possible interpretations.+ | AmbiguousProjection QName (List1 QName)+ -- ^ The list contains alternative interpretations of the name.+ | AmbiguousOverloadedProjection AmbiguousQName Doc+ | OperatorInformation [NotationSection] OperatorScope TypeError+ -- ^ The list of notations can be empty.+{- UNUSED+ | NoParseForPatternSynonym C.Pattern+ | AmbiguousParseForPatternSynonym C.Pattern [C.Pattern]+-}+ -- Usage errors+ -- Instance search errors+ | InstanceNoCandidate Type [(Term, TCErr)]+ -- ^ The list can be empty.+ -- Reflection errors+ | ExecError ExecError+ | UnquoteFailed UnquoteError+ | DeBruijnIndexOutOfScope Nat Telescope [Name]+ -- ^ The list can be empty.+ | MissingBindingsForTelescopeVariables (List1 Text)+ -- Language option errors+ | NeedOptionAllowExec+ | NeedOptionCopatterns+ | NeedOptionCubical Cubical String+ -- ^ Flavor of cubical needed for the given reason.+ | NeedOptionPatternMatching+ | NeedOptionIrrelevance+ | NeedOptionProp+ | NeedOptionRewriting+ | NeedOptionSizedTypes String+ -- ^ Need @--sized-types@ for the given reason.+ | NeedOptionTwoLevel+ | NeedOptionUniversePolymorphism+ -- Failure associated to warnings+ | NonFatalErrors (Set1 TCWarning)+ -- Instance search errors+ | InstanceSearchDepthExhausted Term Type Int+ | TriedToCopyConstrainedPrim QName+ | InvalidInstanceHeadType Type WhyInvalidInstanceType+ -- Interaction errors+ | InteractionError InteractionError+ -- Backend errors+ | BackendDoesNotSupportOnlyScopeChecking BackendName+ -- ^ The given backend does not support @--only-scope-checking@.+ | CubicalCompilationNotSupported Cubical+ -- ^ NYI: Compilation of files using the given flavor of 'Cubical'.+ | CustomBackendError BackendName Doc+ -- ^ Used for backend-specific errors. The string is the backend name.+ | GHCBackendError GHCBackendError+ -- ^ Errors raised by the GHC backend.+ | JSBackendError JSBackendError+ -- ^ Errors raised by the JS backend.+ | UnknownBackend BackendName (Set BackendName)+ -- ^ Unknown backend requested, known ones are in the 'Set'.+ deriving (Show, Generic)++-- | Name a 'ClashingDefinition' clashes with.+data ClashingName+ = ClashingAbstractName AbstractName+ -- ^ We have 'WhyInScope' information for the previously defined name.+ | ClashingQName QName+ -- ^ We have no extra information for the previously defined name.+ deriving (Show, Generic)++-- | Extract the 'QName' from the 'ClashingName'.+clashingQName :: ClashingName -> QName+clashingQName = \case+ ClashingAbstractName x -> anameName x+ ClashingQName x -> x++-- | Reason for why the instance type is invalid.+data WhyInvalidInstanceType+ = ImproperInstHead+ -- ^ The type isn't headed by a local, a definition, or a postulate+ -- (e.g. it's a universe)+ | ImproperInstTele+ -- ^ The type we're looking for has a visible argument+ deriving (Show, Generic)++-- | Errors raised in @--interaction@ mode.+data InteractionError+ = CannotGive A.Expr+ -- ^ Failure of the 'give' interactive tactic.+ | CannotRefine String+ -- ^ Failure of the 'refine' interactive tactic.+ | CaseSplitError Doc+ -- ^ Failure of the 'makeCase' interactive tactic.+ | ExpectedIdentifier C.Expr+ -- ^ Expected the given expression to be an identifier.+ | ExpectedApplication+ -- ^ Expected an argument of the form @f e1 e2 .. en@.+ | NoActionForInteractionPoint InteractionId+ -- ^ Interaction point has not been reached during type checking.+ | NoSuchInteractionPoint InteractionId+ -- ^ 'InteractionId' does not resolve to an 'InteractionPoint'.+ | UnexpectedWhere+ -- ^ @where@ not allowed in hole.+ deriving (Show, Generic)++-- | Errors raised by the GHC backend.+data GHCBackendError+ = ConstructorCountMismatch QName [QName] [String]+ -- ^ The number of Haskell constructors ('String' list) does not match+ -- the number of constructors of the given data type.+ | NotAHaskellType Term WhyNotAHaskellType+ -- ^ GHC backend fails to represent given Agda type in Haskell.+ | WrongTypeOfMain QName Type+ -- ^ The type of @main@ should be @IO _@ ('QName') but is instead 'Type'.+ deriving (Show, Generic)++-- | Errors raised by the JS backend.+data JSBackendError+ = BadCompilePragma+ deriving (Show, Generic)++-- | Extra information for 'MissingTypeSignature' error.+data MissingTypeSignatureInfo+ = MissingDataSignature C.Name+ -- ^ The @data@ definition for 'C.Name' lacks a data signature.+ | MissingRecordSignature C.Name+ -- ^ The @record@ definition for 'C.Name' lacks a record signature.+ | MissingFunctionSignature C.LHS+ -- ^ The function lhs misses a type signature.+ deriving (Show, Generic)++-- | Extra information for 'NotAHaskellType' error.+data WhyNotAHaskellType+ = NoPragmaFor QName+ | WrongPragmaFor Range QName+ | BadLambda Term+ | BadMeta Term+ | BadDontCare Term+ | NotCompiled QName+ deriving (Show, Generic)++-- | Extra information for 'InvalidFileName' error.+data InvalidFileNameReason+ = DoesNotCorrespondToValidModuleName+ | RootNameModuleNotAQualifiedModuleName Text+ deriving (Show, Generic)++type DataOrRecordE = DataOrRecord' InductionAndEta++data InductionAndEta = InductionAndEta+ { recordInduction :: Maybe Induction+ , recordEtaEquality :: EtaEquality+ } deriving (Show, Generic)++-- | Source of the rewrite rule+-- Parameterised by the info for global rewrite rules (it is convenient+-- to remember the definition during checking, but when serialising we just+-- store the 'QName')+data RewriteSource' a+ = GlobalRewrite a+ | LocalRewrite Context (Maybe Name) Type+ deriving (Show, Generic, Functor)++type RewriteSource = RewriteSource' Definition+type SerialisableRewriteSource = RewriteSource' QName++isLocalRewrite :: RewriteSource -> Bool+isLocalRewrite (LocalRewrite g r t) = True+isLocalRewrite (GlobalRewrite d) = False++-- Reason, why rewrite rule is invalid+data IllegalRewriteRuleReason+ = LHSNotDefinitionOrConstructor+ | VariablesNotBoundByLHS VarSet+ | VariablesBoundMoreThanOnce VarSet+ | VariablesBoundInSingleton VarSet+ | LHSReduces Term Term+ | HeadSymbolIsProjectionLikeFunction QName+ | HeadSymbolIsTypeConstructor QName+ | HeadSymbolContainsMetas QName+ | ConstructorParametersNotGeneral ConHead Args1+ | ContainsUnsolvedMetaVariables (Set1 MetaId)+ | BlockedOnProblems (Set1 ProblemId)+ | RequiresDefinitions (Set1 QName)+ | DoesNotTargetRewriteRelation+ | BeforeFunctionDefinition+ | BeforeMutualFunctionDefinition QName+ | DuplicateRewriteRule+ | LocalRewriteOutsideTelescope+ deriving (Show, Generic)++-- | Boolean flag whether a name is ambiguous.+data IsAmbiguous+ = YesAmbiguous AmbiguousQName+ | NotAmbiguous+ deriving (Show, Generic)++-- Reason, why type for rewrite rule is incorrect+data IncorrectTypeForRewriteRelationReason+ = ShouldAcceptAtLeastTwoArguments+ | FinalTwoArgumentsNotVisible+ | TypeDoesNotEndInSort Type Telescope+ deriving (Show, Generic)++-- | Extra information for error 'CannotQuote'.+data CannotQuote+ = CannotQuoteAmbiguous AmbiguousQName+ -- ^ @quote@ is applied to a really ambiguous name.+ | CannotQuoteExpression A.Expr+ -- ^ @quote@ is applied to an expression that is not an unambiguous defined name.+ | CannotQuoteHidden+ -- ^ @quote@ is applied to a non-visible argument.+ | CannotQuoteNothing+ -- ^ @quote@ is unapplied.+ | CannotQuotePattern (NamedArg C.Pattern)+ -- ^ @quote@ is applied to a pattern that is not an unambiguous defined name.+ deriving (Show, Generic)++-- | Distinguish error message when parsing lhs or pattern synonym, resp.+data LHSOrPatSyn = IsLHS | IsPatSyn+ deriving (Eq, Show, Generic, Bounded, Enum)++-- | 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.+ }+ | ParserError ParseError+ -- ^ Error raised by the Happy parser.+ | GenericException String+ -- ^ Unspecific error without 'Range'.+ | IOException (Maybe 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 = \case+ TypeError _ _ e -> prettyShow (envRange $ envColdEnv $ clEnv e) ++ ": " ++ show (clValue e)+ ParserError e -> prettyShow e+ GenericException msg -> msg+ IOException _ r e -> prettyShow r ++ ": " ++ showIOException e+ PatternErr{} -> "Pattern violation (you shouldn't see this)"++instance HasRange TCErr where+ getRange (TypeError _ _ cl) = envRange $ envColdEnv $ clEnv cl+ getRange (ParserError e) = getRange e+ getRange GenericException{} = noRange+ getRange (IOException _ r _) = r+ getRange PatternErr{} = noRange++instance E.Exception TCErr++-- | Assorted warnings and errors to be displayed to the user+data WarningsAndNonFatalErrors = WarningsAndNonFatalErrors+ { tcWarnings :: Set TCWarning+ , nonFatalErrors :: Set TCWarning+ }++instance Null WarningsAndNonFatalErrors where+ null (WarningsAndNonFatalErrors ws errs) = null ws && null errs+ empty = WarningsAndNonFatalErrors empty empty++------------------------------------------------------------------------------------------------------+-- * Accessing options+------------------------------------------------------------------------------------------------------++instance MonadIO m => HasOptions (TCMT m) where+ pragmaOptions = useTC stPragmaOptions+ {-# INLINE pragmaOptions #-}++ commandLineOptions = do+ p <- useTC stPragmaOptions+ cl <- stPersistentOptions . stPersistentState <$> getTC+ return $ cl { optPragmaOptions = p }+ {-# SPECIALIZE commandLineOptions :: TCM CommandLineOptions #-}++-- HasOptions lifts through monad transformers+-- (see default signatures in the HasOptions class).++sizedTypesOption :: HasOptions m => m Bool+sizedTypesOption = optSizedTypes <$> pragmaOptions+{-# INLINE sizedTypesOption #-}++guardednessOption :: HasOptions m => m Bool+guardednessOption = optGuardedness <$> pragmaOptions+{-# INLINE guardednessOption #-}++withoutKOption :: HasOptions m => m Bool+withoutKOption = optWithoutK <$> pragmaOptions+{-# INLINE withoutKOption #-}++cubicalOption :: HasOptions m => m (Maybe Cubical)+cubicalOption = optCubical <$> pragmaOptions+{-# INLINE cubicalOption #-}++cubicalCompatibleOption :: HasOptions m => m Bool+cubicalCompatibleOption = optCubicalCompatible <$> pragmaOptions+{-# INLINE cubicalCompatibleOption #-}++enableCaching :: HasOptions m => m Bool+enableCaching = optCaching <$> pragmaOptions+{-# INLINE enableCaching #-}++rewritingOption :: HasOptions m => m Bool+rewritingOption = optRewriting <$> pragmaOptions+{-# INLINE rewritingOption #-}++localRewritingOption :: HasOptions m => m Bool+localRewritingOption = optLocalRewriting <$> pragmaOptions+{-# INLINE localRewritingOption #-}++-- | Local or global rewriting is enabled+anyRewritingOption :: HasOptions m => m Bool+anyRewritingOption = (||) <$> rewritingOption <*> localRewritingOption+{-# INLINE anyRewritingOption #-}+++-- * 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...).+ , redSess :: !SessionState -- ^ Read only access to the *session* state (module - source maps, etc)+ , 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) }+{-# INLINE mapRedEnv #-}++mapRedSt :: (TCState -> TCState) -> ReduceEnv -> ReduceEnv+mapRedSt f s = s { redSt = f (redSt s) }+{-# INLINE mapRedSt #-}++mapRedEnvSt :: (TCEnv -> TCEnv) -> (TCState -> TCState) -> ReduceEnv+ -> ReduceEnv+mapRedEnvSt f g (ReduceEnv e s sess p) = ReduceEnv (f e) (g s) sess p+{-# INLINE mapRedEnvSt #-}++-- Lenses+reduceEnv :: Lens' ReduceEnv TCEnv+reduceEnv f s = f (redEnv s) <&> \ e -> s { redEnv = e }+{-# INLINE reduceEnv #-}++reduceSt :: Lens' ReduceEnv TCState+reduceSt f s = f (redSt s) <&> \ e -> s { redSt = e }+{-# INLINE reduceSt #-}++newtype ReduceM a = ReduceM# { unReduceM :: ReduceEnv -> a }++pattern ReduceM :: (ReduceEnv -> a) -> ReduceM a+pattern ReduceM f <- ReduceM# f where+ ReduceM f = ReduceM# (oneShot \ !e -> f e)+{-# INLINE ReduceM #-}+{-# COMPLETE ReduceM #-}++{-# INLINE unKleisli #-}+unKleisli :: (a -> ReduceM b) -> ReduceM (a -> b)+unKleisli f = ReduceM \env x -> unReduceM (f x) env++onReduceEnv :: (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a+onReduceEnv f (ReduceM m) = ReduceM \e -> m $! f e+{-# INLINE onReduceEnv #-}++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+ (>>) = (*>)++instance MonadFail ReduceM where+ fail = error++instance ReadTCState ReduceM where+ getTCState = ReduceM redSt+ getSessionState = ReduceM redSess++ locallyTCState l f = onReduceEnv $ mapRedSt $ over l f++instance ExpandCase a => ExpandCase (ReduceM a) where+ type Result (ReduceM a) = Result a+ {-# INLINE expand #-}+ expand k =+ ReduceM (oneShot \ ~r ->+ expand @a (oneShot \deflateA -> let r' = r in k (oneShot \act -> deflateA (unReduceM act r'))))++runReduceM :: ReduceM a -> TCM a+runReduceM m = TCM $ \ r e -> do+ s <- Strict.readIORef r+ sess <- readAtomic (stPersistentSession (stPersistentState s))+ E.evaluate $ unReduceM m $ ReduceEnv e s sess 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)++instance MonadTCEnv ReduceM where+ {-# INLINE askTC #-}+ askTC = ReduceM redEnv+ {-# INLINE localTC #-}+ 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' TCState a -> m a+useR l = do+ !x <- getTCState <&> (^. l)+ return x+{-# INLINE useR #-}++askR :: ReduceM ReduceEnv+askR = ReduceM ask+{-# INLINE askR #-}++localR :: (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a+localR f = ReduceM . local f . unReduceM+{-# INLINE localR #-}++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 (Strict.ReaderT r m)+instance MonadReduce m => MonadReduce (Strict.StateT w m)+instance (Monoid w, MonadReduce m) => MonadReduce (Strict.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 (Strict.ReaderT r m)+instance MonadTCEnv m => MonadTCEnv (Strict.StateT s m)+instance (Monoid w, MonadTCEnv m) => MonadTCEnv (Strict.WriterT w m)++instance MonadTCEnv m => MonadTCEnv (ListT m) where+ localTC = mapListT . localTC++{-# INLINE asksTC #-}+asksTC :: MonadTCEnv m => (TCEnv -> a) -> m a+asksTC f = f <$> askTC++{-# INLINE viewTC #-}+viewTC :: MonadTCEnv m => Lens' TCEnv a -> m a+viewTC l = asksTC (^. l)++{-# INLINE locallyTC #-}+-- | Modify the lens-indicated part of the @TCEnv@ in a subcomputation.+locallyTC :: MonadTCEnv m => Lens' TCEnv a -> (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 ()++ {-# INLINE getTC #-}+ default getTC :: (MonadTrans t, MonadTCState n, t n ~ m) => m TCState+ getTC = lift getTC++ {-# INLINE putTC #-}+ default putTC :: (MonadTrans t, MonadTCState n, t n ~ m) => TCState -> m ()+ putTC = lift . putTC++ {-# INLINE modifyTC #-}+ 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 (Monoid w, MonadTCState m) => MonadTCState (WriterT w m)+instance MonadTCState m => MonadTCState (ChangeT m)+instance MonadTCState m => MonadTCState (IdentityT m)+instance MonadTCState m => MonadTCState (Strict.ReaderT r m)+instance MonadTCState m => MonadTCState (Strict.StateT s m)+instance (Monoid w, MonadTCState m) => MonadTCState (Strict.WriterT w m)+++{-# INLINE getsTC #-}+-- ** @TCState@ accessors (no lenses)+getsTC :: ReadTCState m => (TCState -> a) -> m a+getsTC f = f <$> getTCState++{-# INLINE modifyTC' #-}+-- | 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++{-# INLINE useTC #-}+useTC :: ReadTCState m => Lens' TCState a -> m a+useTC l = do+ !x <- getsTC (^. l)+ return x++infix 4 `setTCLens`++{-# INLINE setTCLens #-}+-- | Overwrite the part of the 'TCState' focused on by the lens.+setTCLens :: MonadTCState m => Lens' TCState a -> a -> m ()+setTCLens l = modifyTC . set l++{-# INLINE setTCLens' #-}+-- | Overwrite the part of the 'TCState' focused on by the lens+-- (strictly).+setTCLens' :: MonadTCState m => Lens' TCState a -> a -> m ()+setTCLens' l = modifyTC' . set l++{-# INLINE modifyTCLens #-}+-- | Modify the part of the 'TCState' focused on by the lens.+modifyTCLens :: MonadTCState m => Lens' TCState a -> (a -> a) -> m ()+modifyTCLens l = modifyTC . over l++{-# INLINE modifyTCLens' #-}+-- | Modify the part of the 'TCState' focused on by the lens+-- (strictly).+modifyTCLens' :: MonadTCState m => Lens' TCState a -> (a -> a) -> m ()+modifyTCLens' l = modifyTC' . over l++{-# INLINE modifyTCLensM #-}+-- | Modify a part of the state monadically.+--+-- This is an instance of 'Agda.Utils.Lens.%=='.+modifyTCLensM :: (MonadTCState m, ReadTCState m) => Lens' TCState a -> (a -> m a) -> m ()+modifyTCLensM l f = useTC l >>= f >>= setTCLens l+ -- Note:+ -- The implementation @getTC >>= l f >>= putTC@ loses state changes+ -- contained in @f@, see https://github.com/agda/agda/pull/7470#discussion_r1747232483++{-# INLINE stateTCLens #-}+-- | Modify the part of the 'TCState' focused on by the lens, and return some result.+stateTCLens :: (MonadTCState m, ReadTCState m) => Lens' TCState a -> (a -> (r , a)) -> m r+stateTCLens l f = stateTCLensM l $ return . f++{-# INLINE stateTCLensM #-}+-- | Modify a part of the state monadically, and return some result.+--+-- This is an instance of 'Agda.Utils.Lens.%%='.+stateTCLensM :: (MonadTCState m, ReadTCState m) => Lens' TCState a -> (a -> m (r , a)) -> m r+stateTCLensM l f = do+ a <- useTC l+ (result , a') <- f a+ result <$ setTCLens l a'++{-# INLINE useSession #-}+-- | Access a part of the 'SessionState' through a lens.+useSession :: ReadTCState m => Lens' SessionState a -> m a+useSession l = view l <$!> getSessionState++class ReadTCState m => ModifySession m where+ -- | Modify a part of the 'SessionState' through a lens. If the+ -- continuation fails, modifications to the *session* state are reset.+ -- Other monadic states will not necessarily be reverted.+ --+ -- This function keeps an **exclusive** lock on the session state+ -- **for the entire execution of the continuation**, regardless of+ -- what the given lens focuses on.+ --+ -- No thread can access **any** part of the session state while+ -- 'stateSessionLensM' is executing. This includes the continuation!+ -- Nested applications of this function **will always** deadlock.+ --+ -- This function is strict in the modification to the session state,+ -- and the exclusive lock on the session state is maintained for the+ -- duration of forcing the new session state.+ --+ -- This function has a few variants if less flexibility is required:+ -- * 'stateSessionLens' takes a pure modification function.+ -- * 'modifySession' does not allow returning an additional result.+ stateSessionLensM :: Lens' SessionState a -> (a -> m (r, a)) -> m r++instance (MonadIO m, Catch.MonadMask m) => ModifySession (TCMT m) where++ -- The heavy lifting for synchronization and atomicity is handled by+ -- 'modifyAtomic', we just have to thread the TCM part of the state+ -- through.+ stateSessionLensM :: Lens' SessionState a -> (a -> TCMT m (r, a)) -> TCMT m r+ stateSessionLensM l f = TCM \st env -> do+ mv <- stPersistentSession . stPersistentState <$> liftIO (Strict.readIORef st)+ modifyAtomic mv \sess -> do+ (ret, new) <- unTCM (f $! sess ^. l) st env+ let sess' = set l new sess+ sess' `seq` pure (sess', ret)++instance ModifySession m => ModifySession (StateT s m) where+ stateSessionLensM l k = StateT \s -> stateSessionLensM l \v ->+ runStateT (k v) s <&> \((r, a), s) -> ((r, s), a)++instance ModifySession m => ModifySession (MaybeT m) where+ stateSessionLensM l k = MaybeT $ stateSessionLensM l \v -> runMaybeT (k v) >>= \case+ Just (r, a) -> pure (Just r, a)+ Nothing -> pure (Nothing, v)++{-# INLINE stateSessionLens #-}+-- | Like 'stateSessionLensM', but the modification function is not+-- allowed to perform effects.+stateSessionLens :: ModifySession m => Lens' SessionState a -> (a -> (r, a)) -> m r+stateSessionLens l f = stateSessionLensM l $ pure . f++{-# INLINE modifySession #-}+-- | Like 'stateSessionLens', but the modification function can not+-- return an extra result.+modifySession :: ModifySession m => Lens' SessionState a -> (a -> a) -> m ()+modifySession l f = stateSessionLens l $ pure . f++{-# INLINE setSession #-}+-- | Like 'modifySession', but with a constant new value.+--+-- If the computation of the new value depends on a previous+-- 'useSession', this function is prone to suffering from time-of-check+-- vs. time-of-use issues. Prefer the 'stateSessionLensM' family of+-- functions instead.+setSession :: ModifySession m => Lens' SessionState a -> a -> m ()+setSession l v = modifySession l (const v)++----------------------------------------------------------------------------------------------------+-- ** Monad with capability to block a computation+----------------------------------------------------------------------------------------------------++class Monad m => MonadBlock m where++ -- | `patternViolation b` aborts the current computation+ patternViolation :: Blocker -> m a++ {-# INLINE patternViolation #-}+ 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, 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 :: BlockT m a -> m (Either Blocker a)+runBlocked = runExceptT . unBlockT+{-# INLINE runBlocked #-}++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)++instance MonadBlock m => MonadBlock (Strict.ReaderT e m) where+ catchPatternErr h m = Strict.ReaderT (oneShot \e ->+ let run = flip Strict.runReaderT e; {-# INLINE run #-}+ in catchPatternErr (run . h) (run m))++instance MonadFileId m => MonadFileId (BlockT m)+----------------------------------------------------------------------------------------------------+-- * Type checking monad transformer+----------------------------------------------------------------------------------------------------++-- | The type checking monad transformer.+-- Adds readonly 'TCEnv' and mutable 'TCState'.+newtype TCMT m a = TCM# { unTCM# :: MutVar# RealWorld TCState -> TCEnv -> m a }++pattern TCM :: (Strict.IORef TCState -> TCEnv -> m a) -> TCMT m a+pattern TCM f <- TCM# ((\f (Strict.StrictIORef (IORef (STRef r))) e -> f r e) -> f) where+ TCM f = TCM# (oneShot \s -> oneShot \ !e -> f (Strict.StrictIORef (IORef (STRef s))) e)+{-# INLINE TCM #-}+{-# COMPLETE TCM #-}++{-# INLINE unTCM #-}+unTCM :: TCMT m a -> Strict.IORef TCState -> TCEnv -> m a+unTCM (TCM f) = f++-- | Type checking monad.+type TCM = TCMT IO++instance ExpandCase (TCM a) where+ type Result (TCM a) = IO a+ {-# INLINE expand #-}+ expand k = TCM# (oneShot \s -> oneShot \ !e -> k (oneShot (\(TCM# act) -> act s e)))+++-- 9.14 cannot do this specialization with {-# LANGUAGE DeepSubsumption #-}+-- https://gitlab.haskell.org/ghc/ghc/-/issues/26349+-- #if __GLASGOW_HASKELL__ < 914+{-# SPECIALIZE INLINE mapTCMT :: (forall a. IO a -> IO a) -> TCM a -> TCM a #-}+-- #endif+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 $ Strict.readIORef r+ return (f s e)+{-# INLINE pureTCM #-}++-- 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; {-# INLINE fmap #-}++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; {-# INLINE pure #-}+ (<*>) = apTCMT; {-# INLINE (<*>) #-}++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; {-# INLINE lift #-}++-- We want a special monad implementation of fail.+-- 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+ return = pure; {-# INLINE return #-}+ (>>=) = bindTCMT; {-# INLINE (>>=) #-}+ (>>) = (*>); {-# INLINE (>>) #-}++instance MonadFail TCM where+ fail = internalError+ {-# INLINE fail #-}++instance MonadIO m => MonadIO (TCMT m) where+ liftIO m = TCM $ \ s env -> do+ liftIO $ wrap s (env ^. eRange) $ do+ x <- m+ x `seq` return x+ where+ wrap s r m = E.catch m $ \ err -> do+ s <- Strict.readIORef s+ E.throwIO $ IOException (Just s) r err++instance MonadIO m => MonadTCEnv (TCMT m) where+ askTC = TCM $ \ _ e -> return e; {-# INLINE askTC #-}+ localTC f (TCM m) = TCM $ \ s e -> m s (f e); {-# INLINE localTC #-}++instance MonadIO m => MonadTCState (TCMT m) where+ getTC = TCM $ \ r _e -> liftIO (Strict.readIORef r); {-# INLINE getTC #-}+ putTC s = TCM $ \ r _e -> liftIO (Strict.writeIORef r s); {-# INLINE putTC #-}+ modifyTC f = putTC . f =<< getTC; {-# INLINE modifyTC #-}++instance MonadIO m => ReadTCState (TCMT m) where+ getTCState = getTC; {-# INLINE getTCState #-}+ locallyTCState l f = bracket_ (useTC l <* modifyTCLens l f) (setTCLens l); {-# INLINE locallyTCState #-}++ getSessionState = do+ mv <- getsTC (stPersistentSession . stPersistentState)+ readAtomic mv++instance MonadBlock TCM where+ {-# inline patternViolation #-}+ patternViolation b = throwError (PatternErr b)+ {-# INLINE catchPatternErr #-}+ catchPatternErr = \handle v ->+ catchError_ v \case+ -- 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+ err -> throwError err++instance MonadError TCErr TCM where+ {-# INLINE throwError #-}+ throwError = liftIO . E.throwIO+ {-# INLINE catchError #-}+ catchError m h = TCM \r e -> do -- now we are in the monad m+ oldState <- liftIO $ Strict.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 ()+ _ -> do+ newState <- Strict.readIORef r+ Strict.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 <- Strict.readIORef r+ catchImpossibleJust f (unTCM m r e) $ \ err -> do+ Strict.writeIORef r s+ unTCM (h err) r e++instance MonadIO m => MonadReduce (TCMT m) where+ liftReduce = liftTCM . runReduceM; {-# INLINE liftReduce #-}++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, 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__++{-# INLINE catchError_ #-}+-- | 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++{-# INLINE finally_ #-}+-- | 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+ {-# INLINE liftTCM #-}++{-# RULES "liftTCM/id" liftTCM = id #-}+instance MonadIO m => MonadTCM (TCMT m) where+ liftTCM = mapTCMT liftIO+ {-# INLINE liftTCM #-}++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)+instance MonadTCM tcm => MonadTCM (Strict.ReaderT r tcm)+instance MonadTCM tcm => MonadTCM (Strict.StateT s tcm)+instance (Monoid w, MonadTCM tcm) => MonadTCM (Strict.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, MonadTCError m) => String -> m a+internalError s = withCallerCallStack $ \ loc ->+ 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))++{-# 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'_++interactionError :: (HasCallStack, MonadTCError m) => InteractionError -> m a+interactionError = locatedTypeError InteractionError++syntaxError :: (HasCallStack, MonadTCError m) => String -> m a+syntaxError = locatedTypeError SyntaxError++unquoteError :: (HasCallStack, MonadTCError m) => UnquoteError -> m a+unquoteError = locatedTypeError UnquoteFailed++execError :: (HasCallStack, MonadTCError m) => ExecError -> m a+execError = locatedTypeError ExecError++-- | 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 $ Strict.newIORef s+ a <- unTCM m r e+ s <- liftIO $ Strict.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 $ Strict.newIORef =<< initStateIO+ 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 computation in a separate thread, with a /copy/ of the+-- 'TCState' of the calling thread.+--+-- Modifications of the 'TCState' performed by the detached computation+-- (e.g. creation of metas) are invisible to the parent thread, and to+-- any of its siblings. They will be "discarded" when the thread+-- finishes.+-- It is thus important to ensure that any results returned out-of-band+-- by the child thread are valid in an arbitrary TC state.+--+-- The detached thread has read-write, synchronised access to the+-- 'SessionState'.++forkTCM :: TCM () -> TCM ()+forkTCM m = do+ s <- getTC+ e <- askTC+ liftIO $ void $ forkIO $ void $ runTCM e s m++----------------------------------------------------------------------------------------------------+-- * Interaction Callback+----------------------------------------------------------------------------------------------------++-- | Callback fuction to call when there is a response+-- to give to the interactive frontend.+--+-- Note that the response is given in pieces and incrementally,+-- so the user can have timely response even during long computations.+--+-- Typical 'InteractionOutputCallback' functions:+--+-- * Convert the response into a 'String' representation and+-- print it on standard output+-- (suitable for inter-process communication).+--+-- * Put the response into a mutable variable stored in the+-- closure of the 'InteractionOutputCallback' function.+-- (suitable for intra-process communication).++type InteractionOutputCallback = Response_boot TCErr TCWarning WarningsAndNonFatalErrors -> TCM ()++-- | The default 'InteractionOutputCallback' function prints certain+-- things to stdout (other things generate internal errors).++defaultInteractionOutputCallback :: InteractionOutputCallback+defaultInteractionOutputCallback = \case+ Resp_RunningInfo _ msg -> do+ putDocTreeLn msg+ liftIO $ hFlush stdout+ Resp_HighlightingInfo {} -> __IMPOSSIBLE__+ Resp_Status {} -> __IMPOSSIBLE__+ Resp_JumpToError {} -> __IMPOSSIBLE__+ Resp_InteractionPoints {} -> __IMPOSSIBLE__+ Resp_GiveAction {} -> __IMPOSSIBLE__+ Resp_MakeCase {} -> __IMPOSSIBLE__+ Resp_SolveAll {} -> __IMPOSSIBLE__+ Resp_Mimer {} -> __IMPOSSIBLE__+ Resp_DisplayInfo {} -> __IMPOSSIBLE__+ Resp_ClearRunningInfo {} -> __IMPOSSIBLE__+ Resp_ClearHighlighting {} -> __IMPOSSIBLE__+ Resp_DoneAborting {} -> __IMPOSSIBLE__+ Resp_DoneExiting {} -> __IMPOSSIBLE__++----------------------------------------------------------------------------------------------------+-- * 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++-- | Name for telescope (record) of generalized variables.+generalizeRecordName :: String+generalizeRecordName = ".GeneralizeTel"++-- | Name for the record constructor for the generalized variables.+generalizeConstructorName :: String+generalizeConstructorName = ".mkGeneralizeTel"++-- | Base name for generalized variable projections.+generalizedFieldName :: String+generalizedFieldName = ".generalizedField-"++-- | Check whether we have a generalized variable field.+getGeneralizedFieldName :: A.QName -> Maybe String+getGeneralizedFieldName = List.stripPrefix generalizedFieldName . prettyShow . nameConcrete . qnameName++----------------------------------------------------------------------------------------------------+-- * KillRange instances+----------------------------------------------------------------------------------------------------++instance KillRange Signature where+ killRange (Sig secs defs rews inst) = killRangeN Sig secs defs rews inst++instance KillRange InstanceTable where+ killRange (InstanceTable tree count) = killRangeN InstanceTable tree count++instance KillRange Sections where+ killRange = fmap killRange++instance KillRange Definitions where+ killRange = fmap killRange++instance KillRange GlobalRewriteRuleMap where+ killRange = fmap killRange++instance KillRange Section where+ killRange (Section tel) = killRangeN Section tel++instance KillRange InstanceInfo where+ killRange :: KillRangeT InstanceInfo+ killRange (InstanceInfo a b) = killRangeN InstanceInfo a b++instance KillRange Definition where+ killRange (Defn ai name t pols occs gpars displ mut compiled inst copy ma nc inj copat blk lang hasmetas def) =+ killRangeN Defn ai name t pols occs gpars displ mut compiled inst copy ma nc inj copat blk lang hasmetas def+ -- TODO clarify: Keep the range in the defName field?++instance KillRange NumGeneralizableArgs where+ killRange = id++instance KillRange GlobalRewriteRule where+ killRange (GlobalRewriteRule q gamma f es rhs t c top) =+ killRangeN GlobalRewriteRule q gamma f es rhs t c top++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) = killRangeN ExtLamInfo m b sys++instance KillRange FunctionFlag where+ killRange = id++instance KillRange CompKit where+ killRange = id++instance KillRange IsPathCons where+ killRange = id++instance KillRange ProjectionLikenessMissing where+ killRange = id++instance KillRange BuiltinSort where+ killRange = id++instance KillRange a => KillRange (IsWithFunction a) where+ killRange NoWithFunction = NoWithFunction+ killRange (WithFunction a) = WithFunction (killRange a)++instance KillRange Defn where+ killRange def =+ case def of+ Axiom a -> Axiom a+ DataOrRecSig n eta -> DataOrRecSig n (killRange eta)+ GeneralizableVar a -> GeneralizableVar a+ AbstractDefn{} -> __IMPOSSIBLE__ -- only returned by 'getConstInfo'!+ Function a b c d e f g h i j k l m n ->+ killRangeN Function a b c d e f g h i j k l m n+ Datatype a b c d e f g h i j k -> killRangeN Datatype a b c d e f g h i j k+ Record a b c d e f g h i j k l m n -> killRangeN Record a b c d e f g h i j k l m n+ Constructor a b c d e f g h i j k l -> killRangeN Constructor a b c d e f g h i j k l+ Primitive a b c d e f -> killRangeN Primitive a b c d e f+ PrimitiveSort a b -> killRangeN 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) = killRangeN 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) = killRangeN 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 -> killRangeN DWithApp dt dts es+ DCon q ci dts -> killRangeN DCon q ci dts+ DDef q dts -> killRangeN DDef q dts+ DDot' v es -> killRangeN DDot' v es+ DTerm' v es -> killRangeN DTerm' v es++instance 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 (ParserError a) = rnf a+ rnf (GenericException a)= rnf a+ 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 PostNamesCheckpoints+instance NFData PostMetaState+instance NFData PostColdState+instance NFData PostScopeState+instance NFData TCState+instance NFData DisambiguatedName+instance NFData MutualBlock+instance NFData OpaqueBlock+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 InstanceTable+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 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 GlobalRewriteRule+instance NFData InstanceInfo+instance NFData LocalRewriteRuleMap+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 EtaProvenance+instance NFData FunctionFlag+instance NFData CompKit+instance NFData AxiomData+instance NFData DataOrRecSigData+instance NFData ProjectionLikenessMissing+instance NFData FunctionData+instance NFData IsPathCons+instance NFData DatatypeData+instance NFData RecordData+instance NFData ConstructorData+instance NFData PrimitiveData+instance NFData PrimitiveSortData+instance NFData Defn+instance NFData Simplification+instance NFData AllowedReduction+instance NFData ReduceDefs+instance NFData c => NFData (FunctionInverse' c)+instance NFData TermHead+instance NFData Call+instance NFData BuiltinSort+instance NFData pf => NFData (Builtin pf)+instance NFData HighlightingLevel+instance NFData HighlightingMethod+instance NFData TCContext+instance NFData ColdEnv+instance NFData ModalEnv+instance NFData TCEnv+instance NFData LetBinding+instance NFData UnquoteFlags+instance NFData AbstractMode+instance NFData ExpandHidden+instance NFData CandidateKind+instance NFData Candidate+instance NFData Warning+instance NFData RecordFieldWarning+instance NFData TCWarning+instance NFData CallInfo+instance NFData TerminationError+instance NFData SplitError+instance NFData NegativeUnification+instance NFData UnificationFailure+instance NFData UnquoteError+instance NFData TypeError+instance NFData WhyInvalidInstanceType+instance NFData ClashingName+instance NFData InvalidFileNameReason+instance NFData LHSOrPatSyn+instance NFData InductionAndEta+instance NFData SerialisableRewriteSource+instance NFData IllegalRewriteRuleReason+instance NFData IncorrectTypeForRewriteRelationReason+instance NFData GHCBackendError+instance NFData JSBackendError+instance NFData MissingTypeSignatureInfo+instance NFData WhyNotAHaskellType+instance NFData InteractionError+instance NFData IsAmbiguous+instance NFData CannotQuote+instance NFData ExecError+instance NFData ConstructorDisambiguationData+instance NFData Statistics+instance NFData UnusedImportsState+instance NFData OpenedModule+instance NFData IsAxiom++instance NFData SessionState where+ rnf (SessionState backends fileDict moduleToSourceId _interactionCallback) =+ rnf backends `seq` rnf fileDict `seq` rnf moduleToSourceId++instance NFData PrimFun where+ rnf (PrimFun a b c _fun) =+ rnf a `seq` rnf b `seq` rnf c++instance NFData TypeCheckingProblem where+ rnf = \case+ CheckExpr a b c ->+ rnf a `seq` rnf b `seq` rnf c+ CheckArgs a b c d e f _fun ->+ rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e `seq` rnf f+ CheckProjAppToKnownPrincipalArg a b c d e f g h i j k ->+ rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e `seq` rnf f+ `seq` rnf g `seq` rnf h `seq` rnf i `seq` rnf j `seq` rnf k+ CheckLambda a b c d ->+ rnf a `seq` rnf b `seq` rnf c `seq` rnf d+ DisambiguateConstructor a _fun ->+ rnf a+ DoQuoteTerm a b c ->+ rnf a `seq` rnf b `seq` rnf c
src/full/Agda/TypeChecking/Monad/Base/Types.hs view
@@ -17,7 +17,7 @@ import GHC.Generics ( Generic ) import Agda.Syntax.Common- ( LensArgInfo(..), LensCohesion, LensHiding, LensModality, LensOrigin, LensQuantity, LensRelevance, LensModalPolarity )+ ( LensArgInfo(..), LensCohesion, LensHiding, LensModality, LensOrigin, LensQuantity, LensRelevance, LensModalPolarity, Nat ) import Agda.Syntax.Info ( MetaNameSuggestion ) import Agda.Syntax.Internal ( Dom, MetaId, Name, Type )@@ -27,6 +27,9 @@ import Agda.Utils.FileName as X ( AbsolutePath ) import Agda.Utils.Lens ( Lens', (&&&), iso ) import Agda.Utils.Null ( Null(..) )+import Agda.Utils.Size ( Sized )+import Agda.Utils.List+import Agda.Utils.Tuple ( second ) ---------------------------------------------------------------------------@@ -34,8 +37,27 @@ --------------------------------------------------------------------------- -- | The @Context@ is a stack of 'ContextEntry's.-type Context = [ContextEntry]+-- Unlike telescopes, later context entries are bound in earlier ones.+newtype Context' a = Context+ { cxEntries :: [a]+ }+ deriving (Show, Generic, Sized, Functor, Foldable, Null, Traversable) +type Context = Context' ContextEntry++pattern CxEmpty :: Context+pattern CxExtendVar :: Name -> Dom Type -> Context -> Context+pattern CxExtend :: ContextEntry -> Context -> Context++pattern CxEmpty = Context []+pattern CxExtend x g <- Context (x : (Context -> g)) where+ CxExtend x (Context g) = Context (x : g)+{-# INLINE CxExtend #-}+pattern CxExtendVar x a g = CxExtend (CtxVar x a) g++{-# COMPLETE CxEmpty, CxExtend #-}+{-# COMPLETE CxEmpty, CxExtendVar #-}+ data ContextEntry = CtxVar { ceName :: Name@@ -44,6 +66,33 @@ -- N.B. 2024-11-29 there might be CtxLet in the future. deriving (Show, Generic) +-- | Does not raise the retrieved entry!+cxLookup :: Nat -> Context -> Maybe ContextEntry+cxLookup i (Context es) = es !!! i++cxDrop :: Nat -> Context -> Context+cxDrop n (Context es) = Context $ drop n es++-- | The returned list of context entries follows the context ordering+-- convention (earlier entries depend on later ones)+cxTake :: Nat -> Context -> [ContextEntry]+cxTake n (Context es) = take' n es++-- | Assumes the list of entries to be prepended follows the context ordering+-- convention (earlier entries depend on later ones)+cxPrepend :: [ContextEntry] -> Context -> Context+cxPrepend es' (Context es) = Context $ es' ++! es++-- | The returned prefix follows the context ordering convention (earlier+-- entries depend on later ones)+cxSplitAt :: Nat -> Context -> ([ContextEntry], Context)+cxSplitAt n (Context es) = second Context $ splitAt' n es++cxWithIndex :: (Nat -> ContextEntry -> a) -> Context -> [a]+cxWithIndex f = \cx -> go 0 (cxEntries cx) where+ go !i [] = []+ go i (e:es) = let !a = f i e in (a:) $! go (i + 1) es+ instance LensArgInfo ContextEntry where getArgInfo (CtxVar _ a) = getArgInfo a mapArgInfo f (CtxVar x a) = CtxVar x $ mapArgInfo f a@@ -111,18 +160,25 @@ --------------------------------------------------------------------------- -- | Discern Agda's primitive modules from other file modules.--- @IsPrimitiveModule `implies` IsBuiltinModuleWithSafePostulate `implies` isBuiltinModule.-+-- @isPrimitiveModule `implies` IsBuiltinModuleWithSafePostulate `implies` isBuiltinModule@. -- Keep constructors in this order! data IsBuiltinModule- = IsPrimitiveModule- -- ^ Very magical module, e.g. @Agda.Primitive@.+ = IsAgdaPrimitive+ -- ^ @Agda.Primitive@.+ | IsAgdaPrimitiveCubical+ -- ^ @Agda.Primitive.Cubical@. | IsBuiltinModuleWithSafePostulates -- ^ Safe module, e.g. @Agda.Builtin.Equality@. | IsBuiltinModule -- ^ Any builtin module. deriving (Eq, Ord, Show, Generic) +isPrimitiveModule :: IsBuiltinModule -> Bool+isPrimitiveModule = \case+ IsAgdaPrimitive -> True+ IsAgdaPrimitiveCubical -> True+ _ -> False+ -- | Collection of 'FileId's of primitive modules. type BuiltinModuleIds = EnumMap FileId IsBuiltinModule@@ -147,6 +203,12 @@ newtype SourceFile = SourceFile { srcFileId :: FileId } deriving (Eq, Ord, Show, Generic) +data TopLevelModuleNameWithSourceFile = TopLevelModuleNameWithSourceFile+ { fileModuleName :: TopLevelModuleName+ , fileModuleSourceFile :: SourceFile+ }+ deriving (Show, Generic)+ -- | Maps top-level module names to the corresponding source file ids. type ModuleToSourceId = Map TopLevelModuleName SourceFile@@ -158,15 +220,19 @@ -- ** Lenses +{-# INLINE lensFileDictFileDictBuilder #-} lensFileDictFileDictBuilder :: Lens' FileDictWithBuiltins FileDictBuilder-lensFileDictFileDictBuilder f s = f (fileDictBuilder s) <&> \ x -> s { fileDictBuilder = x }+lensFileDictFileDictBuilder = \f s -> f (fileDictBuilder s) <&> \ x -> s { fileDictBuilder = x } +{-# INLINE lensFileDictBuiltinModuleIds #-} lensFileDictBuiltinModuleIds :: Lens' FileDictWithBuiltins BuiltinModuleIds-lensFileDictBuiltinModuleIds f s = f (builtinModuleIds s) <&> \ x -> s { builtinModuleIds = x }+lensFileDictBuiltinModuleIds = \f s -> f (builtinModuleIds s) <&> \ x -> s { builtinModuleIds = x } +{-# INLINE lensFileDictPrimitiveLibDir #-} lensFileDictPrimitiveLibDir :: Lens' FileDictWithBuiltins PrimitiveLibDir-lensFileDictPrimitiveLibDir f s = f (primitiveLibDir s) <&> \ x -> s { primitiveLibDir = x }+lensFileDictPrimitiveLibDir = \f s -> f (primitiveLibDir s) <&> \ x -> s { primitiveLibDir = x } +{-# INLINE lensPairModuleToSource #-} lensPairModuleToSource :: Lens' (FileDictWithBuiltins, ModuleToSourceId) ModuleToSource lensPairModuleToSource = iso (uncurry ModuleToSource) (fileDict &&& moduleToSourceId) @@ -177,11 +243,24 @@ -- | For printing, we couple a meta with its name suggestion. data NamedMeta = NamedMeta { nmSuggestion :: MetaNameSuggestion- , nmid :: MetaId+ , nmid :: {-# UNPACK #-} !MetaId } +---------------------------------------------------------------------------+-- * @with@ functions+--------------------------------------------------------------------------- +data IsWithFunction a+ = NoWithFunction+ | WithFunction !a+ deriving (Eq, Show, Generic, Functor, Foldable, Traversable) +instance Null (IsWithFunction a) where+ empty = NoWithFunction+ null = \case+ NoWithFunction -> True+ WithFunction{} -> False+ -- Feel free to move more types from Agda.TypeChecking.Monad.Base here when needed... -- Null instances@@ -198,7 +277,10 @@ -- NFData instances +instance NFData Context instance NFData ContextEntry instance NFData FileDictWithBuiltins instance NFData SourceFile instance NFData IsBuiltinModule+instance NFData TopLevelModuleNameWithSourceFile+instance NFData a => NFData (IsWithFunction a)
src/full/Agda/TypeChecking/Monad/Benchmark.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wunused-imports #-}+{-# LANGUAGE NumDecimals #-} -- | Measure CPU time for individual phases of the Agda pipeline. @@ -15,16 +16,28 @@ import Prelude hiding (print) +import Data.Foldable (foldMap')+import Data.Function (on)+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Monoid (Sum(..), getSum)+import qualified Data.Text.Lazy as TL+ import Agda.Benchmarking+import Agda.Interaction.Options.Types( optParallelChecking, Parallelism(..) ) import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Debug+import Agda.TypeChecking.Monad.Imports (getVisitedModule) import qualified Agda.Utils.Benchmark as B-+import qualified Agda.Utils.Trie as Trie import Agda.Utils.Monad-import Agda.Syntax.Common.Pretty (prettyShow)-import qualified Agda.Utils.ProfileOptions as Profile+import Agda.Utils.Time (CPUTime(..), fromMilliseconds)+import Agda.Syntax.Common.Pretty+ ( Doc, Pretty, comma, hsep, nest, parens, pretty, prettyShow+ , text, vcat, (<+>), ($+$)+ )+import qualified Agda.Interaction.Options.ProfileOptions as Profile -- | When profile options are set or changed, we need to turn benchmarking on or off. updateBenchmarkingStatus :: TCM ()@@ -47,6 +60,9 @@ print :: MonadTCM tcm => tcm () print = liftTCM $ whenM (B.isBenchmarkOn [] <$> benchmarking) $ do b <- B.getBenchmark+ extra <- ifM moduleThroughputEnabled+ (moduleThroughputDoc b)+ (pure mempty) -- Andreas, 2017-07-29, issue #2602: -- The following line messes up the AgdaInfo buffer, -- thus, as Fredrik Forsberg suggest, I restore the original@@ -56,7 +72,110 @@ -- 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.- displayDebugMessage "profile" 2 $ prettyShow b+ displayDebugMessage "profile" 2 $ pretty b $+$ extra++moduleThroughputEnabled :: TCM Bool+moduleThroughputEnabled = do+ modulesProfiling <- hasProfileOption Profile.Modules+ sequential <- sequentialTypeChecking+ pure $ modulesProfiling && sequential++sequentialTypeChecking :: TCM Bool+sequentialTypeChecking = do+ opts <- commandLineOptions+ pure $ case optParallelChecking opts of+ Sequential -> True+ Parallel{} -> False++data ModuleThroughput = ModuleThroughput+ { mtModuleName :: TopLevelModuleName+ , mtLineCount :: Int+ , mtTime :: CPUTime+ }++instance Pretty ModuleThroughput where+ pretty mt =+ text (prettyShow $ mtModuleName mt) <+>+ parens+ (hsep+ [ (text (show (mtLineCount mt)) <+> "lines") <> comma+ , text (show (linesPerSecond mt)) <+> "lines/s"+ ])++moduleThroughputDoc :: Benchmark -> TCM Doc+moduleThroughputDoc b = do+ stats <- mapMaybeM loadModuleThroughput (moduleRows b)+ pure $ renderModuleThroughput stats++renderModuleThroughput :: [ModuleThroughput] -> Doc+renderModuleThroughput [] = mempty+renderModuleThroughput stats =+ vcat+ [ mempty+ , mempty+ , text "Module throughput:"+ , vcat $ map (nest 2 . pretty) stats+ ]++-- | Keep only benchmark entries corresponding to top-level modules,+-- using the aggregate module time.+moduleRows :: Benchmark -> [(TopLevelModuleName, CPUTime)]+moduleRows =+ mapMaybe moduleRow . orderedBenchmarkEntries+ where+ moduleRow (acc, (_selfTime, totalTime)) =+ case acc of+ [TopModule m] -> Just (m, totalTime)+ _ -> Nothing++-- | Flatten benchmark timings into entries ordered by aggregate time,+-- skipping entries with aggregate time below 10 ms.+-- Each entry stores:+-- * the account path+-- * time stored at this node+-- * the aggregate time of the whole subtree+orderedBenchmarkEntries :: Benchmark -> [(Account, (CPUTime, CPUTime))]+orderedBenchmarkEntries =+ Trie.toListOrderedBy (flip compare `on` snd)+ . Trie.filter ((> fromMilliseconds 10) . snd)+ . Trie.mapSubTries (Just . aggregateNode)+ . B.timings++-- | For a benchmark trie node, return:+-- * time stored at this node+-- * the aggregate time of the whole subtree+aggregateNode :: Ord a => Trie.Trie a CPUTime -> (CPUTime, CPUTime)+aggregateNode t =+ ( fromMaybe 0 $ Trie.lookup [] t+ , getSum $ foldMap' Sum t+ )++-- | Compute the throughput of a module from the benchmark time.+-- Returns 'Nothing' if the module is not in the visited-module cache,+-- which happens when the module failed to check: its time was billed,+-- but it never got an interface.+loadModuleThroughput+ :: (TopLevelModuleName, CPUTime)+ -> TCM (Maybe ModuleThroughput)+loadModuleThroughput (mName, totalTime) =+ getVisitedModule mName <&> fmap \ mi -> ModuleThroughput+ { mtModuleName = mName+ , mtTime = totalTime+ , mtLineCount = length (lines (TL.unpack (iSource (miInterface mi))))+ }++picosecondsPerSecond :: Integer+picosecondsPerSecond = 1e12++linesPerSecond :: ModuleThroughput -> Integer+linesPerSecond ModuleThroughput{ mtLineCount, mtTime = CPUTime ps }+ | ps == 0 = 0+ | otherwise = round throughput+ where+ elapsedSeconds =+ fromInteger ps / fromInteger picosecondsPerSecond+ throughput =+ fromIntegral mtLineCount / elapsedSeconds -- -- | Bill a computation to a specific account. -- {-# SPECIALIZE billTo :: Account -> TCM a -> TCM a #-}
src/full/Agda/TypeChecking/Monad/Builtin.hs view
@@ -34,6 +34,10 @@ import Agda.Utils.Tuple import Agda.Utils.Update +import Agda.Utils.StrictReader qualified as Strict+import Agda.Utils.StrictWriter qualified as Strict+import Agda.Utils.StrictState qualified as Strict+ import Agda.Utils.Impossible class ( Functor m@@ -42,6 +46,7 @@ ) => HasBuiltins m where getBuiltinThing :: SomeBuiltin -> m (Maybe (Builtin PrimFun)) + {-# INLINE getBuiltinThing #-} default getBuiltinThing :: (MonadTrans t, HasBuiltins n, t n ~ m) => SomeBuiltin -> m (Maybe (Builtin PrimFun)) getBuiltinThing = lift . getBuiltinThing @@ -53,6 +58,9 @@ instance HasBuiltins m => HasBuiltins (ReaderT e m) instance HasBuiltins m => HasBuiltins (StateT s m) instance (HasBuiltins m, Monoid w) => HasBuiltins (WriterT w m)+instance HasBuiltins m => HasBuiltins (Strict.ReaderT e m)+instance HasBuiltins m => HasBuiltins (Strict.StateT s m)+instance (HasBuiltins m, Monoid w) => HasBuiltins (Strict.WriterT w m) deriving instance HasBuiltins m => HasBuiltins (BlockT m) @@ -164,13 +172,13 @@ -- Def f [] -> Just f -- _ -> Nothing -{-# INLINABLE getBuiltin #-}+{-# SPECIALIZE getBuiltin :: BuiltinId -> TCM Term #-} getBuiltin :: (HasBuiltins m, MonadTCError m) => BuiltinId -> m Term getBuiltin x = fromMaybeM (typeError $ NoBindingForBuiltin x) $ getBuiltin' x -{-# INLINABLE getBuiltin' #-}+{-# SPECIALIZE getBuiltin' :: BuiltinId -> TCM (Maybe Term) #-} -- | Returns 'Nothing' if built-in is not bound or bound to a 'Prim'. getBuiltin' :: HasBuiltins m => BuiltinId -> m (Maybe Term) getBuiltin' x = (getBuiltin =<<) <$> getBuiltinThing (BuiltinName x)@@ -180,7 +188,7 @@ Prim{} -> Nothing BuiltinRewriteRelations{} -> __IMPOSSIBLE__ -{-# INLINABLE getPrimitive' #-}+{-# SPECIALIZE getPrimitive' :: PrimitiveId -> TCM (Maybe PrimFun) #-} -- | Returns 'Nothing' if primitive is not bound or bound to a 'Builtin'. getPrimitive' :: HasBuiltins m => PrimitiveId -> m (Maybe PrimFun) getPrimitive' x = (getPrim =<<) <$> getBuiltinThing (PrimitiveName x)@@ -228,10 +236,19 @@ constructorForm v = do let pZero = fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinZero pSuc = fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSuc+ -- By passing the builtins lazily we do not have to look them up if @v@ is not a 'LitNat'. constructorForm' pZero pSuc v +-- | Produce a function that rewrites a literal to constructor form if possible.+constructorFormer :: HasBuiltins m => m (Term -> Term)+constructorFormer = do+ mz <- getBuiltin' builtinZero+ ms <- getBuiltin' builtinSuc+ return \ v -> fromMaybe v (constructorForm' mz ms v)+ {-# INLINABLE constructorForm' #-} {-# SPECIALIZE constructorForm' :: TCM Term -> TCM Term -> Term -> TCM Term #-}+{-# SPECIALIZE constructorForm' :: Maybe Term -> Maybe Term -> Term -> Maybe Term #-} constructorForm' :: Applicative m => m Term -> m Term -> Term -> m Term constructorForm' pZero pSuc v = case v of@@ -271,6 +288,7 @@ primLevelUniv, primProp, primSet, primStrictSet, primPropOmega, primSetOmega, primSSetOmega, primFromNat, primFromNeg, primFromString,+ primQuotientConstructor, -- builtins for reflection: primQName, primArgInfo, primArgArgInfo, primArg, primArgArg, primAbs, primAbsAbs, primAgdaTerm, primAgdaTermVar, primAgdaTermLam, primAgdaTermExtLam, primAgdaTermDef, primAgdaTermCon, primAgdaTermPi,@@ -404,6 +422,7 @@ primFromNat = getBuiltin builtinFromNat primFromNeg = getBuiltin builtinFromNeg primFromString = getBuiltin builtinFromString+primQuotientConstructor = getBuiltin builtinQuotientConstructor primQName = getBuiltin builtinQName primArg = getBuiltin builtinArg primArgArg = getBuiltin builtinArgArg@@ -587,7 +606,7 @@ -- 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 :: (HasBuiltins m, MonadTCError m) => m SortKit sortKit = do prop <- getBuiltinName_ builtinProp set <- getBuiltinName_ builtinSet@@ -617,7 +636,7 @@ getPrimName :: Term -> QName getPrimName ty = do- let lamV (Lam i b) = mapFst (getHiding i :) $ lamV (unAbs b)+ let lamV (Lam i b) = first (getHiding i :) $ lamV (unAbs b) lamV (Pi _ b) = lamV (unEl $ unAbs b) lamV v = ([], v) case lamV ty of@@ -747,7 +766,7 @@ -- 1. universe and type polymorphic -- 2. type polymorphic only -- 3. monomorphic.- let lamV (Lam i b) = mapFst (getHiding i :) $ lamV (unAbs b)+ let lamV (Lam i b) = first (getHiding i :) $ lamV (unAbs b) lamV v = ([], v) return $ case lamV eq of (_, Def equality _) -> equality
src/full/Agda/TypeChecking/Monad/Caching.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wunused-imports #-}+-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-all -dno-suppress-type-signatures -ddump-to-file -dno-typeable-binds #-} module Agda.TypeChecking.Monad.Caching ( -- * Log reading/writing operations@@ -15,6 +16,8 @@ -- * Restoring the 'PostScopeState' , restorePostScopeState++ , cachingStartsTEST ) where import qualified Data.Set as Set@@ -27,28 +30,45 @@ import Agda.TypeChecking.Monad.Debug import qualified Agda.Utils.BiMap as BiMap-import Agda.Utils.Lens import Agda.Utils.Monad import Agda.Utils.Null (empty) import Agda.Utils.Impossible +{-# NOINLINE cachingStartsTEST #-}+cachingStartsTEST :: TCM ()+cachingStartsTEST = do+ NameId _ m <- useTC stFreshNameId+ stFreshNameId `setTCLens` NameId 1 m+ stFreshOpaqueId `setTCLens` OpaqueId 1 m+ stAreWeCaching `setTCLens` True+ validateCache m -- fixes issue #4835+ where+ validateCache m = (localCache readFromCachedLog) >>= \case+ Just (_ , s) -> do+ let+ NameId _ m' = s ^. lensFreshNameId+ OpaqueId _ m'' = s ^. lensFreshOpaqueId+ stale = (m' /= m) || (m'' /= m)+ when stale cleanCachedLog+ _ -> return ()+ -- | To be called before any write or restore calls. {-# SPECIALIZE cachingStarts :: TCM () #-} cachingStarts :: (MonadDebug m, MonadTCState m, ReadTCState m) => m () cachingStarts = do NameId _ m <- useTC stFreshNameId- stFreshNameId `setTCLens` NameId 1 m+ stFreshNameId `setTCLens` NameId 1 m stFreshOpaqueId `setTCLens` OpaqueId 1 m- stAreWeCaching `setTCLens` True+ stAreWeCaching `setTCLens` True validateCache m -- fixes issue #4835 where validateCache m = (localCache readFromCachedLog) >>= \case Just (_ , s) -> do let- NameId _ m' = stPostFreshNameId s- OpaqueId _ m'' = stPostFreshOpaqueId s- stale = or [ m' /= m, m'' /= m ]+ NameId _ m' = s ^. lensFreshNameId+ OpaqueId _ m'' = s ^. lensFreshOpaqueId+ stale = (m' /= m) || (m'' /= m) when stale cleanCachedLog _ -> return () @@ -71,12 +91,11 @@ modifyTC $ \s -> let ipoints = s ^. stInteractionPoints ws = s ^. stTCWarnings- pss' = pss{stPostInteractionPoints = stPostInteractionPoints pss `mergeIPMap` ipoints- ,stPostTCWarnings = stPostTCWarnings pss `mergeWarnings` ws- ,stPostOpaqueBlocks = s ^. stOpaqueBlocks- ,stPostOpaqueIds = s ^. stOpaqueIds- }- in s{stPostScopeState = pss'}+ pss' = pss & lensInteractionPoints %~ (`mergeIPMap` ipoints)+ & lensTCWarnings %~ (`mergeWarnings` ws)+ & lensOpaqueBlocks .~ s ^. stOpaqueBlocks+ & lensOpaqueIds .~ s ^. stOpaqueIds+ in s{stPostScopeState = pss'} where mergeIPMap lm sm = BiMap.mapWithKey (\k v -> maybe v (`mergeIP` v) (BiMap.lookup k lm)) sm -- see #1338 on why we need to use the new ranges.
src/full/Agda/TypeChecking/Monad/Closure.hs view
@@ -8,16 +8,15 @@ import Agda.TypeChecking.Monad.Env import Agda.TypeChecking.Monad.State -import Agda.Utils.Lens- {-# INLINE enterClosure #-} enterClosure :: (MonadTCEnv m, ReadTCState m, LensClosure c a) => c -> (a -> m b) -> m b enterClosure c k | Closure _sig env scope cps x <- c ^. lensClosure = do isDbg <- viewTC eIsDebugPrinting- withScope_ scope+ evalWithScope scope+ -- TODO: use the signature here? would that fix parts of issue #118? $ locallyTCState stModuleCheckpoints (const cps)- $ withEnv env{ envIsDebugPrinting = isDbg }+ $ withEnv (env & eIsDebugPrinting .~ isDbg) $ k x {-# INLINE withClosure #-}
src/full/Agda/TypeChecking/Monad/Constraints.hs view
@@ -1,7 +1,6 @@ module Agda.TypeChecking.Monad.Constraints where -import Control.Arrow ((&&&)) import Control.Monad.Except import Control.Monad.Reader @@ -9,7 +8,6 @@ import qualified Data.List as List import Data.Set (Set) import qualified Data.Set as Set-import Data.Semigroup ((<>)) import Agda.Interaction.Options.Base import Agda.Syntax.Internal@@ -17,16 +15,28 @@ import Agda.TypeChecking.Monad.Closure import Agda.TypeChecking.Monad.Debug +import Agda.Utils.List import Agda.Utils.Lens import Agda.Utils.Monad+import Agda.Utils.Tuple ((&&&))+import Agda.Utils.StrictReader qualified as Strict +{-# INLINE solvingProblem #-} solvingProblem :: MonadConstraint m => ProblemId -> m a -> m a-solvingProblem pid = solvingProblems (Set.singleton pid)+solvingProblem pid m = verboseBracket "tc.constr.solve" 50 ("working on problem " ++ show pid) $ do+ x <- localTC (over eActiveProblems (Set.insert pid)) m+ ifNotM (isProblemSolved pid)+ (reportSLn "tc.constr.solve" 50 $ "problem " ++ show pid ++ " was not solved.")+ $ {- else -} do+ reportSLn "tc.constr.solve" 50 $ "problem " ++ show pid ++ " was solved!"+ wakeConstraints (wakeIfBlockedOnProblem pid . constraintUnblocker)+ return x +{-# INLINE solvingProblems #-} solvingProblems :: MonadConstraint m => Set ProblemId -> m a -> m a solvingProblems pids m = verboseBracket "tc.constr.solve" 50 ("working on problems " ++ show (Set.toList pids)) $ do- x <- localTC (\e -> e { envActiveProblems = pids `Set.union` envActiveProblems e }) m- Fold.forM_ pids $ \ pid -> do+ x <- localTC (over eActiveProblems (pids `Set.union`)) m+ Fold.forM_ pids \pid -> do ifNotM (isProblemSolved pid) (reportSLn "tc.constr.solve" 50 $ "problem " ++ show pid ++ " was not solved.") $ {- else -} do@@ -41,18 +51,33 @@ isProblemCompletelySolved = isProblemSolved' True isProblemSolved' :: (MonadTCEnv m, ReadTCState m) => Bool -> ProblemId -> m Bool-isProblemSolved' completely pid =- and2M (not . Set.member pid <$> asksTC envActiveProblems)- (not . any belongsToUs <$> getAllConstraints)+isProblemSolved' completely pid = do+ active <- viewTC eActiveProblems+ tc <- getTCState+ pure $! not (Set.member pid active)+ && not (any belongsToUs (tc ^. stAwakeConstraints))+ && not (any belongsToUs (tc ^. stSleepingConstraints)) where belongsToUs c | Set.notMember pid (constraintProblems c) = False | isBlockingConstraint (clValue $ theConstraint c) = True | otherwise = completely -- Ignore non-blocking unless `completely` +isProblemSolved'' :: ProblemId -> TCM Bool+isProblemSolved'' pid = do+ active <- viewTC eActiveProblems+ tc <- getTCState+ pure $! not (any belongsToUs (tc ^. stAwakeConstraints))+ && not (any belongsToUs (tc ^. stSleepingConstraints))+ where+ belongsToUs c+ | Set.notMember pid (constraintProblems c) = False+ | isBlockingConstraint (clValue $ theConstraint c) = True+ | otherwise = False+ {-# SPECIALIZE getConstraintsForProblem :: ProblemId -> TCM Constraints #-} getConstraintsForProblem :: ReadTCState m => ProblemId -> m Constraints-getConstraintsForProblem pid = List.filter (Set.member pid . constraintProblems) <$> getAllConstraints+getConstraintsForProblem pid = filter' (Set.member pid . constraintProblems) <$> getAllConstraints -- | Get the awake constraints getAwakeConstraints :: ReadTCState m => m Constraints@@ -61,26 +86,24 @@ -- danger... dropConstraints :: MonadConstraint m => (ProblemConstraint -> Bool) -> m () dropConstraints crit = do- let filt = List.filter $ not . crit- modifySleepingConstraints filt- modifyAwakeConstraints filt+ let filt = filter' $ not . crit+ modifyConstraints filt filt -- | Takes out all constraints matching given filter. -- Danger! The taken constraints need to be solved or put back at some point. takeConstraints :: MonadConstraint m => (ProblemConstraint -> Bool) -> m Constraints takeConstraints f = do- (takeAwake , keepAwake ) <- List.partition f <$> useTC stAwakeConstraints- (takeAsleep, keepAsleep) <- List.partition f <$> useTC stSleepingConstraints- modifyAwakeConstraints $ const keepAwake- modifySleepingConstraints $ const keepAsleep- return $ takeAwake ++ takeAsleep+ tc <- getTCState+ let (takeAwake , keepAwake ) = partition' f $ tc ^. stAwakeConstraints+ let (takeAsleep, keepAsleep) = partition' f $ tc ^. stSleepingConstraints+ modifyConstraints (const keepAwake) (const keepAsleep)+ return $! takeAwake ++! takeAsleep putConstraintsToSleep :: MonadConstraint m => (ProblemConstraint -> Bool) -> m () putConstraintsToSleep sleepy = do awakeOnes <- useR stAwakeConstraints- let (gotoSleep, stayAwake) = List.partition sleepy awakeOnes- modifySleepingConstraints $ (++ gotoSleep)- modifyAwakeConstraints $ const stayAwake+ let (!gotoSleep, !stayAwake) = partition' sleepy awakeOnes+ modifyConstraints (const stayAwake) (++! gotoSleep) -- TODO: quadratic append! putAllConstraintsToSleep :: MonadConstraint m => m () putAllConstraintsToSleep = putConstraintsToSleep (const True)@@ -93,13 +116,12 @@ -- by events that would normally trigger a wakeup call. holdConstraints :: (ConstraintStatus -> ProblemConstraint -> Bool) -> TCM a -> TCM a holdConstraints p m = do- (holdAwake, stillAwake) <- List.partition (p AwakeConstraint) <$> useTC stAwakeConstraints- (holdAsleep, stillAsleep) <- List.partition (p SleepingConstraint) <$> useTC stSleepingConstraints- stAwakeConstraints `setTCLens` stillAwake- stSleepingConstraints `setTCLens` stillAsleep- let restore = do- stAwakeConstraints `modifyTCLens` (holdAwake ++)- stSleepingConstraints `modifyTCLens` (holdAsleep ++)+ tc <- getTCState+ let (!holdAwake, !stillAwake) = partition' (p AwakeConstraint) $ tc ^. stAwakeConstraints+ let (!holdAsleep, !stillAsleep) = partition' (p SleepingConstraint) $ tc ^. stSleepingConstraints+ modifyTC' $ set stAwakeConstraints stillAwake . set stSleepingConstraints stillAsleep+ let restore = modifyTC' $ over stAwakeConstraints (holdAwake ++!)+ . over stSleepingConstraints (holdAsleep ++!) catchError (m <* restore) (\ err -> restore *> throwError err) takeAwakeConstraint :: MonadConstraint m => m (Maybe ProblemConstraint)@@ -113,21 +135,22 @@ case break p cs of (_, []) -> return Nothing (cs0, c : cs) -> do- modifyAwakeConstraints $ const (cs0 ++ cs)+ modifyAwakeConstraints $ const (cs0 ++! cs) return $ Just c getAllConstraints :: ReadTCState m => m Constraints getAllConstraints = do s <- getTCState- return $ s ^. stAwakeConstraints ++ s ^. stSleepingConstraints+ return $! s ^. stAwakeConstraints ++! s ^. stSleepingConstraints withConstraint :: MonadConstraint m => (Constraint -> m a) -> ProblemConstraint -> m a withConstraint f (PConstr pids _ c) = do -- We should preserve the problem stack and the isSolvingConstraint flag- (pids', isSolving) <- asksTC $ envActiveProblems &&& envSolvingConstraints- enterClosure c $ \c ->- localTC (\e -> e { envActiveProblems = pids', envSolvingConstraints = isSolving }) $- solvingProblems pids (f c)+ pids' <- viewTC eActiveProblems+ isSolving <- viewTC eSolvingConstraints+ enterClosure c \c ->+ localTC (set eActiveProblems pids' . set eSolvingConstraints isSolving) $+ solvingProblems pids (f c) buildProblemConstraint :: (MonadTCEnv m, ReadTCState m)@@ -141,7 +164,7 @@ buildConstraint :: Blocker -> Constraint -> TCM ProblemConstraint buildConstraint unblock c = do- pids <- asksTC envActiveProblems+ pids <- viewTC eActiveProblems buildProblemConstraint pids unblock c -- | Monad service class containing methods for adding and solving@@ -169,9 +192,16 @@ stealConstraints :: ProblemId -> m () + -- | Modify both awake (first argument) and sleeping (second argument) constraints.+ modifyConstraints :: (Constraints -> Constraints) -> (Constraints -> Constraints) -> m ()++ {-# INLINE modifyAwakeConstraints #-} modifyAwakeConstraints :: (Constraints -> Constraints) -> m ()+ modifyAwakeConstraints f = modifyConstraints f id + {-# INLINE modifySleepingConstraints #-} modifySleepingConstraints :: (Constraints -> Constraints) -> m ()+ modifySleepingConstraints f = modifyConstraints id f instance MonadConstraint m => MonadConstraint (ReaderT e m) where addConstraint = (lift .) . addConstraint@@ -179,10 +209,25 @@ solveConstraint = lift . solveConstraint solveSomeAwakeConstraints = (lift .) . solveSomeAwakeConstraints stealConstraints = lift . stealConstraints- modifyAwakeConstraints = lift . modifyAwakeConstraints- modifySleepingConstraints = lift . modifySleepingConstraints- wakeConstraints = lift . wakeConstraints+ modifyConstraints = (lift .) . modifyConstraints+ wakeConstraints = lift . wakeConstraints +instance MonadConstraint m => MonadConstraint (Strict.ReaderT e m) where+ {-# INLINE addConstraint #-}+ addConstraint = (lift .) . addConstraint+ {-# INLINE addAwakeConstraint #-}+ addAwakeConstraint = (lift .) . addAwakeConstraint+ {-# INLINE solveConstraint #-}+ solveConstraint = lift . solveConstraint+ {-# INLINE solveSomeAwakeConstraints #-}+ solveSomeAwakeConstraints = (lift .) . solveSomeAwakeConstraints+ {-# INLINE stealConstraints #-}+ stealConstraints = lift . stealConstraints+ {-# INLINE modifyConstraints #-}+ modifyConstraints = (lift .) . modifyConstraints+ {-# INLINE wakeConstraints #-}+ wakeConstraints = lift . wakeConstraints+ -- | Add new a constraint addConstraint' :: Blocker -> Constraint -> TCM () addConstraint' = addConstraintTo stSleepingConstraints@@ -190,11 +235,12 @@ addAwakeConstraint' :: Blocker -> Constraint -> TCM () addAwakeConstraint' = addConstraintTo stAwakeConstraints +{-# INLINE addConstraintTo #-} addConstraintTo :: Lens' TCState Constraints -> Blocker -> Constraint -> TCM () addConstraintTo bucket unblock c = do pc <- buildConstraint unblock c- stDirty `setTCLens` True- bucket `modifyTCLens` (pc :)+ tc <- getTCState+ putTC $! tc & stDirty .~ True & bucket %~ (pc :) -- | A problem is considered solved if there are no unsolved blocking constraints belonging to it. -- There's no really good principle for what constraints are blocking and which are not, but the@@ -223,17 +269,19 @@ CheckType{} -> True CheckLockedVars{} -> True UsableAtModality{} -> True+ RewConstraint{} -> True -- | Start solving constraints nowSolvingConstraints :: MonadTCEnv m => m a -> m a-nowSolvingConstraints = localTC $ \e -> e { envSolvingConstraints = True }+nowSolvingConstraints = localTC (set eSolvingConstraints True) isSolvingConstraints :: MonadTCEnv m => m Bool-isSolvingConstraints = asksTC envSolvingConstraints+isSolvingConstraints = viewTC eSolvingConstraints +{-# INLINE catchConstraint #-} -- | Add constraint if the action raises a pattern violation catchConstraint :: MonadConstraint m => Constraint -> m () -> m ()-catchConstraint c = catchPatternErr $ \ unblock -> addConstraint unblock c+catchConstraint c = catchPatternErr \unblock -> addConstraint unblock c isInstanceConstraint :: Constraint -> Bool isInstanceConstraint FindInstance{} = True
src/full/Agda/TypeChecking/Monad/Context.hs view
@@ -1,3 +1,4 @@+-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-all -dno-suppress-type-signatures -ddump-to-file -dno-typeable-binds #-} module Agda.TypeChecking.Monad.Context where @@ -14,143 +15,257 @@ import Control.Monad.Writer ( WriterT ) import Data.Foldable+import qualified Data.HashMap.Strict as HMap+import qualified Data.IntMap as IntMap import qualified Data.List as List import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Set (Set) import Agda.Syntax.Abstract.Name import Agda.Syntax.Common import Agda.Syntax.Common.Pretty import Agda.Syntax.Concrete.Name (NameInScope(..), LensInScope(..), nameRoot, nameToRawName)+import Agda.Syntax.Concrete.Name qualified as C import Agda.Syntax.Internal import Agda.Syntax.Position import Agda.Syntax.Scope.Base +import Agda.TypeChecking.Free (Free, freeVarList) import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Substitute import Agda.TypeChecking.Monad.Open import Agda.TypeChecking.Monad.State+import Agda.TypeChecking.Warnings (warning, MonadWarning) import Agda.Utils.Function import Agda.Utils.Functor+import Agda.Utils.Impossible import Agda.Utils.Lens-import Agda.Utils.List ((!!!), downFrom)+import Agda.Utils.List import Agda.Utils.ListT import Agda.Utils.List1 (List1, pattern (:|)) import qualified Agda.Utils.List1 as List1 import qualified Agda.Utils.Set1 as Set1 import Agda.Utils.Maybe+import Agda.Utils.Monad (mzero, void)+import Agda.Utils.Null (empty) import Agda.Utils.Size import Agda.Utils.Tuple import Agda.Utils.Update ++import Agda.Utils.StrictReader qualified as Strict+import Agda.Utils.StrictWriter qualified as Strict+import Agda.Utils.StrictState qualified as Strict+ import Agda.Utils.Impossible + -- * Modifying the context -- | Modify a 'Context' in a computation. Warning: does not update -- the checkpoints. Use @updateContext@ instead. {-# INLINE unsafeModifyContext #-} unsafeModifyContext :: MonadTCEnv tcm => (Context -> Context) -> tcm a -> tcm a-unsafeModifyContext f = localTC $ \e -> e { envContext = f $ envContext e }+unsafeModifyContext f = localTC (over eContext f) {-# INLINE modifyContextInfo #-} -- | Modify the 'Dom' part of context entries. modifyContextInfo :: MonadTCEnv tcm => (forall e. Dom e -> Dom e) -> tcm a -> tcm a-modifyContextInfo f = unsafeModifyContext $ map $ \case+modifyContextInfo f = unsafeModifyContext $ fmap $ \case (CtxVar x a) -> CtxVar x (f a) -- | Change to top (=empty) context. Resets the checkpoints.-{-# SPECIALIZE inTopContext :: TCM a -> TCM a #-}+{-# INLINE inTopContext #-} inTopContext :: (MonadTCEnv tcm, ReadTCState tcm) => tcm a -> tcm a inTopContext cont =- unsafeModifyContext (const [])+ unsafeModifyContext (const CxEmpty) $ locallyTC eCurrentCheckpoint (const 0) $ locallyTC eCheckpoints (const $ Map.singleton 0 IdS)- $ locallyTCState stModuleCheckpoints (const Map.empty) $ locallyScope scopeLocals (const []) $ locallyTC eLetBindings (const Map.empty)+ $ locallyTC eLocalRewriteRules (const empty)+ $ withoutModuleCheckpoints $ cont -- | Change to top (=empty) context, but don't update the checkpoints. Totally -- not safe!-{-# SPECIALIZE unsafeInTopContext :: TCM a -> TCM a #-}+{-# INLINE unsafeInTopContext #-} unsafeInTopContext :: (MonadTCEnv m, ReadTCState m) => m a -> m a unsafeInTopContext cont = locallyScope scopeLocals (const []) $- unsafeModifyContext (const []) cont+ unsafeModifyContext (const CxEmpty) cont -- | Delete the last @n@ bindings from the context. -- -- Doesn't update checkpoints! Use `escapeContext` or `updateContext -- rho (drop n)` instead, for an appropriate substitution `rho`.-{-# SPECIALIZE unsafeEscapeContext :: Int -> TCM a -> TCM a #-}+{-# INLINE unsafeEscapeContext #-} unsafeEscapeContext :: MonadTCM tcm => Int -> tcm a -> tcm a-unsafeEscapeContext n = unsafeModifyContext $ drop n+unsafeEscapeContext n = unsafeModifyContext $ cxDrop n -{-# SPECIALIZE escapeContext :: Impossible -> Int -> TCM a -> TCM a #-}+{-# INLINE escapeContext #-} -- | Delete the last @n@ bindings from the context. Any occurrences of -- these variables are replaced with the given @err@. escapeContext :: MonadAddContext m => Impossible -> Int -> m a -> m a-escapeContext err n = updateContext (strengthenS err n) $ drop n+escapeContext err n = updateContext (strengthenS err n) $ cxDrop n -- * Manipulating checkpoints -- -{-# SPECIALIZE checkpoint :: Substitution -> TCM a -> TCM a #-}+-- {-# NOINLINE checkpoint' #-}+-- checkpoint' :: Substitution -> TCM a -> TCM a+-- checkpoint' = checkpoint++{-# INLINE checkpoint #-} -- | Add a new checkpoint. Do not use directly!-checkpoint- :: (MonadDebug tcm, MonadTCM tcm, MonadFresh CheckpointId tcm, ReadTCState tcm)- => Substitution -> tcm a -> tcm a+-- Also updates head symbols of local rewrite rules with variable heads+checkpoint :: Substitution -> TCM a -> TCM a checkpoint sub k = do unlessDebugPrinting $ reportSLn "tc.cxt.checkpoint" 105 $ "New checkpoint {"- old <- viewTC eCurrentCheckpoint- oldMods <- useTC stModuleCheckpoints- chkpt <- fresh+ old <- viewTC eCurrentCheckpoint+ tc <- getTC+ let oldChkpts = tc ^. stModuleCheckpoints+ let chkpt = tc ^. freshLens+ putTC $! tc & freshLens .~ (nextFresh' chkpt)+ unlessDebugPrinting $ verboseS "tc.cxt.checkpoint" 105 $ do cxt <- getContextTelescope cps <- viewTC eCheckpoints let cps' = Map.insert chkpt IdS $ fmap (applySubst sub) cps prCps cps = vcat [ pshow c <+> ": " <+> pretty s | (c, s) <- Map.toList cps ]- reportSDoc "tc.cxt.checkpoint" 105 $ return $ nest 2 $ vcat+ reportS "tc.cxt.checkpoint" 105 $ nest 2 $ vcat [ "old =" <+> pshow old , "new =" <+> pshow chkpt , "sub =" <+> pretty sub , "cxt =" <+> pretty cxt+ , "mods =" <+> pretty oldChkpts , "old substs =" <+> prCps cps , "new substs =" <?> prCps cps' ]- x <- flip localTC k $ \ env -> env- { envCurrentCheckpoint = chkpt- , envCheckpoints = Map.insert chkpt IdS $- fmap (applySubst sub) (envCheckpoints env)- }- newMods <- useTC stModuleCheckpoints++ x <- localTC ( set eCurrentCheckpoint chkpt+ . over eCheckpoints (Map.insert chkpt IdS . fmap (applySubst sub))+ . over eLocalRewriteRules (updateLocalRewriteHeads sub)+ )+ k++ unlessDebugPrinting $ verboseS "tc.cxt.checkpoint" 105 $ do+ newChkpts <- useTC stModuleCheckpoints+ reportS "tc.cxt.checkpoint" 105 $ nest 2 $+ "mods before unwind =" <+> pretty newChkpts+ -- Set the checkpoint for introduced modules to the old checkpoint when the -- new one goes out of scope. #2897: This isn't actually sound for modules -- 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 <$ newMods)++ -- [HACK: Repairing module checkpoints after state resets]+ -- Ideally, we could just walk up the current module checkpoint stack+ -- until we hit the the @old@ checkpoint. This works in most cases, but breaks if+ -- @k@ resets the typechecking state to a state defined *before* the call to+ -- @checkpoint@: this can result in us discarding module checkpoints.+ --+ -- To prevent this, we walk up the current module checkpoint stack until+ -- we hit our previous checkpoint, and add any module checkpoints onto+ -- the checkpoint stack we had before we ran @k@.+ unwindModuleCheckpointsOnto old oldChkpts++ unlessDebugPrinting $ verboseS "tc.cxt.checkpoint" 105 $ do+ unwoundChkpts <- useTC stModuleCheckpoints+ reportS "tc.cxt.checkpoint" 105 $ nest 2 $+ "unwound mods =" <+> pretty unwoundChkpts+ unlessDebugPrinting $ reportSLn "tc.cxt.checkpoint" 105 "}" return x +-- | Update heads of local rewrite rules for the new context+updateLocalRewriteHeads ::+ Substitution -> LocalRewriteRuleMap -> LocalRewriteRuleMap+updateLocalRewriteHeads sub = over lrewsVarHeaded (IntMap.mapKeys subHead)+ where+ subHead x = fromMaybe __IMPOSSIBLE__ $ lookupSVar sub x++-- | Add a module checkpoint for the provided @ModuleName@.+{-# SPECIALIZE setModuleCheckpoint :: ModuleName -> CheckpointId -> TCM () #-}+setModuleCheckpoint :: (MonadTCState m) => ModuleName -> CheckpointId -> m ()+setModuleCheckpoint !mname !newChkpt =+ modifyTCLens' stModuleCheckpoints \case+ (ModuleCheckpointsSection chkpts mnames chkpt) | chkpt == newChkpt ->+ ModuleCheckpointsSection chkpts (Set.insert mname mnames) chkpt+ chkpts -> ModuleCheckpointsSection chkpts (Set.singleton mname) newChkpt++-- | Set every module checkpoint in the checkpoint stack to the provided @CheckpointId@.+{-# SPECIALIZE setAllModuleCheckpoints :: CheckpointId -> TCM () #-}+setAllModuleCheckpoints :: (MonadTCState m) => CheckpointId -> m ()+setAllModuleCheckpoints !chkpt =+ modifyTCLens' stModuleCheckpoints \case+ ModuleCheckpointsTop -> ModuleCheckpointsTop+ ModuleCheckpointsSection chkpts siblings _ -> setAll siblings chkpts+ where+ setAll :: Set ModuleName -> ModuleCheckpoints -> ModuleCheckpoints+ setAll acc ModuleCheckpointsTop = ModuleCheckpointsSection ModuleCheckpointsTop acc chkpt+ setAll acc (ModuleCheckpointsSection chkpts siblings _) = setAll (Set.union siblings acc) chkpts++-- | Unwind the current module checkpoint stack until we reach a target @CheckpointId@,+-- and place the checkpoints onto the provided @ModuleCheckpoints@ stack.+{-# SPECIALIZE NOINLINE unwindModuleCheckpointsOnto :: CheckpointId -> ModuleCheckpoints -> TCM () #-} -- TODO+unwindModuleCheckpointsOnto :: (MonadTCState m) => CheckpointId -> ModuleCheckpoints -> m ()+unwindModuleCheckpointsOnto !unwindTo !oldChkpts =+ -- We know that the checkpoints in the stack are sorted,+ -- so we can do a preliminary check to see if there's+ -- any work to be done.+ modifyTCLens' stModuleCheckpoints \case+ ModuleCheckpointsSection chkpts siblings chkpt | unwindTo < chkpt -> unwind siblings chkpts+ _ -> oldChkpts+ where+ unwind :: Set ModuleName -> ModuleCheckpoints -> ModuleCheckpoints+ unwind acc ModuleCheckpointsTop =+ ModuleCheckpointsSection ModuleCheckpointsTop acc unwindTo+ unwind acc (ModuleCheckpointsSection chkpts siblings chkpt)+ | chkpt < unwindTo =+ -- If the unwind target isnt present in the stack, we add it+ -- ourselves.+ ModuleCheckpointsSection oldChkpts acc unwindTo+ | chkpt == unwindTo =+ -- Make sure to avoid adding duplicate entries into the unwind+ -- stack: this would break later unwinds!+ ModuleCheckpointsSection oldChkpts (Set.union siblings acc) chkpt+ | otherwise = unwind (Set.union siblings acc) chkpts++{-# INLINE withoutModuleCheckpoints #-}+-- | Run a computation with no module checkpoints set.+withoutModuleCheckpoints :: (ReadTCState m) => m a -> m a+withoutModuleCheckpoints = locallyTCState stModuleCheckpoints (const ModuleCheckpointsTop)++{-# SPECIALIZE checkpointSubstitution :: CheckpointId -> TCM Substitution #-} -- | Get the substitution from the context at a given checkpoint to the current context. checkpointSubstitution :: MonadTCEnv tcm => CheckpointId -> tcm Substitution checkpointSubstitution = maybe __IMPOSSIBLE__ return <=< checkpointSubstitution' +{-# SPECIALIZE checkpointSubstitution' :: CheckpointId -> TCM (Maybe Substitution) #-} -- | Get the substitution from the context at a given checkpoint to the current context. checkpointSubstitution' :: MonadTCEnv tcm => CheckpointId -> tcm (Maybe Substitution) checkpointSubstitution' chkpt = viewTC (eCheckpoints . key chkpt) +-- | Get the @CheckpointId@ of a module name.+getModuleCheckpoint :: ModuleName -> ModuleCheckpoints -> Maybe CheckpointId+getModuleCheckpoint mname ModuleCheckpointsTop = Nothing+getModuleCheckpoint mname (ModuleCheckpointsSection chkpts siblings chkid)+ | Set.member mname siblings = Just chkid+ | otherwise = getModuleCheckpoint mname chkpts++{-# SPECIALIZE getModuleParameterSub :: ModuleName -> TCM (Maybe Substitution) #-} -- | Get substitution @Γ ⊢ ρ : Γm@ where @Γ@ is the current context -- and @Γm@ is the module parameter telescope of module @m@. -- -- Returns @Nothing@ in case the we don't have a checkpoint for @m@. getModuleParameterSub :: (MonadTCEnv m, ReadTCState m) => ModuleName -> m (Maybe Substitution) getModuleParameterSub m = do- mcp <- (^. stModuleCheckpoints . key m) <$> getTCState- traverse checkpointSubstitution mcp-+ chkpt <- getModuleCheckpoint m <$> useTC stModuleCheckpoints+ traverse checkpointSubstitution chkpt -- * Adding to the context @@ -163,8 +278,13 @@ addCtx :: Name -> Dom Type -> m a -> m a -- | Add a let bound variable to the context- addLetBinding' :: Origin -> Name -> Term -> Dom Type -> m a -> m a+ addLetBinding' ::+ IsAxiom -- ^ Does this let binding come from a 'LetAxiom'?+ -> Origin -> Name -> Term -> Dom Type -> m a -> m a + -- | Adds a local rewrite rule to the context+ addLocalRewrite :: RewriteRule -> m a -> m a+ -- | Update the context. -- Requires a substitution that transports things living in the old context -- to the new.@@ -172,21 +292,31 @@ withFreshName :: Range -> ArgName -> (Name -> m a) -> m a + {-# INLINE addCtx #-} default addCtx :: (MonadAddContext n, MonadTransControl t, t n ~ m) => Name -> Dom Type -> m a -> m a addCtx x a = liftThrough $ addCtx x a + {-# INLINE addLetBinding' #-} default addLetBinding' :: (MonadAddContext n, MonadTransControl t, t n ~ m)- => Origin -> Name -> Term -> Dom Type -> m a -> m a- addLetBinding' o x u a = liftThrough $ addLetBinding' o x u a+ => IsAxiom -> Origin -> Name -> Term -> Dom Type -> m a -> m a+ addLetBinding' isAxiom o x u a = liftThrough $ addLetBinding' isAxiom o x u a + {-# INLINE addLocalRewrite #-}+ default addLocalRewrite+ :: (MonadAddContext n, MonadTransControl t, t n ~ m)+ => RewriteRule -> m a -> m a+ addLocalRewrite r = liftThrough $ addLocalRewrite r++ {-# INLINE updateContext #-} default updateContext :: (MonadAddContext n, MonadTransControl t, t n ~ m) => Substitution -> (Context -> Context) -> m a -> m a updateContext sub f = liftThrough $ updateContext sub f + {-# INLINE withFreshName #-} default withFreshName :: (MonadAddContext n, MonadTransControl t, t n ~ m) => Range -> ArgName -> (Name -> m a) -> m a@@ -198,9 +328,15 @@ {-# INLINE defaultAddCtx #-} -- | Default implementation of addCtx in terms of updateContext defaultAddCtx :: MonadAddContext m => Name -> Dom Type -> m a -> m a-defaultAddCtx x a ret =- updateContext (raiseS 1) (CtxVar x a :) ret+defaultAddCtx x a ret = applyWhenJust (rewDom a) addRewDom $+ updateContext (raiseS 1) (CxExtendVar x a) ret +addRewDom :: MonadAddContext m => RewDom -> m a -> m a+addRewDom rew = case rewDomRew rew of+ Just r -> addLocalRewrite r+ Nothing -> __IMPOSSIBLE__++{-# INLINE withFreshName_ #-} withFreshName_ :: (MonadAddContext m) => ArgName -> (Name -> m a) -> m a withFreshName_ = withFreshName noRange @@ -211,61 +347,47 @@ instance MonadAddContext m => MonadAddContext (ReaderT r m) instance MonadAddContext m => MonadAddContext (StateT r m) instance (Monoid w, MonadAddContext m) => MonadAddContext (WriterT w m)+instance MonadAddContext m => MonadAddContext (Strict.ReaderT r m)+instance MonadAddContext m => MonadAddContext (Strict.StateT r m)+instance (Monoid w, MonadAddContext m) => MonadAddContext (Strict.WriterT w m) deriving instance MonadAddContext m => MonadAddContext (BlockT m) instance MonadAddContext m => MonadAddContext (ListT m) where addCtx x a = liftListT $ addCtx x a- addLetBinding' o x u a = liftListT $ addLetBinding' o x u a+ addLetBinding' isAxiom o x u a = liftListT $ addLetBinding' isAxiom o x u a+ addLocalRewrite r = liftListT $ addLocalRewrite r updateContext sub f = liftListT $ updateContext sub f withFreshName r x cont = ListT $ withFreshName r x $ runListT . cont --- | Run the given TCM action, and register the given variable as--- being shadowed by all the names with the same root that are added--- to the context during this TCM action.-withShadowingNameTCM :: Name -> TCM b -> TCM b-withShadowingNameTCM x f = do- reportSDoc "tc.cxt.shadowing" 80 $ pure $ "registered" <+> pretty x <+> "for shadowing"- when (isInScope x == InScope) $ tellUsedName x- (result , useds) <- listenUsedNames f- reportSDoc "tc.cxt.shadowing" 90 $ pure $ "all used names: " <+> text (show useds)- tellShadowing x useds- return result-- where- listenUsedNames f = do- origUsedNames <- useTC stUsedNames- setTCLens stUsedNames Map.empty- result <- f- newUsedNames <- useTC stUsedNames- 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 . (Set1.insertSet rawX) . Set1.toSet'-- 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 $ toList shadows)- modifyTCLens stShadowingNames $ Map.insertWith (<>) x shadows- Nothing -> return ()- instance MonadAddContext TCM where- addCtx x a ret = applyUnless (isNoName x) (withShadowingNameTCM x) $- defaultAddCtx x a ret+ {-# INLINE addCtx #-}+ addCtx !x !a !ret = defaultAddCtx x a ret - addLetBinding' o x u a ret = applyUnless (isNoName x) (withShadowingNameTCM x) $- defaultAddLetBinding' o x u a ret+ {-# INLINE addLetBinding' #-}+ addLetBinding' isAxiom o x u a ret = defaultAddLetBinding' isAxiom o x u a ret - updateContext sub f = unsafeModifyContext f . checkpoint sub+ {-# INLINE updateContext #-}+ updateContext !sub !f !act = unsafeModifyContext f (checkpoint sub act) + {-# INLINE addLocalRewrite #-}+ addLocalRewrite = defaultAddLocalRewrite++ {-# INLINE withFreshName #-} withFreshName r x m = freshName r x >>= m +{-# INLINE defaultAddLocalRewrite #-}+-- | Adds a rewrite rule to the local typechecking environment+defaultAddLocalRewrite :: (MonadTCEnv m, ReadTCState m)+ => RewriteRule -> m a -> m a+defaultAddLocalRewrite rew ret = do+ rew' <- makeOpen rew+ case rewHead rew of+ RewVarHead x -> locallyTC (eLocalRewriteRules . lrewsVarHeaded)+ (IntMap.insertWith mappend x [rew']) ret+ RewDefHead f -> locallyTC (eLocalRewriteRules . lrewsDefHeaded)+ (HMap.insertWith mappend f [rew']) ret++{-# INLINE addRecordNameContext #-} addRecordNameContext :: (MonadAddContext m, MonadFresh NameId m) => Dom Type -> m b -> m b@@ -285,94 +407,125 @@ instance {-# OVERLAPPABLE #-} AddContext a => AddContext [a] where addContext = flip (foldr addContext); {-# INLINABLE addContext #-}- contextSize = sum . map contextSize+ contextSize = sum . map' contextSize +instance AddContext Context where+ addContext = flip (foldl $ flip addContext); {-# INLINABLE addContext #-}+ contextSize = size+ instance AddContext ContextEntry where addContext (CtxVar x a) = addCtx x a {-# INLINE addContext #-} contextSize _ = 1 instance AddContext (Name, Dom Type) where- addContext = uncurry addCtx; {-# INLINE addContext #-}+ {-# INLINE addContext #-}+ addContext = uncurry addCtx; contextSize _ = 1-{-# SPECIALIZE addContext :: (Name, Dom Type) -> TCM a -> TCM a #-} instance AddContext (Dom (Name, Type)) where+ {-# INLINE addContext #-} addContext = addContext . distributeF contextSize _ = 1 instance AddContext (Dom (String, Type)) where+ {-# INLINE addContext #-} addContext = addContext . distributeF contextSize _ = 1 instance AddContext ([Name], Dom Type) where+ {-# INLINE addContext #-} addContext (xs, dom) = addContext (bindsToTel' id xs dom) contextSize (xs, _) = length xs instance AddContext (List1 Name, Dom Type) where+ {-# INLINE addContext #-} addContext (xs, dom) = addContext (bindsToTel'1 id xs dom) contextSize (xs, _) = length xs instance AddContext ([WithHiding Name], Dom Type) where+ {-# INLINE addContext #-} addContext ([] , dom) = id addContext (x : xs, dom) = addContext (x :| xs, dom) contextSize (xs, _) = length xs instance AddContext (List1 (WithHiding Name), Dom Type) where+ {-# INLINE addContext #-} addContext (WithHiding h x :| xs, dom) = addContext (x , mapHiding (mappend h) dom) . addContext (xs, raise 1 dom) contextSize (xs, _) = length xs instance AddContext ([Arg Name], Type) where- addContext (xs, t) = addContext ((map . fmap) unnamed xs :: [NamedArg Name], t)+ {-# INLINE addContext #-}+ addContext (xs, t) = addContext ((map' . fmap) unnamed xs :: [NamedArg Name], t) contextSize (xs, _) = length xs instance AddContext (List1 (Arg Name), Type) where+ {-# INLINE addContext #-} addContext (xs, t) = addContext ((fmap . fmap) unnamed xs :: List1 (NamedArg Name), t) contextSize (xs, _) = length xs instance AddContext ([NamedArg Name], Type) where+ {-# INLINE addContext #-} addContext ([], _) = id addContext (x : xs, t) = addContext (x :| xs, t) contextSize (xs, _) = length xs instance AddContext (List1 (NamedArg Name), Type) where+ {-# INLINE addContext #-} addContext (x :| xs, t) = addContext (namedArg x, t <$ domFromNamedArgName x) . addContext (xs, raise 1 t) contextSize (xs, _) = length xs +instance AddContext ([Dom Name], Type) where+ {-# INLINE addContext #-}+ addContext ([], _) = id+ addContext (x : xs, t) = addContext (x :| xs, t)+ contextSize (xs, _) = length xs++instance AddContext (List1 (Dom Name), Type) where+ {-# INLINE addContext #-}+ addContext (x :| xs, t) =+ addContext (unDom x, x $> t) .+ addContext (xs, raise 1 t)+ contextSize (xs, _) = length xs+ instance AddContext (String, Dom Type) where+ {-# INLINE addContext #-} addContext (s, dom) ret = withFreshName noRange s $ \x -> addCtx (setNotInScope x) dom ret contextSize _ = 1-{-# SPECIALIZE addContext :: (String, Dom Type) -> TCM a -> TCM a #-} instance AddContext (Text, Dom Type) where+ {-# INLINE addContext #-} addContext (s, dom) ret = addContext (T.unpack s, dom) ret contextSize _ = 1-{-# SPECIALIZE addContext :: (Text, Dom Type) -> TCM a -> TCM a #-} instance AddContext (KeepNames String, Dom Type) where+ {-# INLINE addContext #-} addContext (KeepNames s, dom) ret = withFreshName noRange s $ \ x -> addCtx x dom ret contextSize _ = 1-{-# SPECIALIZE addContext :: (KeepNames String, Dom Type) -> TCM a -> TCM a #-} instance AddContext (Dom Type) where+ {-# INLINE addContext #-} addContext dom = addContext ("_" :: String, dom) contextSize _ = 1 instance AddContext Name where+ {-# INLINE addContext #-} addContext x = addContext (x, __DUMMY_DOM__) contextSize _ = 1 instance {-# OVERLAPPING #-} AddContext String where+ {-# INLINE addContext #-} addContext s = addContext (s, __DUMMY_DOM__) contextSize _ = 1 instance AddContext (KeepNames Telescope) where+ {-# INLINE addContext #-} addContext (KeepNames tel) ret = loop tel where loop EmptyTel = ret loop (ExtendTel t tel) = underAbstraction' KeepNames t tel loop@@ -380,92 +533,141 @@ {-# SPECIALIZE addContext :: KeepNames Telescope -> TCM a -> TCM a #-} instance AddContext Telescope where+ {-# INLINE addContext #-} addContext tel ret = loop tel where loop EmptyTel = ret loop (ExtendTel t tel) = underAbstraction' id t tel loop contextSize = size {-# SPECIALIZE addContext :: Telescope -> TCM a -> TCM a #-} +{-# NOINLINE extendReduceEnv #-}+extendReduceEnv :: String -> Dom Type -> ReduceEnv -> ReduceEnv+extendReduceEnv x !a !env =+ let !tcs = redSt env+ (!nid, !tcs') = nextFresh tcs+ ~n = let x' = case x of "" -> "x"; _ -> x+ cn = C.Name noRange InScope (C.stringNameParts x')+ in Name nid cn cn noRange noFixity' False+ !re = redEnv env+ !ec = re ^. eContext+ !ec' = CxExtendVar n a ec+ !re' = re & eContext .~ ec'+ in env {redEnv = re', redSt = tcs'}++{-# INLINE underAbsReduceM #-}+-- | Go under an abstraction in 'ReduceM'. This performs the minimal adjustment to make 'reduce'+-- work, which is to extend the local 'Context' with a name and a type.+underAbsReduceM :: Dom Type -> Abs a -> (a -> ReduceM b) -> ReduceM b+underAbsReduceM a t k = ReduceM \env -> case t of+ Abs x t -> unReduceM (k t) $! extendReduceEnv x a env+ NoAbs _ t -> unReduceM (k t) env++{-# INLINE underAbsReduceM_ #-}+-- | Go under an abstraction in 'ReduceM' while adding a dummy type to the context.+underAbsReduceM_ :: Abs a -> (a -> ReduceM b) -> ReduceM b+underAbsReduceM_ = underAbsReduceM __DUMMY_DOM__+ -- | Go under an abstraction. Do not extend context in case of 'NoAbs'.-{-# SPECIALIZE underAbstraction :: Subst a => Dom Type -> Abs a -> (a -> TCM b) -> TCM b #-}+{-# INLINE underAbstraction #-} underAbstraction :: (Subst a, MonadAddContext m) => Dom Type -> Abs a -> (a -> m b) -> m b underAbstraction = underAbstraction' id +{-# INLINE underAbstraction' #-} underAbstraction' :: (Subst a, MonadAddContext m, AddContext (name, Dom Type)) => (String -> name) -> Dom Type -> Abs a -> (a -> m b) -> m b underAbstraction' _ _ (NoAbs _ v) k = k v underAbstraction' wrap t a k = underAbstractionAbs' wrap t a k +{-# INLINE underAbstractionAbs #-} -- | Go under an abstraction, treating 'NoAbs' as 'Abs'. underAbstractionAbs :: (Subst a, MonadAddContext m) => Dom Type -> Abs a -> (a -> m b) -> m b underAbstractionAbs = underAbstractionAbs' id +{-# INLINE underAbstractionAbs' #-} underAbstractionAbs' :: (Subst a, MonadAddContext m, AddContext (name, Dom Type)) => (String -> name) -> Dom Type -> Abs a -> (a -> m b) -> m b-underAbstractionAbs' wrap t a k = addContext (wrap $ realName $ absName a, t) $ k $ absBody a+underAbstractionAbs' wrap t a k =+ addContext (wrap $ realName $ absName a, t) $ k $ absBody a where realName s = if isNoName s then "x" else argNameToString s -- | Go under an abstract without worrying about the type to add to the context.-{-# SPECIALIZE underAbstraction_ :: Subst a => Abs a -> (a -> TCM b) -> TCM b #-}+{-# INLINE underAbstraction_ #-} underAbstraction_ :: (Subst a, MonadAddContext m) => Abs a -> (a -> m b) -> m b underAbstraction_ = underAbstraction __DUMMY_DOM__ +{-# INLINE mapAbstraction #-} -- | Map a monadic function on the thing under the abstraction, adding -- the abstracted variable to the context. mapAbstraction- :: (Subst a, Subst b, MonadAddContext m)+ :: (Subst a, MonadAddContext m) => Dom Type -> (a -> m b) -> Abs a -> m (Abs b) mapAbstraction dom f x = (x $>) <$> underAbstraction dom x f mapAbstraction_- :: (Subst a, Subst b, MonadAddContext m)+ :: (Subst a, MonadAddContext m) => (a -> m b) -> Abs a -> m (Abs b) mapAbstraction_ = mapAbstraction __DUMMY_DOM__ {-# SPECIALIZE getLetBindings :: TCM [(Name, LetBinding)] #-} getLetBindings :: MonadTCEnv tcm => tcm [(Name, LetBinding)] getLetBindings = do- bs <- asksTC envLetBindings+ bs <- viewTC eLetBindings forM (Map.toList bs) $ \ (n, o) -> (,) n <$> getOpen o --- | Add a let bound variable-{-# SPECIALIZE defaultAddLetBinding' :: Origin -> Name -> Term -> Dom Type -> TCM a -> TCM a #-}-defaultAddLetBinding' :: (ReadTCState m, MonadTCEnv m) => Origin -> Name -> Term -> Dom Type -> m a -> m a-defaultAddLetBinding' o x v t ret = do- vt <- makeOpen $ LetBinding o v t- flip localTC ret $ \e -> e { envLetBindings = Map.insert x vt $ envLetBindings e }+-- | Add a let bound variable.+{-# INLINE defaultAddLetBinding' #-}+defaultAddLetBinding' :: (ReadTCState m, MonadTCEnv m)+ => IsAxiom -- ^ Does this let binding come from a 'LetAxiom'?+ -> Origin -> Name -> Term -> Dom Type -> m a -> m a+defaultAddLetBinding' isAxiom o x v t ret = do+ vt <- makeOpen $ LetBinding isAxiom o v t+ localTC (over eLetBindings (Map.insert x vt)) ret --- | Add a let bound variable-{-# SPECIALIZE addLetBinding :: ArgInfo -> Origin -> Name -> Term -> Type -> TCM a -> TCM a #-}-addLetBinding :: MonadAddContext m => ArgInfo -> Origin -> Name -> Term -> Type -> m a -> m a-addLetBinding info o x v t0 ret = addLetBinding' o x v (defaultArgDom info t0) ret+unsafeRule :: (MonadWarning m) => RewriteSource -> IllegalRewriteRuleReason -> MaybeT m ()+unsafeRule s reason = lift $ warning $ IllegalRewriteRule (defName <$> s) reason +illegalRule :: (MonadWarning m) => RewriteSource -> IllegalRewriteRuleReason -> MaybeT m a+illegalRule s reason = do+ unsafeRule s reason+ mzero -{-# SPECIALIZE removeLetBinding :: Name -> TCM a -> TCM a #-}+-- | Add a let bound variable.+{-# INLINE addLetBinding #-}+addLetBinding :: (MonadWarning m) => ArgInfo -> Origin -> Name -> Term -> Type -> m a -> m a+addLetBinding info o x v t0 =+ addLetBinding' NoAxiom o x v (defaultArgDom info t0)++-- | Add a let bound variable without a definition.+{-# INLINE addLetAxiom #-}+addLetAxiom :: (MonadWarning m) => ArgInfo -> Origin -> Name -> Term -> Type -> m a -> m a+addLetAxiom info o x v t0 ret =+ addLetBinding' YesAxiom o x v (defaultArgDom info t0) ret++{-# INLINE removeLetBinding #-} -- | Remove a let bound variable. removeLetBinding :: MonadTCEnv m => Name -> m a -> m a-removeLetBinding x = localTC $ \ e -> e { envLetBindings = Map.delete x (envLetBindings e) }+removeLetBinding x = localTC (over eLetBindings (Map.delete x)) -{-# SPECIALIZE removeLetBindingsFrom :: Name -> TCM a -> TCM a #-}+{-# INLINE removeLetBindingsFrom #-} -- | Remove a let bound variable and all let bindings introduced after it. For instance before -- printing its body to avoid folding the binding itself, or using bindings defined later. -- Relies on the invariant that names introduced later are sorted after earlier names. removeLetBindingsFrom :: MonadTCEnv m => Name -> m a -> m a-removeLetBindingsFrom x = localTC $ \ e -> e { envLetBindings = fst $ Map.split x (envLetBindings e) }+removeLetBindingsFrom x = localTC (over eLetBindings (fst . Map.split x)) -- * Querying the context -- | Get the current context. {-# SPECIALIZE getContext :: TCM Context #-} getContext :: MonadTCEnv m => m Context-getContext = asksTC envContext+getContext = viewTC eContext -- | Get the size of the current context. {-# SPECIALIZE getContextSize :: TCM Nat #-} getContextSize :: (MonadTCEnv m) => m Nat-getContextSize = length <$> getContext+getContextSize = size <$> getContext {-# SPECIALIZE getContextVars :: TCM [(Int, Dom Name)] #-} getContextVars :: (MonadTCEnv m) => m [(Int, Dom Name)]@@ -479,7 +681,7 @@ contextVars = reverse . contextVars' contextVars' :: Context -> [(Int, Dom Name)]-contextVars' = zipWith mkVar [0..]+contextVars' = cxWithIndex mkVar where mkVar i (CtxVar x a) = (i, a $> x) @@ -489,15 +691,15 @@ getContextArgs = contextArgs <$> getContext contextArgs :: Context -> Args-contextArgs = map (\(i,x) -> var i <$ argFromDom x) . contextVars+contextArgs = map' (\(i,x) -> var i <$ argFromDom x) . contextVars -- | Generate @[var (n - 1), ..., var 0]@ for all declarations in the context. {-# SPECIALIZE getContextTerms :: TCM [Term] #-} getContextTerms :: (MonadTCEnv m) => m [Term]-getContextTerms = map unArg <$> getContextArgs+getContextTerms = map' unArg <$> getContextArgs contextTerms :: Context -> [Term]-contextTerms = map unArg . contextArgs+contextTerms = map' unArg . contextArgs -- | Get the current context as a 'Telescope'. {-# SPECIALIZE getContextTelescope :: TCM Telescope #-}@@ -505,10 +707,11 @@ getContextTelescope = contextToTel <$> getContext contextToTel :: Context -> Telescope-contextToTel = go . reverse+contextToTel = go EmptyTel where- go [] = EmptyTel- go (CtxVar x a : ctx) = ExtendTel a $ Abs (nameToArgName x) (go ctx)+ go !tel CxEmpty = tel+ go tel (CxExtendVar x a ctx) = let !x' = nameToArgName x+ in go (ExtendTel a (Abs x' tel)) ctx -- | Get the names of all declarations in the context. {-# SPECIALIZE getContextNames :: TCM [Name] #-}@@ -520,15 +723,15 @@ getContextNames' = contextNames' <$> getContext contextNames :: Context -> [Name]-contextNames = map (unDom . snd) . contextVars+contextNames = map' (unDom . snd) . contextVars contextNames' :: Context -> [Name]-contextNames' = map (unDom . snd) . contextVars'+contextNames' = map' (unDom . snd) . contextVars' -- | get type of bound variable (i.e. deBruijn index) -- lookupBV_ :: Nat -> Context -> Maybe ContextEntry-lookupBV_ n ctx = raise (n + 1) <$> ctx !!! n+lookupBV_ n ctx = raise (n + 1) <$> cxLookup n ctx {-# SPECIALIZE lookupBV' :: Nat -> TCM (Maybe ContextEntry) #-} lookupBV' :: MonadTCEnv m => Nat -> m (Maybe ContextEntry)@@ -541,7 +744,7 @@ ctx <- getContext __IMPOSSIBLE_VERBOSE__ $ unwords [ "de Bruijn index out of scope:", show n- , "in context", prettyShow $ map ctxEntryName ctx+ , "in context", prettyShow $ map' ctxEntryName $ cxEntries ctx ] caseMaybeM (lookupBV' n) failure return @@ -574,10 +777,10 @@ -- variable the deBruijn index is returned and if it is a let bound variable -- its definition is returned. {-# SPECIALIZE getVarInfo :: Name -> TCM (Term, Dom Type) #-}-getVarInfo :: (MonadDebug m, MonadTCEnv m) => Name -> m (Term, Dom Type)+getVarInfo :: (MonadDebug m, MonadFail m, MonadTCEnv m) => Name -> m (Term, Dom Type) getVarInfo x = do ctx <- getContextVars'- def <- asksTC envLetBindings+ def <- viewTC eLetBindings case List.findIndex ((== x) . unDom . snd) ctx of Just n -> do t <- domOfBV n@@ -585,10 +788,41 @@ _ -> case Map.lookup x def of Just vt -> do- LetBinding _ v t <- getOpen vt+ LetBinding _isAxiom _origin v t <- getOpen vt return (v, t)- _ -> __IMPOSSIBLE_VERBOSE__ $ unwords+ _ -> fail $ unwords [ "unbound variable" , prettyShow $ nameConcrete x , "(id: " ++ prettyShow (nameId x) ++ ")" ]+ -- Andreas, 2026-01-20, issue #8325+ -- This 'fail' is apparently not impossible;+ -- it is apparently caught during a "refine".+ -- TODO: It would be worthwhile investigating who wants to access+ -- an out-of-scope variable.++-- | Change to a dummy context large enough for the given thing to be+-- well-scoped+-- (Very hacky, should only be used if there is no alternative)+inLargeEnoughContext :: (ReadTCState m, MonadAddContext m, Free a)+ => a -> m b -> m b+inLargeEnoughContext t c = do+ let len = 1 + foldl' max 0 (freeVarList t)+ let dummies = replicate len __DUMMY_DOM__+ -- We disable rewrite rules to avoid erroneously applying rewrite rules+ -- which refer to module parameters (see "RewriteRulePiSort.agda")+ -- This is conservative, but conservativity is reasonable here: worst-case+ -- scenario, we treat a pi type as level-dependent (and put it in Setω),+ -- when we technically could have pruned the dependency by applying a+ -- rewrite rule.+ locallyTCState stRewriteRules (const $ empty) $ inTopContext $+ addContext dummies c++-- | Run the continuation on the old codomain sort, in an appropriate context+codomainSortOldM :: (ReadTCState m, MonadAddContext m) =>+ Dom Type -> Sort -> BlockedDepCheck Sort -> (Sort -> m a) -> m a+codomainSortOldM dom s2 CodomainSortSame c = do+ addContext dom $ c s2+codomainSortOldM dom s2 (CodomainSortOld s2Old) c = do+ inLargeEnoughContext s2Old $ c s2Old+
src/full/Agda/TypeChecking/Monad/Context.hs-boot view
@@ -16,7 +16,8 @@ class MonadTCEnv m => MonadAddContext m where addCtx :: Name -> Dom Type -> m a -> m a- addLetBinding' :: Origin -> Name -> Term -> Dom Type -> m a -> m a+ addLetBinding' :: IsAxiom -> Origin -> Name -> Term -> Dom Type -> m a -> m a+ addLocalRewrite :: RewriteRule -> m a -> m a updateContext :: Substitution -> (Context -> Context) -> m a -> m a withFreshName :: Range -> ArgName -> (Name -> m a) -> m a @@ -27,8 +28,13 @@ default addLetBinding' :: (MonadAddContext n, MonadTransControl t, t n ~ m)- => Origin -> Name -> Term -> Dom Type -> m a -> m a+ => IsAxiom -> Origin -> Name -> Term -> Dom Type -> m a -> m a addLetBinding' o x u a = liftThrough $ addLetBinding' o x u a++ default addLocalRewrite+ :: (MonadAddContext n, MonadTransControl t, t n ~ m)+ => RewriteRule -> m a -> m a+ addLocalRewrite r = liftThrough $ addLocalRewrite r default updateContext :: (MonadAddContext n, MonadTransControl t, t n ~ m)
src/full/Agda/TypeChecking/Monad/Debug.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-}+ module Agda.TypeChecking.Monad.Debug ( module Agda.TypeChecking.Monad.Debug , Verbosity, VerboseKey, VerboseLevel@@ -24,6 +26,7 @@ import {-# SOURCE #-} Agda.TypeChecking.Errors import Agda.TypeChecking.Monad.Base+-- import Agda.TypeChecking.Monad.State ( appInteractionOutputCallback ) -- import cycle import Agda.Interaction.Options import Agda.Interaction.Response.Base (Response_boot(..))@@ -36,16 +39,20 @@ import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Monad import Agda.Syntax.Common.Pretty-import Agda.Utils.ProfileOptions+import Agda.Interaction.Options.ProfileOptions import Agda.Utils.Update import qualified Agda.Utils.Trie as Trie+import Agda.Utils.StrictReader qualified as Strict+import Agda.Utils.StrictWriter qualified as Strict+import Agda.Utils.StrictState qualified as Strict import Agda.Utils.Impossible+import Agda.Utils.DocTree (renderToTree) class (Functor m, Applicative m, Monad m) => MonadDebug m where - formatDebugMessage :: VerboseKey -> VerboseLevel -> TCM Doc -> m String- traceDebugMessage :: VerboseKey -> VerboseLevel -> String -> m a -> m a+ formatDebugMessage :: VerboseKey -> VerboseLevel -> TCM Doc -> m Doc+ traceDebugMessage :: VerboseKey -> VerboseLevel -> Doc -> m a -> m a -- | Print brackets around debug messages issued by a computation. verboseBracket :: VerboseKey -> VerboseLevel -> String -> m a -> m a@@ -61,14 +68,16 @@ -- default implementation of transformed debug monad + {-# INLINE formatDebugMessage #-} default formatDebugMessage :: (MonadTrans t, MonadDebug n, m ~ t n)- => VerboseKey -> VerboseLevel -> TCM Doc -> m String+ => VerboseKey -> VerboseLevel -> TCM Doc -> m Doc formatDebugMessage k n d = lift $ formatDebugMessage k n d + {-# INLINE traceDebugMessage #-} default traceDebugMessage :: (MonadTransControl t, MonadDebug n, m ~ t n)- => VerboseKey -> VerboseLevel -> String -> m a -> m a+ => VerboseKey -> VerboseLevel -> Doc -> m a -> m a traceDebugMessage k n s = liftThrough $ traceDebugMessage k n s #ifdef DEBUG@@ -76,6 +85,7 @@ :: (MonadTransControl t, MonadDebug n, m ~ t n) => VerboseKey -> VerboseLevel -> String -> m a -> m a verboseBracket k n s = liftThrough $ verboseBracket k n s+ {-# INLINE verboseBracket #-} #else default verboseBracket :: (MonadTransControl t, MonadDebug n, m ~ t n)@@ -88,21 +98,25 @@ :: (MonadTrans t, MonadDebug n, m ~ t n) => m Verbosity getVerbosity = lift getVerbosity+ {-# INLINE getVerbosity #-} default getProfileOptions :: (MonadTrans t, MonadDebug n, m ~ t n) => m ProfileOptions getProfileOptions = lift getProfileOptions+ {-# INLINE getProfileOptions #-} default isDebugPrinting :: (MonadTrans t, MonadDebug n, m ~ t n) => m Bool isDebugPrinting = lift isDebugPrinting+ {-# INLINE isDebugPrinting #-} default nowDebugPrinting :: (MonadTransControl t, MonadDebug n, m ~ t n) => m a -> m a nowDebugPrinting = liftThrough nowDebugPrinting+ {-# INLINE nowDebugPrinting #-} -- Default implementations (working around the restriction to only -- have one default signature).@@ -114,21 +128,22 @@ defaultGetProfileOptions = optProfiling <$> pragmaOptions defaultIsDebugPrinting :: MonadTCEnv m => m Bool-defaultIsDebugPrinting = asksTC envIsDebugPrinting+defaultIsDebugPrinting = viewTC eIsDebugPrinting defaultNowDebugPrinting :: MonadTCEnv m => m a -> m a defaultNowDebugPrinting = locallyTC eIsDebugPrinting $ const True -- | Print a debug message if switched on.-displayDebugMessage :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m ()+displayDebugMessage :: MonadDebug m => VerboseKey -> VerboseLevel -> Doc -> m () displayDebugMessage k n s = traceDebugMessage k n s $ return () -- | During printing, catch internal errors of kind 'Impossible' and print them. catchAndPrintImpossible :: (CatchImpossible m, Monad m)- => VerboseKey -> VerboseLevel -> m String -> m String+ => VerboseKey -> VerboseLevel -> m DocTree -> m DocTree+{-# SPECIALIZE catchAndPrintImpossible :: VerboseKey -> VerboseLevel -> TCM DocTree -> TCM DocTree #-} catchAndPrintImpossible k n m = catchImpossibleJust catchMe m $ \ imposs -> do- return $ render $ vcat+ return $ renderToTree $ vcat [ text $ "Debug printing " ++ k ++ ":" ++ show n ++ " failed due to exception:" , vcat $ map (nest 2 . text) $ lines $ show imposs ]@@ -140,19 +155,22 @@ Unreachable{} -> False ImpMissingDefinitions{} -> False -instance MonadDebug TCM where-- traceDebugMessage k n s cont = do- -- Andreas, 2019-08-20, issue #4016:- -- 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+traceDebugMessageTCM :: VerboseKey -> VerboseLevel -> Doc -> TCM a -> TCM a+traceDebugMessageTCM k n doc cont = do+ -- Andreas, 2025-07-30, PR #8040:+ -- Forcing the @doc@ introduces a massive space leak,+ -- so for now we switch off the fix of #4016 which is just devx.+ -- This means that attempts to debug-print __IMPOSSIBLE__s will result in internal errors again. -- Andreas, 2022-06-15, prefix with time stamp if `-v debug.time:100`:- msg <- ifNotM (hasVerbosity "debug.time" 100) {-then-} (return s) {-else-} $ do+ doc <- ifNotM (hasVerbosity "debug.time" 100) {-then-} (pure doc) {-else-} $ do now <- liftIO $ trailingZeros . iso8601Show <$> liftA2 utcToLocalTime getCurrentTimeZone getCurrentTime- return $ concat [ now, ": ", s ]+ pure $ (text now <> ":") <+> doc + -- Andreas, 2019-08-20, issue #4016:+ -- Force any lazy 'Impossible' exceptions to the surface and handle them.+ msg :: DocTree <- liftIO . catchAndPrintImpossible k n . E.evaluate . DeepSeq.force . renderToTree $ doc+ cb <- useSession lensInteractionOutputCallback cb $ Resp_RunningInfo n msg cont where@@ -161,30 +179,28 @@ -- So we need to do the padding ourselves. -- yyyy-mm-ddThh:mm:ss.ssssss -- 12345678901234567890123456- trailingZeros = take 26 . (++ repeat '0')+ trailingZeros = takeExactly '0' 26 - formatDebugMessage k n d = catchAndPrintImpossible k n $ do- render <$> d `catchError` \ err -> do- renderError err <&> \ s -> vcat- [ sep $ map text- [ "Printing debug message"- , k ++ ":" ++ show n- , "failed due to error:"- ]- , nest 2 $ text s- ]+formatDebugMessageTCM :: VerboseKey -> VerboseLevel -> TCM Doc -> TCM Doc+formatDebugMessageTCM _ _ = id +verboseBracketTCM :: VerboseKey -> VerboseLevel -> String -> TCM a -> TCM a #ifdef DEBUG- verboseBracket k n s = applyWhenVerboseS k n $ \ m -> do+verboseBracketTCM k n s =+ applyWhenVerboseS k n $ \ m -> do openVerboseBracket k n s (m <* closeVerboseBracket k n) `catchError` \ e -> do closeVerboseBracketException k n throwError e #else- verboseBracket k n s ma = ma- {-# INLINE verboseBracket #-}+verboseBracketTCM _ _ _ = id+{-# INLINE verboseBracketTCM #-} #endif +instance MonadDebug TCM where+ traceDebugMessage = traceDebugMessageTCM+ formatDebugMessage= formatDebugMessageTCM+ verboseBracket = verboseBracketTCM getVerbosity = defaultGetVerbosity getProfileOptions = defaultGetProfileOptions isDebugPrinting = defaultIsDebugPrinting@@ -199,6 +215,9 @@ instance MonadDebug m => MonadDebug (ReaderT r m) instance MonadDebug m => MonadDebug (StateT s m) instance (MonadDebug m, Monoid w) => MonadDebug (WriterT w m)+instance MonadDebug m => MonadDebug (Strict.ReaderT r m)+instance MonadDebug m => MonadDebug (Strict.StateT s m)+instance (MonadDebug m, Monoid w) => MonadDebug (Strict.WriterT w m) instance MonadDebug m => MonadDebug (IdentityT m) -- We are lacking MonadTransControl ListT@@ -226,81 +245,77 @@ instance ReportS [TCM Doc] where reportS k n = reportSDoc k n . fmap vcat . sequence instance ReportS [String] where reportS k n = reportSLn k n . unlines-instance ReportS [Doc] where reportS k n = reportSLn k n . render . vcat-instance ReportS Doc where reportS k n = reportSLn k n . render+instance ReportS [Doc] where reportS k n = reportSDoc k n . pure . vcat+instance ReportS Doc where reportS k n = reportSDoc k n . pure -#ifdef DEBUG+-- | Conditionally println debug string. Works regardless of the debug flag.+{-# SPECIALIZE alwaysReportSLn :: VerboseKey -> VerboseLevel -> String -> TCM () #-}+alwaysReportSLn :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m ()+alwaysReportSLn k n s = alwaysTraceSLn k n s (pure ()) +-- | Conditionally render debug 'Doc' and print it. Works regardless of the debug flag.+{-# SPECIALIZE alwaysReportSDoc :: VerboseKey -> VerboseLevel -> TCM Doc -> TCM () #-}+alwaysReportSDoc :: MonadDebug m => VerboseKey -> VerboseLevel -> TCM Doc -> m ()+alwaysReportSDoc k n d = alwaysTraceSDoc k n d (pure ())+ -- | Conditionally println debug string.-{-# SPECIALIZE reportSLn :: VerboseKey -> VerboseLevel -> String -> TCM () #-}+-- reportSLn :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m ()-reportSLn k n s = verboseS k n $ displayDebugMessage k n $ s ++ "\n"-+#ifdef DEBUG+reportSLn = alwaysReportSLn #else--{-# INLINE reportSLn #-}-reportSLn :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m () reportSLn _ _ _ = pure ()- #endif---- | Conditionally println debug string. Works regardless of the debug flag.-{-# SPECIALIZE reportSLn :: VerboseKey -> VerboseLevel -> String -> TCM () #-}-alwaysReportSLn :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m ()-alwaysReportSLn k n s = verboseS k n $ displayDebugMessage k n $ s ++ "\n"+{-# INLINE reportSLn #-} +-- | Conditionally render debug 'Doc' and print it.+--+reportSDoc :: MonadDebug m => VerboseKey -> VerboseLevel -> TCM Doc -> m ()+#ifdef DEBUG+reportSDoc = alwaysReportSDoc+#else+reportSDoc _ _ _ = pure ()+#endif+{-# INLINE reportSDoc #-} +-- | Raise internal error with extra information. __IMPOSSIBLE_VERBOSE__ :: (HasCallStack, MonadDebug m) => String -> m a __IMPOSSIBLE_VERBOSE__ s = do -- Andreas, 2023-07-19, issue #6728 is fixed by manually inlining reportSLn here. -- reportSLn "impossible" 10 s -- It seems like GHC 9.6 optimization does otherwise something that throws -- away the debug message.- let k = "impossible"- let n = 10- verboseS k n $ displayDebugMessage k n $ s ++ "\n"-- throwImpossible err+ -- let k = "impossible"+ -- let n = 10+ -- verboseS k n $ displayDebugMessage k n $ text s+ -- throwImpossible err+ -- Andreas, 2025-08-01: Does it work with traceSLn?+ traceSLn "impossible" 10 s $ throwImpossible err where -- Create the "Impossible" error using *our* caller as the call site. err = withCallerCallStack Impossible -#ifdef DEBUG---- | Conditionally render debug 'Doc' and print it.-{-# SPECIALIZE reportSDoc :: VerboseKey -> VerboseLevel -> TCM Doc -> TCM () #-}-reportSDoc :: MonadDebug m => VerboseKey -> VerboseLevel -> TCM Doc -> m ()-reportSDoc k n d = verboseS k n $ do- displayDebugMessage k n . (++ "\n") =<< formatDebugMessage k n (locallyTC eIsDebugPrinting (const True) d)- -- | Debug print the result of a computation.+-- reportResult :: MonadDebug m => VerboseKey -> VerboseLevel -> (a -> TCM Doc) -> m a -> m a+#ifdef DEBUG reportResult k n debug action = do x <- action x <$ reportSDoc k n (debug x)- #else---- | Conditionally render debug 'Doc' and print it.-{-# INLINE reportSDoc #-}-reportSDoc :: MonadDebug m => VerboseKey -> VerboseLevel -> TCM Doc -> m ()-reportSDoc _ _ _ = pure ()---- | Debug print the result of a computation.+reportResult _ _ _ = id {-# INLINE reportResult #-}-reportResult :: MonadDebug m => VerboseKey -> VerboseLevel -> (a -> TCM Doc) -> m a -> m a-reportResult _ _ _ action = action- #endif --- | Conditionally render debug 'Doc' and print it. Works regardless of the debug flag.-{-# SPECIALIZE reportSDoc :: VerboseKey -> VerboseLevel -> TCM Doc -> TCM () #-}-alwaysReportSDoc :: MonadDebug m => VerboseKey -> VerboseLevel -> TCM Doc -> m ()-alwaysReportSDoc k n d = verboseS k n $ do- displayDebugMessage k n . (++ "\n") =<< formatDebugMessage k n (locallyTC eIsDebugPrinting (const True) d)-+#ifdef DEBUG unlessDebugPrinting :: MonadDebug m => m () -> m () unlessDebugPrinting = unlessM isDebugPrinting+{-# INLINE unlessDebugPrinting #-}+#else+unlessDebugPrinting :: MonadDebug m => m () -> m ()+unlessDebugPrinting _ = pure ()+{-# INLINE unlessDebugPrinting #-}+#endif -- | Debug print some lines if the verbosity level for the given -- 'VerboseKey' is at least 'VerboseLevel'.@@ -320,43 +335,48 @@ instance TraceS [TCM Doc] where traceS k n = traceSDoc k n . fmap vcat . sequence instance TraceS [String] where traceS k n = traceSLn k n . unlines-instance TraceS [Doc] where traceS k n = traceSLn k n . render . vcat-instance TraceS Doc where traceS k n = traceSLn k n . render+instance TraceS [Doc] where traceS k n = traceSDoc k n . pure . vcat+instance TraceS Doc where traceS k n = traceSDoc k n . pure +-- | Conditionally debug print 'String', and then continue. Works regardless of the debug flag.+alwaysTraceSLn :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m a -> m a+alwaysTraceSLn k n s = applyWhenVerboseS k n $ traceDebugMessage k n $ text s -#ifdef DEBUG+-- | Conditionally render debug 'Doc', print it, and then continue. Works regardless of the debug flag.+alwaysTraceSDoc :: MonadDebug m => VerboseKey -> VerboseLevel -> TCM Doc -> m a -> m a+alwaysTraceSDoc k n d = applyWhenVerboseS k n $ \cont -> do+ doc <- formatDebugMessage k n $ locallyTC eIsDebugPrinting (const True) d+ traceDebugMessage k n doc cont +-- | Conditionally debug print 'String', and then continue. Works regardless of the debug flag.+-- traceSLn :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m a -> m a-traceSLn k n s = applyWhenVerboseS k n $ traceDebugMessage k n $ s ++ "\n"---- | Conditionally render debug 'Doc', print it, and then continue.-traceSDoc :: MonadDebug m => VerboseKey -> VerboseLevel -> TCM Doc -> m a -> m a-traceSDoc k n d = applyWhenVerboseS k n $ \cont -> do- s <- formatDebugMessage k n $ locallyTC eIsDebugPrinting (const True) d- traceDebugMessage k n (s ++ "\n") cont-+#ifdef DEBUG+traceSLn = alwaysTraceSLn #else-+traceSLn _ _ _ = id+#endif {-# INLINE traceSLn #-}-traceSLn :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m a -> m a-traceSLn _ _ _ action = action -- | Conditionally render debug 'Doc', print it, and then continue.-{-# INLINE traceSDoc #-}+-- traceSDoc :: MonadDebug m => VerboseKey -> VerboseLevel -> TCM Doc -> m a -> m a-traceSDoc _ _ _ action = action-+#ifdef DEBUG+traceSDoc = alwaysTraceSDoc+#else+traceSDoc _ _ _ = id #endif+{-# INLINE traceSDoc #-} openVerboseBracket :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m ()-openVerboseBracket k n s = displayDebugMessage k n $ "{ " ++ s ++ "\n"+openVerboseBracket k n s = displayDebugMessage k n $ "{" <+> text s closeVerboseBracket :: MonadDebug m => VerboseKey -> VerboseLevel -> m ()-closeVerboseBracket k n = displayDebugMessage k n "}\n"+closeVerboseBracket k n = displayDebugMessage k n "}" closeVerboseBracketException :: MonadDebug m => VerboseKey -> VerboseLevel -> m ()-closeVerboseBracketException k n = displayDebugMessage k n "} (exception)\n"+closeVerboseBracketException k n = displayDebugMessage k n "} (exception)" ------------------------------------------------------------------------@@ -369,40 +389,30 @@ -- reportSLn -- reportSDoc +-- | Get the verbosity level for a given key.+getVerbosityLevel :: MonadDebug m => VerboseKey -> m VerboseLevel+getVerbosityLevel k = do+ t <- getVerbosity+ return $ case t of+ Strict.Nothing -> 1+ Strict.Just t+ -- This code is not executed if no debug flags have been given.+ | t == Trie.singleton [] 0 -> 0 -- A special case for "-v0".+ | otherwise -> lastWithDefault 0 $ Trie.lookupPath ks t+ where ks = parseVerboseKey k+ -- | 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 = 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+hasVerbosity k n = (n <=) <$> getVerbosityLevel k -- | 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 = 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+hasExactVerbosity k n = (n ==) <$> getVerbosityLevel k -- | Run a computation if a certain verbosity level is activated (exact match). @@ -410,7 +420,7 @@ whenExactVerbosity :: MonadDebug m => VerboseKey -> VerboseLevel -> m () -> m () whenExactVerbosity k n = whenM $ hasExactVerbosity k n -__CRASH_WHEN__ :: (HasCallStack, MonadTCM m, MonadDebug m) => VerboseKey -> VerboseLevel -> m ()+__CRASH_WHEN__ :: (HasCallStack, MonadDebug m) => VerboseKey -> VerboseLevel -> m () __CRASH_WHEN__ k n = whenExactVerbosity k n (throwImpossible err) where -- Create the "Unreachable" error using *our* caller as the call site.
src/full/Agda/TypeChecking/Monad/Env.hs view
@@ -19,17 +19,17 @@ {-# SPECIALIZE currentModule :: TCM ModuleName #-} {-# SPECIALIZE currentModule :: ReduceM ModuleName #-} currentModule :: MonadTCEnv m => m ModuleName-currentModule = asksTC envCurrentModule+currentModule = viewTC eCurrentModule +{-# INLINE withCurrentModule #-} -- | Set the name of the current module. withCurrentModule :: (MonadTCEnv m) => ModuleName -> m a -> m a-withCurrentModule m =- localTC $ \ e -> e { envCurrentModule = m }+withCurrentModule m = localTC $ set eCurrentModule m -- | Get the path of the currently checked file getCurrentPath :: (MonadTCEnv m, MonadFileId m) => m AbsolutePath getCurrentPath = do- i <- fromMaybe __IMPOSSIBLE__ <$> asksTC envCurrentPath+ i <- fromMaybe __IMPOSSIBLE__ <$> viewTC eCurrentPath fileFromId i -- | Get the number of variables bound by anonymous modules.@@ -37,86 +37,97 @@ {-# SPECIALIZE getAnonymousVariables :: ModuleName -> ReduceM Nat #-} getAnonymousVariables :: MonadTCEnv m => ModuleName -> m Nat getAnonymousVariables m = do- ms <- asksTC envAnonymousModules+ ms <- viewTC eAnonymousModules return $ sum [ n | (m', n) <- ms, mnameToList m' `List.isPrefixOf` mnameToList m ] +{-# INLINE withAnonymousModule #-} -- | Add variables bound by an anonymous module. withAnonymousModule :: ModuleName -> Nat -> TCM a -> TCM a withAnonymousModule m n =- localTC $ \ e -> e { envAnonymousModules = (m, n) : envAnonymousModules e }+ localTC $ over eAnonymousModules \ms -> (m, n) : ms +{-# INLINE withEnv #-} -- | Set the current environment to the given withEnv :: MonadTCEnv m => TCEnv -> m a -> m a-withEnv env = localTC $ \ env0 -> env+withEnv env = localTC \env0 -> -- Keep persistent settings- { envPrintMetasBare = envPrintMetasBare env0- }+ env & ePrintMetasBare .~ (env0 ^. ePrintMetasBare) -- | Get the current environment getEnv :: TCM TCEnv getEnv = askTC +{-# INLINE withHighlightingLevel #-} -- | Set highlighting level withHighlightingLevel :: HighlightingLevel -> TCM a -> TCM a-withHighlightingLevel h = localTC $ \ e -> e { envHighlightingLevel = h }+withHighlightingLevel h = localTC $ set eHighlightingLevel h +{-# INLINE doExpandLast #-} -- | Restore setting for 'ExpandLast' to default. doExpandLast :: TCM a -> TCM a-doExpandLast = localTC $ \ e -> e { envExpandLast = setExpand (envExpandLast e) }- where+doExpandLast = localTC $ over eExpandLast setExpand where setExpand ReallyDontExpandLast = ReallyDontExpandLast setExpand _ = ExpandLast +{-# INLINE dontExpandLast #-} dontExpandLast :: TCM a -> TCM a-dontExpandLast = localTC $ \ e -> e { envExpandLast = DontExpandLast }+dontExpandLast = localTC $ set eExpandLast DontExpandLast +{-# INLINE reallyDontExpandLast #-} reallyDontExpandLast :: TCM a -> TCM a-reallyDontExpandLast = localTC $ \ e -> e { envExpandLast = ReallyDontExpandLast }+reallyDontExpandLast = localTC $ set eExpandLast ReallyDontExpandLast -- | If the reduced did a proper match (constructor or literal pattern), -- then record this as simplification step.-{-# SPECIALIZE performedSimplification :: TCM a -> TCM a #-}+{-# INLINE performedSimplification #-} performedSimplification :: MonadTCEnv m => m a -> m a-performedSimplification = localTC $ \ e -> e { envSimplification = YesSimplification }+performedSimplification = localTC $ set eSimplification YesSimplification -{-# SPECIALIZE performedSimplification' :: Simplification -> TCM a -> TCM a #-}+{-# INLINE performedSimplification' #-} performedSimplification' :: MonadTCEnv m => Simplification -> m a -> m a-performedSimplification' simpl = localTC $ \ e -> e { envSimplification = simpl `mappend` envSimplification e }+performedSimplification' simpl = localTC $ over' eSimplification (simpl <>) getSimplification :: MonadTCEnv m => m Simplification-getSimplification = asksTC envSimplification+getSimplification = viewTC eSimplification -- * Controlling reduction. -- | Lens for 'AllowedReductions'. updateAllowedReductions :: (AllowedReductions -> AllowedReductions) -> TCEnv -> TCEnv-updateAllowedReductions f e = e { envAllowedReductions = f (envAllowedReductions e) }+updateAllowedReductions = over eAllowedReductions +{-# INLINE modifyAllowedReductions #-} modifyAllowedReductions :: MonadTCEnv m => (AllowedReductions -> AllowedReductions) -> m a -> m a modifyAllowedReductions = localTC . updateAllowedReductions +{-# INLINE putAllowedReductions #-} putAllowedReductions :: MonadTCEnv m => AllowedReductions -> m a -> m a putAllowedReductions = modifyAllowedReductions . const +{-# INLINE onlyReduceProjections #-} -- | Reduce @Def f vs@ only if @f@ is a projection. onlyReduceProjections :: MonadTCEnv m => m a -> m a onlyReduceProjections = modifyAllowedReductions $ SmallSet.intersection $ SmallSet.singleton ProjectionReductions +{-# INLINE allowAllReductions #-} -- | Allow all reductions except for non-terminating functions (default). allowAllReductions :: MonadTCEnv m => m a -> m a allowAllReductions = putAllowedReductions allReductions +{-# INLINE allowNonTerminatingReductions #-} -- | Allow all reductions including non-terminating functions. allowNonTerminatingReductions :: MonadTCEnv m => m a -> m a allowNonTerminatingReductions = putAllowedReductions reallyAllReductions +{-# INLINE onlyReduceTypes #-} -- | Allow all reductions when reducing types. Otherwise only allow -- inlined functions to be unfolded. onlyReduceTypes :: MonadTCEnv m => m a -> m a onlyReduceTypes = modifyAllowedReductions $ SmallSet.intersection $ SmallSet.fromList [TypeLevelReductions, InlineReductions] +{-# INLINE typeLevelReductions #-} -- | Update allowed reductions when working on types typeLevelReductions :: MonadTCEnv m => m a -> m a typeLevelReductions = modifyAllowedReductions $ \reds -> if@@ -128,18 +139,21 @@ -- * Concerning 'envInsideDotPattern' +{-# INLINE insideDotPattern #-} insideDotPattern :: TCM a -> TCM a-insideDotPattern = localTC $ \ e -> e { envInsideDotPattern = True }+insideDotPattern = localTC $ set eInsideDotPattern True isInsideDotPattern :: TCM Bool-isInsideDotPattern = asksTC envInsideDotPattern+isInsideDotPattern = viewTC eInsideDotPattern +{-# INLINE callByName #-} -- | Don't use call-by-need evaluation for the given computation. callByName :: TCM a -> TCM a-callByName = localTC $ \ e -> e { envCallByNeed = False }+callByName = localTC $ set eCallByNeed False +{-# INLINE dontFoldLetBindings #-} -- | Don't fold let bindings when printing. This is a bit crude since it disables any folding of let -- bindings at all. In many cases it's better to use `removeLetBinding` before printing to drop -- the let bindings that should not be folded. dontFoldLetBindings :: MonadTCEnv m => m a -> m a-dontFoldLetBindings = localTC $ \ e -> e { envFoldLetBindings = False }+dontFoldLetBindings = localTC $ set eFoldLetBindings False
src/full/Agda/TypeChecking/Monad/Imports.hs view
@@ -2,12 +2,11 @@ module Agda.TypeChecking.Monad.Imports ( addImport- , addImportCycleCheck+ , locallyAddImport , checkForImportCycle , dropDecodedModule , getDecodedModule , getDecodedModules- , getImportPath , getPrettyVisitedModules , getVisitedModule , getVisitedModules@@ -15,25 +14,24 @@ , setVisitedModules , storeDecodedModule , visitModule- , withImportPath ) where -import Control.Arrow ( (***) ) import Control.Monad ( when ) import Data.Maybe (catMaybes)-import qualified Data.Map as Map+import Data.Map qualified as Map import Data.Set (Set)-import qualified Data.Set as Set+import Data.Set qualified as Set import Agda.Syntax.Common.Pretty import Agda.Syntax.TopLevelModuleName import Agda.TypeChecking.Monad.Base -import Agda.Utils.List ( caseListM )-import qualified Agda.Utils.List1 as List1-import qualified Agda.Utils.List2 as List2+import Agda.Utils.List+import Agda.Utils.List1 qualified as List1+import Agda.Utils.List2 qualified as List2 import Agda.Utils.Singleton (singleton)+import Agda.Utils.Tuple ( (***) ) import Agda.Utils.Impossible @@ -41,32 +39,37 @@ -- Also recursively add its imports to the cumulative imports. addImport :: TopLevelModuleName -> TCM () addImport top = do- modifyTCLens' stImportedModules $ Set.insert top- modifyTCLensM stImportedModulesTransitive $ completeTransitiveImports $ singleton top+ vis <- getVisitedModules+ modifyTCLens' stImportedModulesAndTransitive $ updateImports vis top +-- | Temporarily register the given module as imported.+locallyAddImport :: TopLevelModuleName -> TCM () -> TCM ()+locallyAddImport top cont = do+ vis <- getVisitedModules+ locallyTCState stImportedModulesAndTransitive (updateImports vis top) cont++updateImports :: VisitedModules -> TopLevelModuleName+ -> (ImportedModules, ImportedModules)+ -> (ImportedModules, ImportedModules)+updateImports vis top+ = Set.insert top *** completeTransitiveImports vis (singleton top)+ -- | @completeTransitiveImports ms ms'@. -- Precondition: @ms@ disjoint from @ms'@.-completeTransitiveImports :: ReadTCState m => Set TopLevelModuleName -> ImportedModules -> m ImportedModules-completeTransitiveImports ms old = if null ms then return old else do+completeTransitiveImports :: VisitedModules -> Set TopLevelModuleName -> ImportedModules -> ImportedModules+completeTransitiveImports vis ms old = if null ms then old else do -- Add the given imports to the current set. let next = old `Set.union` ms -- The interfaces for the modules we added to the transitive imports.- is <- catMaybes <$> mapM getVisitedModule (Set.toList ms)+ let is = catMaybes $ (`Map.lookup` vis) <$> Set.toList ms -- The imports of these modules.- let imps = Set.unions $ map (Set.fromList . map fst . iImportedModules . miInterface) is+ let imps = Set.unions $ map' (Set.fromList . map' fst . iImportedModules . miInterface) is -- Recurse on the new imports.- completeTransitiveImports (imps `Set.difference` next) next--addImportCycleCheck :: TopLevelModuleName -> TCM a -> TCM a-addImportCycleCheck m =- localTC $ \e -> e { envImportPath = m : envImportPath e }--getImportPath :: TCM [TopLevelModuleName]-getImportPath = asksTC envImportPath+ completeTransitiveImports vis (imps `Set.difference` next) next visitModule :: ModuleInfo -> TCM () visitModule mi =@@ -98,7 +101,7 @@ getDecodedModules = stDecodedModules . stPersistentState <$> getTC setDecodedModules :: DecodedModules -> TCM ()-setDecodedModules ms = modifyTC $ \s ->+setDecodedModules ms = modifyTC' $ \s -> s { stPersistentState = (stPersistentState s) { stDecodedModules = ms } } getDecodedModule :: TopLevelModuleName -> TCM (Maybe ModuleInfo)@@ -121,14 +124,12 @@ } } -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 -- worried about. checkForImportCycle :: TCM () checkForImportCycle = do- caseListM getImportPath __IMPOSSIBLE__ $ \ m ms -> do+ caseListM (viewTC eImportStack) __IMPOSSIBLE__ \m ms -> do when (m `elem` ms) $ typeError $ CyclicModuleDependency $ List2.snoc (List1.fromListSafe __IMPOSSIBLE__ $ dropWhile (/= m) $ reverse ms) m -- NB: we know that ms contains m, so even after dropWhile the list is not empty.
src/full/Agda/TypeChecking/Monad/MetaVars.hs view
@@ -27,7 +27,7 @@ import Agda.Syntax.Internal.MetaVars import Agda.Syntax.Position import Agda.Syntax.Scope.Base-import Agda.Syntax.Common.Pretty (prettyShow)+import Agda.Syntax.Common.Pretty (pretty, prettyShow, (<+>)) import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Builtin (HasBuiltins)@@ -35,7 +35,7 @@ import Agda.TypeChecking.Monad.Closure import Agda.TypeChecking.Monad.Constraints (MonadConstraint(..)) import Agda.TypeChecking.Monad.Debug- (MonadDebug, reportSLn, __IMPOSSIBLE_VERBOSE__)+ (MonadDebug, reportSLn, reportSDoc, __IMPOSSIBLE_VERBOSE__) import Agda.TypeChecking.Monad.Context import Agda.TypeChecking.Monad.Signature (HasConstInfo) import Agda.TypeChecking.Monad.State@@ -52,6 +52,7 @@ import Agda.Utils.Permutation import Agda.Utils.Tuple import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.StrictReader qualified as Strict import Agda.Utils.Impossible @@ -104,7 +105,7 @@ -- | Directly instantiate the metavariable. Skip pattern check, -- occurs check and frozen check. Used for eta expanding frozen -- metas.- assignTerm' :: MonadMetaSolver m => MetaId -> [Arg ArgName] -> Term -> m ()+ assignTerm' :: MetaId -> [Arg ArgName] -> Term -> m () -- | Eta-expand a local meta-variable, if it is of the specified -- class. Don't do anything if the meta-variable is a blocked term.@@ -126,11 +127,27 @@ updateMetaVar m f = lift $ updateMetaVar m f speculateMetas fallback m = ReaderT $ \x -> speculateMetas (runReaderT fallback x) (runReaderT m x) +instance MonadMetaSolver m => MonadMetaSolver (Strict.ReaderT r m) where+ {-# INLINE newMeta' #-}+ newMeta' inst f i p perm j = lift $ newMeta' inst f i p perm j+ {-# INLINE assignV #-}+ assignV dir m us v cmp = lift $ assignV dir m us v cmp+ {-# INLINE assignTerm' #-}+ assignTerm' m us v = lift $ assignTerm' m us v+ {-# INLINE etaExpandMeta #-}+ etaExpandMeta k m = lift $ etaExpandMeta k m+ {-# INLINE updateMetaVar #-}+ updateMetaVar m f = lift $ updateMetaVar m f+ {-# INLINE speculateMetas #-}+ speculateMetas fallback m =+ Strict.ReaderT (\x -> speculateMetas (Strict.runReaderT fallback x)+ (Strict.runReaderT m x))+ -- | Switch off assignment of metas.-dontAssignMetas :: (MonadTCEnv m, HasOptions m, MonadDebug m) => m a -> m a+dontAssignMetas :: (MonadTCEnv m, MonadDebug m) => m a -> m a dontAssignMetas cont = do reportSLn "tc.meta" 45 $ "don't assign metas"- localTC (\ env -> env { envAssignMetas = False }) cont+ localTC (set eAssignMetas False) cont -- | Is the meta-variable from another top-level module? @@ -149,9 +166,9 @@ -- | Pairs of local meta-stores. data LocalMetaStores = LocalMetaStores- { openMetas :: LocalMetaStore+ { openMetas :: !LocalMetaStore -- ^ A 'MetaStore' containing open meta-variables.- , solvedMetas :: LocalMetaStore+ , solvedMetas :: !LocalMetaStore -- ^ A 'MetaStore' containing instantiated meta-variables. } @@ -173,18 +190,17 @@ (_, Just m, ms) -> MapS.insert next m ms -- | Find information about the given local meta-variable, if any.-+{-# SPECIALIZE lookupLocalMeta' :: MetaId -> TCM (Maybe MetaVariable) #-} lookupLocalMeta' :: ReadTCState m => MetaId -> m (Maybe MetaVariable) lookupLocalMeta' m = do- mv <- lkup <$> useR stSolvedMetaStore- case mv of+ tc <- getTCState+ case MapS.lookup m (tc ^. stSolvedMetaStore) of mv@Just{} -> return mv- Nothing -> lkup <$> useR stOpenMetaStore- where- lkup = MapS.lookup m+ Nothing -> pure $! MapS.lookup m (tc ^. stOpenMetaStore) -- | Find information about the given local meta-variable. +{-# SPECIALIZE lookupLocalMeta :: MetaId -> TCM MetaVariable #-} lookupLocalMeta :: (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m MetaVariable@@ -332,8 +348,7 @@ -- | 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) =>+ (HasBuiltins m, HasCallStack, MonadDebug m, MonadReduce m) => MetaId -> m Type getMetaTypeInContext m = do mv@MetaVar{ mvJudgement = j } <- lookupLocalMeta m@@ -414,12 +429,12 @@ -- #5147: Don't count metas in the type of a constraint. For instance the constraint u = v : t -- should not stop us from generalize metas in t, since we could never solve those metas based -- on that constraint alone.- ValueCmp _ _ u v -> return $ allMetas Set.singleton (u, v)- ValueCmpOnFace _ p _ u v -> return $ allMetas Set.singleton (p, u, v)- ElimCmp _ _ _ _ es es' -> return $ allMetas Set.singleton (es, es')- LevelCmp _ l l' -> return $ allMetas Set.singleton (Level l, Level l')- UnquoteTactic t h g -> return $ allMetas Set.singleton (t, h, g)- SortCmp _ s1 s2 -> return $ allMetas Set.singleton (Sort s1, Sort s2)+ ValueCmp _ _ u v -> gatherMetas (u, v)+ ValueCmpOnFace _ p _ u v -> gatherMetas (p, u, v)+ ElimCmp _ _ _ _ es es' -> gatherMetas (es, es')+ LevelCmp _ l l' -> gatherMetas (Level l, Level l')+ UnquoteTactic t h g -> gatherMetas (t, h, g)+ SortCmp _ s1 s2 -> gatherMetas (Sort s1, Sort s2) UnBlock x -> Set.insert x . Set.unions <$> (mapM listenerMetas =<< getMetaListeners x) FindInstance _ x _ -> -- #5093: We should not generalize over metas bound by instance constraints.@@ -434,14 +449,40 @@ 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)+ CheckType t -> gatherMetas t+ CheckLockedVars a b c d -> gatherMetas (a, b, c, d) UsableAtModality{} -> return mempty+ RewConstraint e -> gatherMetas e where -- For blocked constant twin variables listenerMetas EtaExpand{} = return Set.empty listenerMetas (CheckConstraint _ c) = constraintMetas (clValue $ theConstraint c) + gatherMetas :: AllMetas t => t -> TCM (Set MetaId)+ gatherMetas = allMetas makeSingle++ makeSingle :: MetaId -> TCM (Set MetaId)+ makeSingle m = lookupMetaInstantiation m >>= \case+ InstV i -> gatherMetas $ instBody i+ OpenMeta _ -> return $ Set.singleton m+ BlockedConst t ->+ -- Jesper, 2025-05-13: We should really look into the+ -- (blocked) solution here but doing so triggers a+ -- regression in the standard library that I'm too tired+ -- to deal with (see test/Succeed/Issue7876b.agda).+ -- Set.insert m <$> gatherMetas t+ return $ Set.singleton m+ PostponedTypeCheckingProblem clos -> Set.insert m <$> tcProblemMetas (clValue clos)++ tcProblemMetas :: TypeCheckingProblem -> TCM (Set MetaId)+ tcProblemMetas = \case+ CheckExpr _ _ ty -> gatherMetas ty+ CheckArgs _ _ _ _ ty1 ty2 _ -> gatherMetas (ty1, ty2)+ CheckProjAppToKnownPrincipalArg _ _ _ _ _ _ ty1 _ u ty2 patm -> gatherMetas (u, ty1, ty2, patm)+ CheckLambda _ (Arg { unArg = (_ , mty)}) _ ty -> gatherMetas (mty, ty)+ DisambiguateConstructor cdd _ -> gatherMetas $ bcdType cdd+ DoQuoteTerm _ u ty -> gatherMetas (u, ty)+ -- | Create 'MetaInfo' in the current environment. createMetaInfo :: (MonadTCEnv m, ReadTCState m) => m MetaInfo createMetaInfo = createMetaInfo' RunMetaOccursCheck@@ -453,7 +494,14 @@ r <- getCurrentRange cl <- buildClosure r gen <- viewTC eGeneralizeMetas- modality <- currentModality+ -- Andreas, 2026-10-03, issue #8171.+ -- The polarity of the current position is not tracked in the environment;+ -- instead, the context is divided by the polarity of each argument we enter.+ -- Thus, relative to its context, a meta always sits at the unit polarity (@++),+ -- not at the 'defaultPolarity' (mixed) supplied by 'currentModality'.+ -- Otherwise, the occurs check, which divides the variables by the meta's+ -- modality, rejects solutions mentioning variables of non-mixed polarity.+ modality <- setModalPolarity unitPolarity <$> currentModality return MetaInfo { miClosRange = cl , miModality = modality@@ -523,8 +571,12 @@ instance (MonadInteractionPoints m, Monoid w) => MonadInteractionPoints (WriterT w m) instance MonadInteractionPoints TCM where- freshInteractionId = fresh- modifyInteractionPoints f = stInteractionPoints `modifyTCLens` f+ -- TODO: does the pure mode happen?+ freshInteractionId =+ ifImpureConv fresh (patternViolation alwaysUnblock)+ -- TODO: does the pure mode happen?+ modifyInteractionPoints f =+ ifImpureConv (stInteractionPoints `modifyTCLens` f) (patternViolation alwaysUnblock) -- | Register an interaction point during scope checking. -- If there is no interaction id yet, create one.@@ -580,7 +632,7 @@ :: MonadInteractionPoints m => InteractionId -> MetaId -> m () connectInteractionPoint ii mi = do- ipCl <- asksTC envClause+ ipCl <- viewTC eClause m <- useR stInteractionPoints let ip = InteractionPoint { ipRange = __IMPOSSIBLE__, ipMeta = Just mi, ipSolved = False, ipClause = ipCl, ipBoundary = IPBoundary mempty } -- The interaction point needs to be present already, we just set the meta.@@ -593,10 +645,15 @@ removeInteractionPoint ii = modifyInteractionPoints $ BiMap.update (\ ip -> Just ip{ ipSolved = True }) ii --- | Get a list of interaction ids.+-- | Get a list of unsolved interaction ids. {-# SPECIALIZE getInteractionPoints :: TCM [InteractionId] #-} getInteractionPoints :: ReadTCState m => m [InteractionId]-getInteractionPoints = BiMap.keys <$> useR stInteractionPoints+getInteractionPoints =+ map fst . filter (not . ipSolved . snd) . BiMap.toList <$> useR stInteractionPoints+ -- The following alternative will not include the unreachable IPs+ -- (e.g. test/Interaction/Issue2807).+ -- This might lead to a wrong numbering of ?s.+ -- map fst <$> getInteractionIdsAndMetas -- | Get all metas that correspond to unsolved interaction ids. getInteractionMetas :: ReadTCState m => m [MetaId]@@ -688,6 +745,14 @@ => InteractionId -> m Range getInteractionRange = ipRange <.> lookupInteractionPoint +-- | Set the 'Range' for an interaction point.+{-# SPECIALIZE setInteractionRange :: Range -> InteractionId -> TCM () #-}+setInteractionRange :: (MonadInteractionPoints m, MonadDebug m)+ => Range -> InteractionId -> m ()+setInteractionRange r ii = do+ modifyInteractionPoints $ BiMap.update (\ ip -> Just ip{ ipRange = r }) ii+ return ()+ -- | Get the 'Range' for a local meta-variable. getMetaRange :: (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m Range@@ -700,24 +765,22 @@ getInteractionScope = getMetaScope <.> lookupLocalMeta <=< lookupInteractionId -withMetaInfo' :: (MonadTCEnv m, ReadTCState m, MonadTrace m) => MetaVariable -> m a -> m a+withMetaInfo' :: (MonadTrace m) => MetaVariable -> m a -> m a withMetaInfo' mv = withMetaInfo (miClosRange $ mvInfo mv) -withMetaInfo :: (MonadTCEnv m, ReadTCState m, MonadTrace m) => Closure Range -> m a -> m a+withMetaInfo :: (MonadTrace m) => Closure Range -> m a -> m a withMetaInfo mI cont = enterClosure mI $ \ r -> setCurrentRange r cont withInteractionId ::- (MonadDebug m, ReadTCState m, MonadError TCErr m,- MonadTCEnv m, MonadTrace m) =>+ (MonadDebug m, MonadError TCErr m, MonadTrace m) => InteractionId -> m a -> m a withInteractionId i ret = do m <- lookupInteractionId i withMetaId m ret withMetaId ::- (HasCallStack, MonadDebug m, MonadTCEnv m, MonadTrace m,- ReadTCState m) =>+ (HasCallStack, MonadDebug m, MonadTrace m) => MetaId -> m a -> m a withMetaId m ret = do mv <- lookupLocalMeta m@@ -782,33 +845,33 @@ -- * Freezing and unfreezing metas. --------------------------------------------------------------------------- -{-# SPECIALIZE freezeMetas :: LocalMetaStore -> TCM (Set MetaId) #-}+{-# SPECIALIZE freezeMetas :: [MetaId] -> TCM (Set MetaId) #-} -- | Freeze the given meta-variables (but only if they are open) and -- return those that were not already frozen.-freezeMetas :: forall m. (MonadTCState m, ReadTCState m) => LocalMetaStore -> m (Set MetaId)-freezeMetas ms =- execWriterT $- modifyTCLensM stOpenMetaStore $- execStateT (mapM_ freeze $ MapS.keys ms)+freezeMetas :: forall m t. (MonadTCState m, ReadTCState m, Traversable t) => t MetaId -> m (Set MetaId)+freezeMetas =+ execWriterT . modifyTCLensM stOpenMetaStore . execStateT . mapM_ freeze+ -- For efficiency, this modifies the 'LocalMetaStore' in 'stOpenMetaStore'+ -- in a local state and writes this store back to TCState in the end+ -- with the accumulated changes. where freeze :: MetaId -> StateT LocalMetaStore (WriterT (Set MetaId) m) () freeze m = do store <- get- case MapS.lookup m store of- Just mvar- | mvFrozen mvar /= Frozen -> do- lift $ tell (Set.singleton m)- put $ MapS.insert m (mvar { mvFrozen = Frozen }) store- | otherwise -> return ()- Nothing -> return ()+ whenJust (MapS.lookup m store) \ mvar -> do+ unless (mvFrozen mvar == Frozen) do+ lift $ tell $ Set.singleton m+ put $ MapS.insert m (mvar { mvFrozen = Frozen }) store -- | Thaw all open meta variables. unfreezeMetas :: TCM ()-unfreezeMetas = stOpenMetaStore `modifyTCLens` MapS.map unfreeze- where- unfreeze :: MetaVariable -> MetaVariable- unfreeze mvar = mvar { mvFrozen = Instantiable }+unfreezeMetas = do+ reportSDoc "tc.meta" 40 $ "unfreezing ALL metas"+ stOpenMetaStore `modifyTCLens` MapS.map unfreeze_ +unfreeze_ :: MetaVariable -> MetaVariable+unfreeze_ = \ mvar -> mvar { mvFrozen = Instantiable }+ {-# SPECIALIZE isFrozen :: MetaId -> TCM Bool #-} isFrozen :: (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m Bool@@ -816,15 +879,16 @@ mvar <- lookupLocalMeta x return $ mvFrozen mvar == Frozen +-- | Temporarily freeze all open metas (from 'stOpenMetaStore')+-- and unfreeze exactly those that were frozen in the first step. withFrozenMetas :: (MonadMetaSolver m, MonadTCState m) => m a -> m a withFrozenMetas act = do- openMetas <- useR stOpenMetaStore+ openMetas <- MapS.keys <$> useR stOpenMetaStore frozenMetas <- freezeMetas openMetas result <- act- forM_ frozenMetas $ \m ->- updateMetaVar m $ \ mv -> mv { mvFrozen = Instantiable }+ mapM_ (`updateMetaVar` unfreeze_) frozenMetas return result -- | Unfreeze a meta and its type if this is a meta again.@@ -835,7 +899,8 @@ instance UnFreezeMeta MetaId where unfreezeMeta x = unlessM (($ x) <$> isRemoteMeta) $ do- updateMetaVar x $ \ mv -> mv { mvFrozen = Instantiable }+ reportSDoc "tc.meta" 50 $ pure $ "unfreezing meta" <+> pretty x+ updateMetaVar x unfreeze_ unfreezeMeta =<< metaType x {-# SPECIALIZE unfreezeMeta :: MetaId -> TCM () #-}
src/full/Agda/TypeChecking/Monad/Modality.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wunused-imports #-}+-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-all -dno-suppress-type-signatures -ddump-to-file -dno-typeable-binds #-} {- | Modality. @@ -22,15 +23,18 @@ import Agda.Interaction.Options import Agda.Syntax.Common+import Agda.Syntax.Internal import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Constraints (MonadConstraint, solveConstraint) import Agda.TypeChecking.Monad.Context import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Monad.Env+import {-# SOURCE #-} Agda.TypeChecking.Rewriting (checkRewConstraint) import Agda.Utils.Function-import Agda.Utils.Lens import Agda.Utils.Monad+import Agda.Utils.ExpandCase -- | data 'Relevance' -- see "Agda.Syntax.Common".@@ -44,6 +48,8 @@ -- * Operations on 'Context'. ++{-# INLINE workOnTypes #-} -- | Modify the context whenever going from the l.h.s. (term side) -- of the typing judgement to the r.h.s. (type side). workOnTypes :: (MonadTCEnv m, HasOptions m, MonadDebug m)@@ -52,6 +58,7 @@ allowed <- optExperimentalIrrelevance <$> pragmaOptions verboseBracket "tc.irr" 60 "workOnTypes" $ workOnTypes' allowed cont +{-# INLINE workOnTypes' #-} -- | Internal workhorse, expects value of --experimental-irrelevance flag -- as argument. workOnTypes' :: (MonadTCEnv m) => Bool -> m a -> m a@@ -60,11 +67,11 @@ . applyQuantityToJudgement zeroQuantity . applyPolarityToContext (withStandardLock UnusedPolarity) . typeLevelReductions- . localTC (\ e -> e { envWorkingOnTypes = True })+ . localTC (set eWorkingOnTypes True) applyPolarityToContext :: (MonadTCEnv tcm, LensModalPolarity p) => p -> tcm a -> tcm a applyPolarityToContext p = localTC- $ over eContext (map $ inverseApplyPolarity pol)+ $ over eContext (fmap $ inverseApplyPolarity pol) . over eLetBindings (Map.map . fmap . onLetBindingType $ inverseApplyPolarity pol) where@@ -91,7 +98,7 @@ -- Precondition: @Relevance /= Relevant@ applyRelevanceToContextOnly :: (MonadTCEnv tcm) => Relevance -> tcm a -> tcm a applyRelevanceToContextOnly rel = localTC- $ over eContext (map $ inverseApplyRelevance rel)+ $ over eContext (fmap $ inverseApplyRelevance rel) . over eLetBindings (Map.map . fmap . onLetBindingType $ inverseApplyRelevance rel) -- | Apply relevance @rel@ the the relevance annotation of the (typing/equality)@@ -101,14 +108,15 @@ applyRelevanceToJudgementOnly :: (MonadTCEnv tcm) => Relevance -> tcm a -> tcm a applyRelevanceToJudgementOnly = localTC . over eRelevance . composeRelevance +{-# INLINE applyRelevanceToContextFunBody #-} -- | Like 'applyRelevanceToContext', but only act on context if -- @--irrelevant-projections@. -- See issue #2170.-applyRelevanceToContextFunBody :: (MonadTCM tcm, LensRelevance r) => r -> tcm a -> tcm a-applyRelevanceToContextFunBody thing cont =+applyRelevanceToContextFunBody :: (MonadTCM tcm, ExpandCase (tcm a), LensRelevance r) => r -> tcm a -> tcm a+applyRelevanceToContextFunBody thing cont = expand \ret -> case getRelevance thing of- Relevant{} -> cont- rel -> applyWhenM (optIrrelevantProjections <$> pragmaOptions)+ Relevant{} -> ret cont+ rel -> ret $ applyWhenM (optIrrelevantProjections <$> pragmaOptions) (applyRelevanceToContextOnly rel) $ -- enable local irr. defs only when option applyRelevanceToJudgementOnly rel cont -- enable global irr. defs alway @@ -119,7 +127,7 @@ applyQuantityToJudgement :: (MonadTCEnv tcm, LensQuantity q) => q -> tcm a -> tcm a applyQuantityToJudgement =- localTC . over eQuantity . composeQuantity . getQuantity+ localTC . over eQuantityZeroHardCompile . composeQuantity . getQuantity -- | Apply inverse composition with the given cohesion to the typing context. applyCohesionToContext :: (MonadTCEnv tcm, LensCohesion m) => m -> tcm a -> tcm a@@ -131,7 +139,7 @@ applyCohesionToContextOnly :: (MonadTCEnv tcm) => Cohesion -> tcm a -> tcm a applyCohesionToContextOnly q = localTC- $ over eContext (map $ inverseApplyCohesion q)+ $ over eContext (fmap $ inverseApplyCohesion q) . over eLetBindings (Map.map . fmap . onLetBindingType $ inverseApplyCohesion q) -- | Can we split on arguments of the given cohesion?@@ -140,8 +148,26 @@ let c = getCohesion a pure (usableCohesion c) `and2M` (pure (c /= Flat) `or2M` do optFlatSplit <$> pragmaOptions) +{-# NOINLINE applyDomToContext' #-}+applyDomToContext' :: RewDom' Term -> TCM ()+applyDomToContext' r = checkRewConstraint (rewDomEq r) -{-# SPECIALIZE applyModalityToContext :: Modality -> TCM a -> TCM a #-}+{-# INLINE applyDomToContext #-}+-- | Apply modalities and equational constraints (local rewrite rules) to the+-- context.+applyDomToContext :: Dom e -> TCM a -> TCM a+applyDomToContext d act = do+ expand \ret -> case rewDom d of+ Nothing -> ret $ pure ()+ Just c -> ret $ applyDomToContext' c+ applyModalityToContext d act++{-# INLINE addRewConstraint #-}+-- | Adds an equational constraint due to a local rewrite rule.+addRewConstraint :: MonadConstraint tcm+ => LocalEquation -> tcm ()+addRewConstraint = solveConstraint . RewConstraint+ -- | (Conditionally) wake up irrelevant variables and make them relevant. -- For instance, -- in an irrelevant function argument otherwise irrelevant variables@@ -150,13 +176,21 @@ -- Also allow the use of irrelevant definitions. -- -- This function might also do something for other modalities.-applyModalityToContext :: (MonadTCEnv tcm, LensModality m) => m -> tcm a -> tcm a-applyModalityToContext thing =+{-# INLINE applyModalityToContext #-}+applyModalityToContext :: (MonadTCEnv tcm, ExpandCase (tcm a), LensModality m) => m -> tcm a -> tcm a+applyModalityToContext !thing !act = expand \ret -> case getModality thing of- m | m == unitModality -> id- | otherwise -> applyModalityToContextOnly m- . applyModalityToJudgementOnly m+ m | noinlineEqModality m unitModality -> ret act+ | otherwise -> ret $ localTC (applyModalityToContext' m) act +{-# NOINLINE applyModalityToContext' #-}+applyModalityToContext' :: Modality -> TCEnv -> TCEnv+applyModalityToContext' m e =+ e & over eContext (fmap $ inverseApplyModalityButNotQuantity m)+ & over eLetBindings (Map.map . fmap . onLetBindingType $ inverseApplyModalityButNotQuantity m)+ & over eRelevance (composeRelevance (getRelevance m))+ & over eQuantityZeroHardCompile (composeQuantity (getQuantity m))+ -- | (Conditionally) wake up irrelevant variables and make them relevant. -- For instance, -- in an irrelevant function argument otherwise irrelevant variables@@ -167,25 +201,36 @@ -- not for quantities. -- -- Precondition: @Modality /= Relevant@+{-# INLINE applyModalityToContextOnly #-} applyModalityToContextOnly :: (MonadTCEnv tcm) => Modality -> tcm a -> tcm a-applyModalityToContextOnly m = localTC- $ over eContext (map $ inverseApplyModalityButNotQuantity m)- . over eLetBindings- (Map.map . fmap . onLetBindingType $ inverseApplyModalityButNotQuantity m)+applyModalityToContextOnly m = localTC (applyModalityToContextOnly' m) +{-# NOINLINE applyModalityToContextOnly' #-}+applyModalityToContextOnly' :: Modality -> TCEnv -> TCEnv+applyModalityToContextOnly' m e =+ e & over eContext (fmap $ inverseApplyModalityButNotQuantity m)+ & over eLetBindings (Map.map . fmap . onLetBindingType $ inverseApplyModalityButNotQuantity m)++ -- | Apply the relevance and quantity components of the modality to -- the modality annotation of the (typing/equality) judgement. -- -- Precondition: The relevance component must not be 'Relevant'.+{-# INLINE applyModalityToJudgementOnly #-} applyModalityToJudgementOnly :: (MonadTCEnv tcm) => Modality -> tcm a -> tcm a-applyModalityToJudgementOnly m =- localTC $ over eRelevance (composeRelevance (getRelevance m)) .- over eQuantity (composeQuantity (getQuantity m))+applyModalityToJudgementOnly m = localTC (applyModalityToJudgementOnly' m) +{-# NOINLINE applyModalityToJudgementOnly' #-}+applyModalityToJudgementOnly' :: Modality -> TCEnv -> TCEnv+applyModalityToJudgementOnly' m e =+ e & over eRelevance (composeRelevance (getRelevance m))+ & over eQuantityZeroHardCompile (composeQuantity (getQuantity m))++{-# INLINE applyModalityToContextFunBody #-} -- | Like 'applyModalityToContext', but only act on context (for Relevance) if -- @--irrelevant-projections@. -- See issue #2170.-applyModalityToContextFunBody :: (MonadTCM tcm, LensModality r) => r -> tcm a -> tcm a+applyModalityToContextFunBody :: (MonadTCM tcm, LensModality r, ExpandCase (tcm a)) => r -> tcm a -> tcm a applyModalityToContextFunBody thing cont = do ifM (optIrrelevantProjections <$> pragmaOptions) {-then-} (applyModalityToContext m cont) -- enable global irr. defs always
src/full/Agda/TypeChecking/Monad/Mutual.hs view
@@ -15,17 +15,17 @@ import Agda.Utils.Null noMutualBlock :: TCM a -> TCM a-noMutualBlock = localTC $ \e -> e { envMutualBlock = Nothing }+noMutualBlock = localTC (set eMutualBlock Nothing) -- | Pass the current mutual block id -- or create a new mutual block if we are not already inside on. inMutualBlock :: (MutualId -> TCM a) -> TCM a inMutualBlock m = do- mi <- asksTC envMutualBlock+ mi <- viewTC eMutualBlock case mi of Nothing -> do i <- fresh- localTC (\ e -> e { envMutualBlock = Just i }) $ m i+ localTC (set eMutualBlock (Just i)) $ m i -- Don't create a new mutual block if we're already inside one. Just i -> m i @@ -53,7 +53,7 @@ -- | Get the current mutual block, if any, otherwise a fresh mutual -- block is returned. currentOrFreshMutualBlock :: TCM MutualId-currentOrFreshMutualBlock = maybe fresh return =<< asksTC envMutualBlock+currentOrFreshMutualBlock = maybe fresh return =<< viewTC eMutualBlock lookupMutualBlock :: ReadTCState tcm => MutualId -> tcm MutualBlock lookupMutualBlock (MutualId i) =
src/full/Agda/TypeChecking/Monad/Open.hs view
@@ -3,6 +3,7 @@ ( makeOpen , getOpen , tryGetOpen+ , tryGetOpenRew , isClosed ) where @@ -36,6 +37,20 @@ getOpen (OpenThing cp _ _ x) = do sub <- checkpointSubstitution cp return $ applySubst sub x++-- | Try to extract the value from an open local rewrite rule.+-- The checkpoint at which it was created must be in scope.+tryGetOpenRew :: (MonadTCEnv m)+ => (Substitution -> m RewriteRule)+ -- ^ Action to take if the substitution fails+ -> Open RewriteRule+ -- ^ The rewrite rule we are trying to open+ -> m RewriteRule+tryGetOpenRew fallback (OpenThing cp _ _ rew) = do+ sub <- checkpointSubstitution cp+ case applySubstLocalRewrite sub rew of+ Nothing -> fallback sub+ Just rew' -> return rew' -- | Extract the value from an open term. If the checkpoint is no longer in scope use the provided -- function to pull the object to the most recent common checkpoint. The function is given the
src/full/Agda/TypeChecking/Monad/Options.hs view
@@ -1,7 +1,7 @@ module Agda.TypeChecking.Monad.Options where -import Prelude hiding (null)+import Prelude hiding (null, (||), not) import Control.Monad ( unless, when ) import Control.Monad.IO.Class ( MonadIO(..) )@@ -22,7 +22,7 @@ import Agda.Syntax.Common import Agda.Syntax.TopLevelModuleName -import Agda.TypeChecking.Monad.Debug (reportSDoc)+import Agda.TypeChecking.Monad.Debug (reportSDoc, reportS) import Agda.TypeChecking.Warnings import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Imports@@ -36,12 +36,14 @@ import Agda.Interaction.Library import Agda.Interaction.Library.Base (LibCache(LibCache), libAbove, libFile, runLibM) +import Agda.Utils.Boolean import Agda.Utils.FileName import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as G import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.List1 (List1) import qualified Agda.Utils.List1 as List1+import Agda.Utils.Maybe (isJust) import Agda.Utils.Null import Agda.Syntax.Common.Pretty import Agda.Utils.Size@@ -99,7 +101,15 @@ -> CommandLineOptions -> TCM () setCommandLineOptions' root opts = do- -- Andreas, 2022-11-19: removed a call to checkOpts which did nothing.+ -- Andreas, 2025-08-05, PR #8037+ -- 'setLibraryPaths' below can fail,+ -- and to print the error correctly+ -- we need knowledge of the optDiagnosticsColor command line option.+ -- Thus, we already set this option here.+ -- Setting all the options here breaks the optAbsoluteIncludePaths logic.+ modifyTC $ Lens.mapCommandLineOptions \ o -> o{ optDiagnosticsColour = optDiagnosticsColour opts }++ -- Compute the set of include paths. incs <- case optAbsoluteIncludePaths opts of [] -> do opts' <- setLibraryPaths root opts@@ -109,7 +119,7 @@ incs -> return incs modifyTC $ Lens.setCommandLineOptions opts{ optAbsoluteIncludePaths = incs } setPragmaOptions (optPragmaOptions opts)- updateBenchmarkingStatus+ -- updateBenchmarkingStatus -- already included in setPragmaOptions libToTCM :: LibM a -> TCM a libToTCM m = do@@ -184,27 +194,34 @@ -> CommandLineOptions -> TCM CommandLineOptions setLibraryPaths root o =- setLibraryIncludes =<< addDefaultLibraries root o+ uncurry setLibraryIncludes =<< addDefaultLibraries root o -setLibraryIncludes :: CommandLineOptions -> TCM CommandLineOptions-setLibraryIncludes o+setLibraryIncludes+ :: Maybe AgdaLibFile+ -- ^ The project whose dependencies are 'optLibraries', if any.+ -> CommandLineOptions+ -> TCM CommandLineOptions+setLibraryIncludes project o | not (optUseLibs o) = pure o | otherwise = do let libs = optLibraries o installed <- libToTCM $ getInstalledLibraries (optOverrideLibrariesFile o)- paths <- libToTCM $ libraryIncludePaths (optOverrideLibrariesFile o) installed libs+ paths <- libToTCM $ libraryIncludePaths (optOverrideLibrariesFile o) project installed libs return o{ optIncludePaths = paths ++ optIncludePaths o } +-- | Unless libraries have been given on the command line,+-- set them from the project's @.agda-lib@ file (returned as well)+-- or the @defaults@ file. addDefaultLibraries :: AbsolutePath -- ^ The base directory of relative paths. -> CommandLineOptions- -> TCM CommandLineOptions+ -> TCM (Maybe AgdaLibFile, CommandLineOptions) addDefaultLibraries root o- | not (null $ optLibraries o) || not (optUseLibs o) = pure o+ | not (null $ optLibraries o) || not (optUseLibs o) = pure (Nothing, o) | otherwise = do- (libs, incs) <- libToTCM $ getDefaultLibraries (filePath root) (optDefaultLibs o)- return o{ optIncludePaths = incs ++ optIncludePaths o, optLibraries = libs }+ (project, libs, incs) <- libToTCM $ getDefaultLibraries (filePath root) (optDefaultLibs o)+ return (project, o{ optIncludePaths = incs ++ optIncludePaths o, optLibraries = libs }) -- This function is only called when an interactor exists -- (i.e. when Agda actually does something).@@ -245,24 +262,22 @@ -- | Disable display forms. enableDisplayForms :: MonadTCEnv m => m a -> m a-enableDisplayForms =- localTC $ \e -> e { envDisplayFormsEnabled = True }+enableDisplayForms = localTC (set eDisplayFormsEnabled True) -- | Disable display forms. disableDisplayForms :: MonadTCEnv m => m a -> m a-disableDisplayForms =- localTC $ \e -> e { envDisplayFormsEnabled = False }+disableDisplayForms = localTC (set eDisplayFormsEnabled False) -- | Check if display forms are enabled. displayFormsEnabled :: MonadTCEnv m => m Bool-displayFormsEnabled = asksTC envDisplayFormsEnabled+displayFormsEnabled = viewTC eDisplayFormsEnabled -- | Gets the include directories. -- -- Precondition: 'optAbsoluteIncludePaths' must be nonempty (i.e. -- 'setCommandLineOptions' must have run). -getIncludeDirs :: HasOptions m => m (List1 AbsolutePath)+getIncludeDirs :: TCM (List1 AbsolutePath) getIncludeDirs = do List1.fromListSafe __IMPOSSIBLE__ . optAbsoluteIncludePaths <$> commandLineOptions @@ -288,13 +303,13 @@ incs <- return $ fmap (mkAbsolute . (filePath root </>)) incs -- Andreas, 2013-10-30 Add default include dir- primdir <- useTC stPrimitiveLibDir+ primdir <- useSession lensPrimitiveLibDir -- We add the default dir at the end, since it is then -- printed last in error messages. -- Might also be useful to overwrite default imports... incs <- return $ List1.fromListSafe __IMPOSSIBLE__ $ nubOn id $ List1.toList $ incs <> List1.singleton primdir - reportSDoc "setIncludeDirs" 10 $ return $ vcat+ reportS "setIncludeDirs" 10 $ vcat [ "Old include directories:" , nest 2 $ vcat $ map pretty oldIncs , "New include directories:"@@ -315,7 +330,6 @@ -- "old-path/M.agda", when the user actually meant -- "new-path/M.agda". when (sort oldIncs /= sort (List1.toList incs)) $ do- ho <- getInteractionOutputCallback tcWarnings <- useTC stTCWarnings -- restore already generated warnings libCache <- useTC stLibCache -- restore cached project configs & .agda-lib files, since they use absolute paths decodedModules <- getDecodedModules@@ -323,9 +337,8 @@ resetAllState setTCLens stTCWarnings tcWarnings setTCLens stLibCache libCache- setInteractionOutputCallback ho setDecodedModules keptDecodedModules- setTCLens stModuleToSourceId modFile+ setSession lensModuleToSourceId modFile Lens.putAbsoluteIncludePaths $ List1.toList incs where@@ -402,6 +415,11 @@ _ -> (keep, modFile) process keep modFile ms +{-# SPECIALIZE NOINLINE isPropEnabled :: TCM Bool #-}+isIrrelevanceEnabled :: HasOptions m => m Bool+isIrrelevanceEnabled = optIrrelevance <$> pragmaOptions++{-# SPECIALIZE NOINLINE isPropEnabled :: TCM Bool #-} isPropEnabled :: HasOptions m => m Bool isPropEnabled = optProp <$> pragmaOptions @@ -409,7 +427,7 @@ isLevelUniverseEnabled = optLevelUniverse <$> pragmaOptions isTwoLevelEnabled :: HasOptions m => m Bool-isTwoLevelEnabled = optTwoLevel <$> pragmaOptions+isTwoLevelEnabled = (optTwoLevel || (isJust . optCubical)) <$> pragmaOptions {-# SPECIALIZE hasUniversePolymorphism :: TCM Bool #-} hasUniversePolymorphism :: HasOptions m => m Bool@@ -419,7 +437,7 @@ showImplicitArguments = optShowImplicit <$> pragmaOptions showGeneralizedArguments :: HasOptions m => m Bool-showGeneralizedArguments = (\opt -> optShowGeneralized opt) <$> pragmaOptions+showGeneralizedArguments = optShowGeneralized <$> pragmaOptions showIrrelevantArguments :: HasOptions m => m Bool showIrrelevantArguments = optShowIrrelevant <$> pragmaOptions@@ -456,6 +474,7 @@ typeInType :: HasOptions m => m Bool typeInType = not . optUniverseCheck <$> pragmaOptions +-- | Is eta-equality enabled according to the options (@--(no-)eta-equality@)? etaEnabled :: HasOptions m => m Bool etaEnabled = optEta <$> pragmaOptions
src/full/Agda/TypeChecking/Monad/Options.hs-boot view
@@ -3,9 +3,8 @@ module Agda.TypeChecking.Monad.Options where import Agda.Interaction.Library.Base-import Agda.Interaction.Options.HasOptions import Agda.TypeChecking.Monad.Base import Agda.Utils.List1 (List1) libToTCM :: LibM a -> TCM a-getIncludeDirs :: HasOptions m => m (List1 AbsolutePath)+getIncludeDirs :: TCM (List1 AbsolutePath)
src/full/Agda/TypeChecking/Monad/Pure.hs view
@@ -23,11 +23,16 @@ import Agda.Utils.ListT import Agda.Utils.Update +import Agda.Utils.StrictReader qualified as Strict+import Agda.Utils.StrictWriter qualified as Strict+import Agda.Utils.StrictState qualified as Strict+ class ( HasBuiltins m , HasConstInfo m , MonadAddContext m , MonadDebug m+ , MonadFileId m , MonadReduce m , MonadTCEnv m , ReadTCState m@@ -43,3 +48,6 @@ instance PureTCM m => PureTCM (ReaderT r m) instance (PureTCM m, Monoid w) => PureTCM (WriterT w m) instance PureTCM m => PureTCM (StateT s m)+instance PureTCM m => PureTCM (Strict.ReaderT r m)+instance (PureTCM m, Monoid w) => PureTCM (Strict.WriterT w m)+instance PureTCM m => PureTCM (Strict.StateT s m)
src/full/Agda/TypeChecking/Monad/Pure.hs-boot view
@@ -20,6 +20,7 @@ , HasConstInfo m , MonadAddContext m , MonadDebug m+ , MonadFileId m , MonadReduce m , MonadTCEnv m , ReadTCState m
src/full/Agda/TypeChecking/Monad/Signature.hs view
@@ -4,28 +4,29 @@ import Prelude hiding (null) -import Control.Arrow ( first, second ) import Control.Monad.Except ( ExceptT ) import Control.Monad.State ( StateT ) import Control.Monad.Reader ( ReaderT ) import Control.Monad.Writer ( WriterT )-import Control.Monad.Trans.Maybe ( MaybeT )+import Control.Monad.Trans.Maybe ( MaybeT (MaybeT), runMaybeT ) import Control.Monad.Trans.Identity ( IdentityT ) import Control.Monad.Trans ( MonadTrans, lift ) -import Data.Foldable (for_)-import qualified Data.List as List-import Data.Set (Set)-import qualified Data.Set as Set-import qualified Data.Map as Map-import qualified Data.HashMap.Strict as HMap+import Data.Either+import Data.Foldable ( for_ )+import Data.IntMap qualified as IntMap+import Data.List qualified as List+import Data.Set ( Set )+import Data.Set qualified as Set+import Data.Map qualified as Map+import Data.HashMap.Strict qualified as HMap import Data.Maybe-import Data.Semigroup ((<>)) import Agda.Interaction.Options +import Agda.Syntax.Scope.Base (LiveNames(..), isModuleAlive, isNameAlive) import Agda.Syntax.Abstract.Name-import Agda.Syntax.Abstract (Ren, ScopeCopyInfo(..))+import Agda.Syntax.Abstract (Ren, renamingSize, ScopeCopyInfo(..)) import Agda.Syntax.Common import Agda.Syntax.Internal as I import Agda.Syntax.Internal.Names@@ -43,6 +44,7 @@ import Agda.TypeChecking.Monad.Options import Agda.TypeChecking.Monad.State import Agda.TypeChecking.Monad.Trace+import Agda.TypeChecking.Monad.Statistics import Agda.TypeChecking.DropArgs import Agda.TypeChecking.Warnings import Agda.TypeChecking.Positivity.Occurrence@@ -51,6 +53,7 @@ import Agda.TypeChecking.Coverage.SplitTree import {-# SOURCE #-} Agda.TypeChecking.InstanceArguments import {-# SOURCE #-} Agda.TypeChecking.CompiledClause.Compile+import {-# SOURCE #-} Agda.TypeChecking.EtaContract (etaContract) import {-# SOURCE #-} Agda.TypeChecking.Polarity import {-# SOURCE #-} Agda.TypeChecking.Pretty import {-# SOURCE #-} Agda.TypeChecking.ProjectionLike@@ -58,13 +61,15 @@ import {-# SOURCE #-} Agda.TypeChecking.Opacity import {-# SOURCE #-} Agda.TypeChecking.Telescope +import qualified Agda.Interaction.Options.ProfileOptions as Profile import Agda.Utils.CallStack.Base import Agda.Utils.Either import Agda.Utils.Function ( applyWhen ) import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List-import qualified Agda.Utils.List1 as List1+import Agda.Utils.List1 ( List1, pattern (:|) )+import Agda.Utils.List1 qualified as List1 import Agda.Utils.ListT import Agda.Utils.Maybe import Agda.Utils.Monad@@ -72,7 +77,11 @@ import Agda.Syntax.Common.Pretty (Doc, prettyShow) import Agda.Utils.Singleton import Agda.Utils.Size+import Agda.Utils.Tuple ( first, second ) import Agda.Utils.Update+import Agda.Utils.StrictReader qualified as Strict+import Agda.Utils.StrictWriter qualified as Strict+import Agda.Utils.StrictState qualified as Strict import Agda.Utils.Impossible @@ -87,7 +96,7 @@ setHardCompileTimeModeIfErased erased = localTC $ applyWhen (isErased erased) (set eHardCompileTimeMode True)- . over eQuantity (`composeQuantity` asQuantity erased)+ . over eQuantityZeroHardCompile (`composeQuantity` asQuantity erased) -- | If the quantity is \"erased\", then hard compile-time mode is -- enabled when the continuation is run.@@ -114,7 +123,7 @@ -> TCM a setRunTimeModeUnlessInHardCompileTimeMode c = ifM (viewTC eHardCompileTimeMode) c $- localTC (over eQuantity $ mapQuantity (`addQuantity` topQuantity)) c+ localTC (over eQuantityZeroHardCompile $ mapQuantity (`addQuantity` topQuantity)) c -- | Use hard compile-time mode in the continuation if the first -- argument is @'Erased' something@. Use run-time mode if the first@@ -140,8 +149,7 @@ Erased{} -> return () NotErased o -> do let warn = warning $ PlentyInHardCompileTimeMode o- hard <- viewTC eHardCompileTimeMode- if not hard then return () else case o of+ whenM (viewTC eHardCompileTimeMode) $ case o of QωInferred{} -> return () Qω{} -> warn QωPlenty{} -> warn@@ -150,6 +158,7 @@ addConstant :: QName -> Definition -> TCM () addConstant q d = do reportSDoc "tc.signature" 20 $ "adding constant " <+> pretty q <+> " to signature"+ reportSDoc "tc.signature" 80 $ "definition =" <?> pretty d -- Every constant that gets added to the signature in hard -- compile-time mode is treated as erased.@@ -162,7 +171,7 @@ return $ mapQuantity (zeroQuantity `composeQuantity`) d tel <- getContextTelescope- let tel' = replaceEmptyName "r" $ killRange $ case theDef d of+ let tel' = killRange $ case theDef d of Constructor{} -> fmap hideOrKeepInstance tel Function{ funProjection = Right Projection{ projProper = Just{}, projIndex = n } } -> let fallback = fmap hideOrKeepInstance tel in@@ -172,7 +181,7 @@ Nothing -> fallback Just (doms, dom) -> telFromList $ fmap hideOrKeepInstance doms ++ [dom] _ -> tel- let d' = abstract tel' $ d { defName = q }+ d' <- normalizeCopyBody $ abstract tel' $ d { defName = q } reportSDoc "tc.signature" 60 $ "lambda-lifted definition =" <?> pretty d' modifySignature $ updateDefinitions $ HMap.insertWith (+++) q d' i <- currentOrFreshMutualBlock@@ -186,8 +195,30 @@ , defPolarity = if null (defPolarity new) then defPolarity old else defPolarity new+ , defCompiledRep = Map.unionWith (++)+ (defCompiledRep new)+ (defCompiledRep old) } +-- | Bring the definition of a data or record type copy into normal form:+-- fully instantiated and eta-contracted (see '_dataClause').+--+-- Lambda-lifting (the 'Abstract' instance for 'Defn') wraps the body of a+-- copy into one lambda per module parameter. Eta-contracting these away+-- again is what makes the copy unfold when it is applied to fewer arguments+-- than it has parameters, which in turn lets chains of copies arising from+-- partial module instantiations unfold all the way down (issue #8545).+-- Metas are instantiated first, since a solved meta can hide an eta-redex.+normalizeCopyBody :: Definition -> TCM Definition+normalizeCopyBody def = case theDef def of+ d@Datatype{ dataClause = Just v } -> contract v \ v -> d{ dataClause = Just v }+ d@Record { recClause = Just v } -> contract v \ v -> d{ recClause = Just v }+ _ -> return def+ where+ contract v update = do+ v <- etaContract =<< instantiateFull v+ return def{ theDef = update v }+ -- | A combination of 'addConstant' and 'defaultDefn'. The 'Language' -- does not need to be supplied. @@ -198,10 +229,10 @@ addConstant q $ defaultDefn info q t lang def -- | Set termination info of a defined function symbol.-setTerminates :: MonadTCState m => QName -> Bool -> m ()+setTerminates :: MonadTCState m => QName -> Maybe Bool -> m () setTerminates q b = modifySignature $ updateDefinition q $ updateTheDef $ \case- def@Function{} -> def { funTerminates = Just b }- def@Record{} -> def { recTerminates = Just b }+ def@Function{} -> def { funTerminates = b }+ def@Record{} -> def { recTerminates = b } def -> def -- | Set CompiledClauses of a defined function symbol.@@ -271,23 +302,18 @@ markFirstOrder :: QName -> TCM () markFirstOrder = setFunctionFlag FunFirstOrder True -unionSignatures :: [Signature] -> Signature-unionSignatures ss = foldr unionSignature emptySignature ss--unionSignature :: Signature -> Signature -> Signature-unionSignature (Sig a b c d) (Sig a' b' c' d') =- Sig (Map.union a a')- (HMap.union b b') -- definitions are unique (in at most one module)- (HMap.unionWith mappend c c') -- rewrite rules are accumulated- (d <> d') -- instances are accumulated- -- | Add a section to the signature. -- -- The current context will be stored as the cumulative module parameters--- for this section.+-- for this section, and a module checkpoint entry will be added+-- into the module checkpoint stack. addSection :: ModuleName -> TCM () addSection m = do tel <- getContextTelescope+ addSection' m tel++addSection' :: ModuleName -> Telescope -> TCM ()+addSection' m tel = do let sec = Section tel -- Make sure we do not overwrite an existing section! whenJustM (getSection m) $ \ sec' -> do@@ -303,15 +329,10 @@ reportSDoc "impossible" 60 $ "with content" <+> pretty sec __IMPOSSIBLE__ -- Add the new section.- setModuleCheckpoint m+ cp <- viewTC eCurrentCheckpoint+ setModuleCheckpoint m cp modifySignature $ over sigSections $ Map.insert m sec --- | Sets the checkpoint for the given module to the current checkpoint.-setModuleCheckpoint :: ModuleName -> TCM ()-setModuleCheckpoint m = do- chkpt <- viewTC eCurrentCheckpoint- stModuleCheckpoints `modifyTCLens` Map.insert m chkpt- -- | Get a section. -- -- Why Maybe? The reason is that we look up all prefixes of a module to@@ -319,7 +340,7 @@ -- A.B.C say, A and A.B do not exist. {-# SPECIALIZE getSection :: ModuleName -> TCM (Maybe Section) #-} {-# SPECIALIZE getSection :: ModuleName -> ReduceM (Maybe Section) #-}-getSection :: (Functor m, ReadTCState m) => ModuleName -> m (Maybe Section)+getSection :: (ReadTCState m) => ModuleName -> m (Maybe Section) getSection m = do sig <- (^. stSignature . sigSections) <$> getTCState isig <- (^. stImports . sigSections) <$> getTCState@@ -331,7 +352,7 @@ -- the section telescope is empty. {-# SPECIALIZE lookupSection :: ModuleName -> TCM Telescope #-} {-# SPECIALIZE lookupSection :: ModuleName -> ReduceM Telescope #-}-lookupSection :: (Functor m, ReadTCState m) => ModuleName -> m Telescope+lookupSection :: (ReadTCState m) => ModuleName -> m Telescope lookupSection m = maybe EmptyTel (^. secTelescope) <$> getSection m -- | Add display forms for a name @f@ copied by a module application. Essentially if @f@ can reduce to@@ -345,6 +366,26 @@ -- @ -- A.B.C.f vs ==> f xs -- @+--+-- Invoking @'addDisplayForms' x@ will add a display form for each copy @x@ transitively reduces to.+-- E.g. consider the following iterated module application.+-- @+-- module M0 (n : Nat) where+-- b : Bool+-- b = n > 42+-- module M1 (n : Nat) = M0 (suc n)+-- module M2 (n : Nat) = M1 (suc n)+-- module M3 (n : Nat) = M2 (suc n)+-- @+--+-- For the first copy @M1.b n = M0.b (suc n)@ we add the display form @M0.b (suc n) --> M1.b n@.+--+-- For the second copy @M2.b n = M1.b (suc n)@ we first add display form @M1.b (suc n) --> M2.b n@+-- and for the further unfolding we add display form @M0.b (suc (suc n)) --> M2.b n@.+--+-- For the third copy @M3.b n = M2.b (suc n)@ we add display forms @M2.b (suc n) --> M3.b n@,+-- @M1.b (suc (suc n)) --> M3.b n@ and @M0.b (suc (suc (suc n))) --> M3.b n@.+ addDisplayForms :: QName -> TCM () addDisplayForms x = do reportSDoc "tc.display.section" 20 $ "Computing display forms for" <+> pretty x@@ -366,6 +407,8 @@ -- and add them mapM_ (uncurry addDisplayForm) dfs+ reportSDoc "tc.display.section" 20 $ "Added display forms for" <+> pretty x+ where -- To get display forms for projections we need to unSpine here.@@ -429,16 +472,21 @@ -> Args -- ^ Arguments of module application. -> ScopeCopyInfo -- ^ Imported names and modules -> TCM ()-applySection new ptel old ts ScopeCopyInfo{ renModules = rm, renNames = rd } = do+applySection new ptel old ts info@ScopeCopyInfo{ renModules = rm, renNames = rd } = do rd <- closeConstructors rd- applySection' new ptel old ts ScopeCopyInfo{ renModules = rm, renNames = rd }+ applySection' new ptel old ts info{ renModules = rm, renNames = rd } where+ -- If a datatype is being copied, all its constructors need to be copied, -- and if a constructor is copied its datatype needs to be.+ --+ -- If a proper projection is being copied, its record needs to be+ -- copied too (#8037). closeConstructors :: Ren QName -> TCM (Ren QName) closeConstructors rd = do- ds <- nubOn snd . catMaybes <$> traverse constructorData (Map.toList rd)- cs <- nubOn snd . concat <$> traverse dataConstructors (Map.toList rd)+ let defs = Map.toList rd+ ds <- nubOn snd . catMaybes <$> traverse childToParent defs+ cs <- nubOn snd . concat <$> traverse parentToChild defs new <- Map.unionsWith (<>) <$> traverse rename (ds ++ cs) reportSDoc "tc.mod.apply.complete" 30 $ "also copying: " <+> pretty new@@ -446,35 +494,91 @@ where rename :: (ModuleName, QName) -> TCM (Ren QName) rename (m, x)- | x `Map.member` rd = pure mempty+ | x `Map.member` rd = pure mempty | otherwise =- -- Ulf, 2024-06-24 (#7329):- -- Here we used to generate an unqualified name, but this breaks things if the new- -- module shows up in a module application later on. This is because we use the- -- module name to figure out which arguments from the application are relevant for- -- the current symbol (see argsToUse in applySection' below).- --- -- Instead we use the target module name of the thing that required x to be copied.- -- For instance, if we are copying a data type A.B.D to X.Y.Z.D and its constructor- -- mkD is not in the renaming, we add `A.B.mkD -> X.Y.Z.mkD` (instead of `A.B.mkD ->- -- mkD` which we did before).- Map.singleton x . pure . qualify m <$> freshName_ (prettyShow $ qnameName x)+ -- Ulf, 2024-06-24 (#7329):+ -- Here we used to generate an unqualified name, but this breaks things if the new+ -- module shows up in a module application later on. This is because we use the+ -- module name to figure out which arguments from the application are relevant for+ -- the current symbol (see argsToUse in applySection' below).+ --+ -- Instead we use the target module name of the thing that required x to be copied.+ -- For instance, if we are copying a data type A.B.D to X.Y.Z.D and its constructor+ -- mkD is not in the renaming, we add `A.B.mkD -> X.Y.Z.mkD` (instead of `A.B.mkD ->+ -- mkD` which we did before).+ Map.singleton x . pure . qualify m <$> freshName_ (prettyShow $ qnameName x) - constructorData :: (QName, List1.List1 QName) -> TCM (Maybe (ModuleName, QName))- constructorData (x, y List1.:| _) = do -- All new names share the same module, so we can safely grab the first one- (theDef <$> getConstInfo x) <&> \case- Constructor{ conData = d } -> Just (qnameModule y, d)- _ -> Nothing+ -- @parentModule x y p@:+ -- Where to put the copy of the data/record type @p@ of the+ -- constructor or projection @x@, given that @x@ is copied to @y@?+ --+ -- The type @p@ lives in an ancestor module of the module of its+ -- child @x@, but how many levels up depends on the kind of child:+ --+ -- 1. A data type and its constructors live in the same module+ -- (0 levels up).+ --+ -- 2. A record lives one level above its projections, which live in+ -- the record module (1 level up).+ --+ -- 3. A record with a user-written constructor lives in the same module+ -- as that constructor (0 levels up, issue #4189), but the /generated/+ -- constructor of a record without a constructor declaration lives in+ -- the record module (1 level up, see 'ConcreteToAbstract.recordConName').+ --+ -- So rather than hardwiring the number of levels, we read it off the+ -- original names @x@ and @p@ and reproduce it for the copies (#8725).+ -- Getting this wrong lands the copy of @p@ in a record module, whose+ -- telescope has one parameter too many (the record value), which then+ -- crashes the next module application that copies @p@ again.+ parentModule :: QName -> QName -> QName -> ModuleName+ parentModule x y p = mnameFromList $ dropEnd (sanitize levels) ys+ where+ qual = mnameToList . qnameModule+ ys = qual y+ levels = length (qual x) - length (qual p)+ -- optional: force argument of @(`dropEnd` ys`)@ into range @0..length ys@+ sanitize = max 0 . min (length ys) - dataConstructors :: (QName, List1.List1 QName) -> TCM [(ModuleName, QName)]- dataConstructors (x, y List1.:| _) = do+ childToParent :: (QName, List1 QName) -> TCM (Maybe (ModuleName, QName))+ childToParent (x, y :| _) = do+ theDef <$> getConstInfo x <&> \case+ Constructor{ conData = d } -> Just (parentModule x y d, d)++ -- If a proper projection is being copied, its record needs to be+ -- copied too (#8037).+ --+ -- #8242: copying a proper projection M.R.proj → N.R.proj does not+ -- mean we should copy the record type M.R to N.R.R!+ def | Just Projection{ projProper = Just r } <- isProjection_ def ->+ Just (parentModule x y r, r)++ _ -> Nothing++ parentToChild :: (QName, List1 QName) -> TCM [(ModuleName, QName)]+ parentToChild (x, y :| _) = do (theDef <$> getConstInfo x) <&> \case Datatype{ dataCons = cs } -> map (qnameModule y,) cs++ -- note about the module here: a user-written record constructor+ -- lives outside the record module, in the same module as the+ -- record (#4189), so we put its copy next to the copy of the+ -- record. A generated constructor lives in the record module, but+ -- putting its copy next to the record copy is fine as well: what+ -- matters is that 'parentModule' above recovers the relative+ -- position from the copies rather than assuming a fixed one.+ --+ -- in debugging output, if the record being copied has a+ -- generated constructor name, it's going to look like we+ -- accidentally lost a layer of quantification, but that's+ -- because record constructors get generated with a concrete+ -- name that *looks* qualified Record{ recConHead = h } -> [(qnameModule y, conName h)]+ _ -> [] applySection' :: ModuleName -> Telescope -> ModuleName -> Args -> ScopeCopyInfo -> TCM ()-applySection' new ptel old ts ScopeCopyInfo{ renNames = rd, renModules = rm } = do+applySection' new ptel old ts ren@ScopeCopyInfo{ renNames = rd, renModules = rm } = do do noCopyList <- catMaybes <$> mapM getName' constrainedPrims for_ (Map.keys rd) $ \ q ->@@ -486,10 +590,30 @@ , "ptel =" <+> pretty ptel , "old =" <+> pretty old , "ts =" <+> pretty ts+ , "ren =" <+> pretty ren ]++ whenProfile Profile.Sections do+ oldn <- show <$> pretty old++ let+ ds = fromIntegral $ renamingSize rd+ ms = fromIntegral $ renamingSize rm++ tickMax "largest copied section" (ds + ms)+ tickN "copied definitions" ds+ tickN ("copies for " <> oldn) (ds + ms)++ reportSLn "tc.mod.apply" 40 "applySection': copying definitions" _ <- Map.traverseWithKey (traverse . copyDef ts) rd++ reportSLn "tc.mod.apply" 40 "applySection': copying modules" _ <- Map.traverseWithKey (traverse . copySec ts) rm++ reportSLn "tc.mod.apply" 40 "applySection': computing polarities" computePolarity (Map.elems rd >>= List1.toList)++ reportSLn "tc.mod.apply" 40 "finished applySection'" where -- Andreas, 2013-10-29 -- Here, if the name x is not imported, it persists as@@ -515,10 +639,12 @@ copyDef ts x y = do def <- getConstInfo x np <- argsToUse (qnameModule x)+ origTel <- lookupSection $ qnameModule x -- Issue #3083: We need to use the hiding from the telescope of the -- original module. This can be different than the hiding for the common -- parent in the case of record modules.- hidings <- map getHiding . telToList <$> lookupSection (qnameModule x)+ let hidings = map getHiding $ telToList origTel+ -- This 'zipWith' sometimes silently drops arguments, see #8443 let ts' = zipWith setHiding hidings ts commonTel <- lookupSection (commonParentModule old $ qnameModule x) reportSDoc "tc.mod.apply" 80 $ vcat@@ -533,13 +659,15 @@ m = unitModality { modCohesion = getCohesion ai , modPolarity = getModalPolarity ai }- localTC (over eContext (map (mapModality (m `inverseComposeModality`)))) $+ localTC (over eContext (fmap (mapModality (m `inverseComposeModality`)))) $ copyDef' ts' np def+ reportSDoc "tc.mod.apply" 80 $+ "finished copyDef" <+> pretty x <+> "->" <+> pretty y where copyDef' ts np d = do reportSDoc "tc.mod.apply" 60 $ "making new def for" <+> pretty y <+> "from" <+> pretty x <+> "with" <+> text (show np) <+> "args" <+> text (show $ defAbstract d) reportSDoc "tc.mod.apply" 80 $ vcat- [ "args = " <+> text (show ts')+ [ "args = " <+> pretty ts , "old type = " <+> pretty (defType d) ] reportSDoc "tc.mod.apply" 80 $ "new type = " <+> pretty t@@ -551,7 +679,7 @@ -- Issue5583: Don't skip constructures, because the original constructor doesn't always -- work. For instance if it's only available in an anonymous module generated by -- `open import M args`.- whenJust inst $ \_ -> addTypedInstance' False False inst y t+ whenJust inst $ \_ -> addTypedInstance' False False inst empty y t -- Set display form for the old name if it's not a constructor. {- BREAKS fail/Issue478 -- Andreas, 2012-10-20 and if we are not an anonymous module@@ -590,22 +718,24 @@ , defMatchable = Set.empty , defNoCompilation = defNoCompilation d , defInjective = False- , defCopatternLHS = isCopatternLHS [cl]+ , defCopatternLHS' = isCopatternLHS [cl] , defBlocked = defBlocked d , defLanguage = case defLanguage d of -- Note that Cubical Agda code can be imported- -- when --erased-cubical is used.- l@(Cubical CFull) -> l- Cubical CErased -> lang- WithoutK -> lang- WithK -> lang- , theDef = df }+ -- when --cubical=erased is used.+ l@(Cubical CFull) -> l+ Cubical CErased -> lang+ Cubical CWithoutGlue -> lang+ WithoutK -> lang+ WithK -> lang+ , defMightContainMetas = True+ , theDef = df } oldDef = theDef d isCon = case oldDef of { Constructor{} -> True ; _ -> False } mutual = case oldDef of { Function{funMutual = m} -> m ; _ -> Nothing } extlam = case oldDef of { Function{funExtLam = e} -> e ; _ -> Nothing }- with = case oldDef of { Function{funWith = w} -> copyName <$> w ; _ -> Nothing }+ with = case oldDef of { Function{funWith = w} -> copyName <$> w ; _ -> empty } -- Andreas, 2015-05-11, to fix issue 1413: -- Even if we apply the record argument (must be @var 0@), we stay a projection. -- This is because we may abstract the record argument later again.@@ -633,12 +763,12 @@ } Datatype{ dataPars = np, dataCons = cs } -> return $ oldDef { dataPars = np - size ts'- , dataClause = Just cl+ , dataClause = Just body , dataCons = map copyName cs } Record{ recPars = np, recTel = tel, recConHead = c, recFields = fs } -> return $ oldDef { recPars = np - size ts'- , recClause = Just cl+ , recClause = Just body , recTel = apply tel ts' , recConHead = copyConHead c , recFields = (map . fmap) copyName fs@@ -665,25 +795,30 @@ reportSDoc "tc.mod.apply" 80 $ ("new def for" <+> pretty x) <?> pretty newDef return newDef + -- The number of remaining parameters. We need to drop the+ -- lambdas corresponding to these from the body below.+ pars = max 0 $ either (const 0) (pred . projIndex) proj+ rel = getRelevance $ defArgInfo d++ -- The definition of the copy, linking back to the original @x@.+ -- For data and record types this is stored as is (in 'dataClause' /+ -- 'recClause'); function copies wrap it into the clause @cl@ below.+ body = dropArgs pars $ case oldDef of+ Function{funProjection = Right p} -> projDropParsApply p ProjSystem rel ts'+ _ -> Def x $ map Apply 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'+ , clauseBody = Just body , clauseType = Just $ defaultArg t , clauseCatchall = empty- , clauseRecursive = Just False -- definitely not recursive+ , clauseRecursive = NotRecursive -- definitely not recursive , clauseUnreachable = Just False -- definitely not unreachable , 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 $ either (const 0) (pred . projIndex) proj- rel = getRelevance $ defArgInfo d {- Example @@ -717,15 +852,18 @@ -} copySec :: Args -> ModuleName -> ModuleName -> TCM () copySec ts x y = do+ reportSDoc "tc.mod.apply" 80 $ "Copying section" <+> pretty x <+> "to" <+> pretty y totalArgs <- argsToUse x tel <- lookupSection x- let sectionTel = apply tel $ take totalArgs ts- reportSDoc "tc.mod.apply" 80 $ "Copying section" <+> pretty x <+> "to" <+> pretty y+ let sectionTel = apply tel $ take totalArgs ts reportSDoc "tc.mod.apply" 80 $ " ts = " <+> mconcat (List.intersperse "; " (map pretty ts)) reportSDoc "tc.mod.apply" 80 $ " totalArgs = " <+> text (show totalArgs) reportSDoc "tc.mod.apply" 80 $ " tel = " <+> text (unwords (map (fst . unDom) $ telToList tel)) -- only names reportSDoc "tc.mod.apply" 80 $ " sectionTel = " <+> text (unwords (map (fst . unDom) $ telToList ptel)) -- only names- addContext sectionTel $ addSection y+ ctxTel <- getContextTelescope+ addSection' y (ctxTel `abstract` sectionTel)+ reportSDoc "tc.mod.apply" 80 $+ "finished copySec" <+> pretty x <+> "->" <+> pretty y -- | Add a display form to a definition (could be in this or imported signature). addDisplayForm :: QName -> DisplayForm -> TCM ()@@ -737,7 +875,8 @@ let add = updateDefinition x $ \ def -> def{ defDisplay = d : defDisplay def } ifM (isLocal x) {-then-} (modifySignature add)- {-else-} (stImportsDisplayForms `modifyTCLens` HMap.insertWith (++) x [d])+ {-else-} (stImportsDisplayForms `modifyTCLens` HMap.insertWith (<>) x (List1.singleton d))+ reportSDoc "tc.display.section" 30 $ "Added display form for" <+> pretty x isLocal :: ReadTCState m => QName -> m Bool isLocal x = HMap.member x <$> useR (stSignature . sigDefinitions)@@ -745,8 +884,8 @@ getDisplayForms :: (HasConstInfo m, ReadTCState m) => QName -> m [LocalDisplayForm] getDisplayForms q = do ds <- either (const []) defDisplay <$> getConstInfo' q- ds1 <- HMap.lookupDefault [] q <$> useR stImportsDisplayForms- ds2 <- HMap.lookupDefault [] q <$> useR stImportedDisplayForms+ ds1 <- List1.toList' . HMap.lookup q <$> useR stImportsDisplayForms+ ds2 <- List1.toList' . HMap.lookup q <$> useR stImportedDisplayForms ifM (isLocal q) (return $ ds ++ ds1 ++ ds2) (return $ ds1 ++ ds ++ ds2) @@ -797,16 +936,18 @@ canonicalName :: HasConstInfo m => QName -> m QName canonicalName x = do- def <- theDef <$> getConstInfo x- case def of- Constructor{conSrcCon = c} -> return $ conName c- Record{recClause = Just (Clause{ clauseBody = body })} -> can body- Datatype{dataClause = Just (Clause{ clauseBody = body })} -> can body- _ -> return x+ getConstInfo x <&> theDef >>= \case+ Constructor{conSrcCon = c} -> return $ conName c+ Record {recClause = Just v} -> can v+ Datatype{dataClause = Just v} -> can v+ _ -> return x where- can body = canonicalName $ extract $ fromMaybe __IMPOSSIBLE__ body- extract (Def x _) = x- extract _ = __IMPOSSIBLE__+ can = canonicalName . extract+ -- The body of a copy is an application of the original type,+ -- possibly still under some lambdas if it could not be eta-contracted.+ extract v = case snd $ lamView v of+ Def x _ -> x+ _ -> __IMPOSSIBLE__ sameDef :: HasConstInfo m => QName -> QName -> m (Maybe QName) sameDef d1 d2 = do@@ -873,7 +1014,7 @@ ) => HasConstInfo m where -- | Lookup the definition of a name. The result is a closed thing, all free -- variables have been abstracted over.- getConstInfo :: QName -> m Definition+ getConstInfo :: HasCallStack => QName -> m Definition getConstInfo q = getConstInfo' q >>= \case Right d -> return d@@ -882,37 +1023,83 @@ "Abstract, thus, not in scope: " ++ prettyShow q -- | Version that reports exceptions:- getConstInfo' :: QName -> m (Either SigError Definition)+ getConstInfo' :: HasCallStack => QName -> m (Either SigError Definition) -- getConstInfo' q = Right <$> getConstInfo q -- conflicts with default signature - -- | Return the rewrite rules for the given head symbol that could be tried.- -- Not categorically all rewrite rules are returned, in particular, none when- -- reduction of the head symbol is disabled.- -- Rewrite rules that only happen to be in the signature but are not in scope- -- are also not returned.- getRewriteRulesFor :: QName -> m RewriteRules+ -- | Return the global rewrite rules for the given head symbol that could be+ -- tried.+ -- Not categorically all rewrite rules are returned, in particular, none+ -- when reduction of the head symbol is disabled.+ -- Rewrite rules that only happen to be in the signature but are not in+ -- scope are also not returned.+ getGlobalRewriteRulesFor :: QName -> m GlobalRewriteRules + -- | Return the local rewrite rules for the given head symbol.+ getLocalRewriteRulesFor :: RewriteHead -> m RewriteRules+ -- Lifting HasConstInfo through monad transformers: default getConstInfo'- :: (HasConstInfo n, MonadTrans t, m ~ t n)+ :: (HasCallStack, HasConstInfo n, MonadTrans t, m ~ t n) => QName -> m (Either SigError Definition) getConstInfo' = lift . getConstInfo' - default getRewriteRulesFor+ default getGlobalRewriteRulesFor :: (HasConstInfo n, MonadTrans t, m ~ t n)- => QName -> m RewriteRules- getRewriteRulesFor = lift . getRewriteRulesFor+ => QName -> m GlobalRewriteRules+ getGlobalRewriteRulesFor = lift . getGlobalRewriteRulesFor -{-# SPECIALIZE getConstInfo :: QName -> TCM Definition #-}+ default getLocalRewriteRulesFor+ :: (HasConstInfo n, MonadTrans t, m ~ t n)+ => RewriteHead -> m RewriteRules+ getLocalRewriteRulesFor = lift . getLocalRewriteRulesFor+{-# SPECIALIZE getConstInfo :: HasCallStack => QName -> TCM Definition #-} -{-# SPECIALIZE getOriginalConstInfo :: QName -> TCM Definition #-}+justTheRule :: GlobalRewriteRule -> Maybe RewriteRule+justTheRule (GlobalRewriteRule _ g q ps rhs t isClause _)+ | isClause = Nothing+ | otherwise = pure $ RewriteRule g (RewDefHead q) ps rhs t++{-# INLINE getAllRewriteRulesForDefHead #-}+getAllRewriteRulesForDefHead :: (HasConstInfo m, ReadTCState m) => QName -> m RewriteRules+getAllRewriteRulesForDefHead f = do+ globals <- catMaybes . fmap justTheRule <$> (instantiateRewriteRules =<< getGlobalRewriteRulesFor f)+ localRewritingOption >>= \case+ True -> do locals <- getLocalRewriteRulesFor (RewDefHead f)+ pure $! globals ++! locals+ False -> pure globals++-- | A local rewrite rule forces us to consider the definition as defined+-- by copatterns (see #3812 for an example case with global rewrite rules)+-- This is necessary because binding local rewrite rules does not update+-- defCopatternLHS'+rewUsesCopatterns :: HasConstInfo m => RewriteHead -> m Bool+rewUsesCopatterns h =+ any lrewHasProjectionPattern <$> getLocalRewriteRulesFor h++{-# INLINE defCopatternLHS #-}+-- | Is this a function defined by copatterns?+-- Accounts for local rewrite rules+defCopatternLHS :: HasConstInfo m => QName -> Definition -> m Bool+defCopatternLHS f d = localRewritingOption >>= \case+ True -> do+ rewForces <- rewUsesCopatterns $ RewDefHead f+ pure $! defCopatternLHS' d || rewForces+ False ->+ pure $! defCopatternLHS' d++{-# INLINE getAllRewriteRulesForVarHead #-}+getAllRewriteRulesForVarHead :: HasConstInfo m+ => Nat -> m RewriteRules+getAllRewriteRulesForVarHead x = getLocalRewriteRulesFor $ RewVarHead x++{-# SPECIALIZE getOriginalConstInfo :: HasCallStack => QName -> TCM Definition #-} -- | The computation 'getConstInfo' sometimes tweaks the returned -- 'Definition', depending on the current 'Language' and the -- 'Language' of the 'Definition'. This variant of 'getConstInfo' does -- not perform any tweaks. getOriginalConstInfo ::- (ReadTCState m, HasConstInfo m) => QName -> m Definition+ (HasCallStack, ReadTCState m, HasConstInfo m) => QName -> m Definition getOriginalConstInfo q = do def <- getConstInfo q lang <- getLanguage@@ -924,86 +1111,103 @@ (getConstInfo q) _ -> return def +{-# SPECIALIZE defaultGetGlobalRewriteRulesFor :: QName -> ReduceM GlobalRewriteRules #-} -- | Return the rewrite rules for the given head symbol that could be tried. -- Not categorically all rewrite rules are returned, e.g. none when -- reduction of the head symbol is disabled. -- Rewrite rules that only happen to be in the signature but are not in scope -- are also not returned.-defaultGetRewriteRulesFor :: (ReadTCState m, MonadTCEnv m) => QName -> m RewriteRules-defaultGetRewriteRulesFor q = ifNotM (shouldReduceDef q) (return []) $ do- getFilteredRewriteRulesFor True q+defaultGetGlobalRewriteRulesFor :: (ReadTCState m, MonadTCEnv m)+ => QName -> m GlobalRewriteRules+defaultGetGlobalRewriteRulesFor q = ifNotM (shouldReduceDef q) (return []) $ do+ getFilteredGlobalRewriteRulesFor True q +{-# SPECIALIZE defaultGetLocalRewriteRulesFor :: RewriteHead -> TCM RewriteRules #-}+defaultGetLocalRewriteRulesFor ::+ (ReadTCState m, MonadTCEnv m, MonadDebug m, HasOptions m)+ => RewriteHead -> m RewriteRules+defaultGetLocalRewriteRulesFor h = localRewritingOption >>= \case+ False -> pure []+ True -> do+ ifNotM (shouldReduceDef' h) (return []) $ do+ m <- runMaybeT . lookup h =<< viewTC eLocalRewriteRules+ pure $ fromMaybe [] m+ where+ shouldReduceDef' (RewDefHead f) = shouldReduceDef f+ shouldReduceDef' (RewVarHead _) = pure True++ lookup h m = do+ rews <- MaybeT $ pure $ lookup' h m+ lift $ traverse (tryGetOpenRew fallback) rews++ fallback = __IMPOSSIBLE_VERBOSE__ . show++ lookup' (RewDefHead f) = HMap.lookup f . defHeadedRews+ lookup' (RewVarHead x) = IntMap.lookup x . varHeadedRews+ -- | If the 'Bool' parameter is 'True', get the rules in scope, -- otherwise, get *all* rules unfiltered.-getFilteredRewriteRulesFor :: (ReadTCState m, MonadTCEnv m)+getFilteredGlobalRewriteRulesFor :: (ReadTCState m) => Bool -- ^ Only return rewrite rules that are in scope? -> QName -- ^ Head symbol.- -> m RewriteRules -- ^ Rules for the head symbol.-getFilteredRewriteRulesFor filt q = do+ -> m GlobalRewriteRules -- ^ Rules for the head symbol.+getFilteredGlobalRewriteRulesFor filt q = do st <- getTCState let- look :: Lens' TCState Signature -> Maybe RewriteRules+ look :: Lens' TCState Signature -> Maybe GlobalRewriteRules look l = HMap.lookup q $ st ^. (l . sigRewriteRules) -- Restrict "imported" rewrite rules to those defined in modules we currently (transitively) import. let imps = st ^. stImportedModulesTransitive- let inScope rew = rewTopModule rew `Set.member` imps+ let inScope rew = grTopModule rew `Set.member` imps let rewImported = applyWhen filt (filter inScope) <$> look stImports -- stImports is actually a superset of imported symbols. return $ mconcat $ catMaybes [look stSignature, rewImported] -- | Get the original name of the projection -- (the current one could be from a module application).-getOriginalProjection :: HasConstInfo m => QName -> m QName+getOriginalProjection :: (HasCallStack, HasConstInfo m) => QName -> m QName getOriginalProjection q = projOrig . fromMaybe __IMPOSSIBLE__ <$> isProjection q -instance HasConstInfo (TCMT IO) where- getRewriteRulesFor = defaultGetRewriteRulesFor+instance HasConstInfo TCM where+ getGlobalRewriteRulesFor = defaultGetGlobalRewriteRulesFor+ getLocalRewriteRulesFor = defaultGetLocalRewriteRulesFor getConstInfo' q = do st <- getTC env <- askTC defaultGetConstInfo st env q getConstInfo q = getConstInfo' q >>= \case Right d -> return d- Left (SigUnknown err) -> fail err+ Left (SigUnknown err) -> internalError err Left SigAbstract -> notInScopeError $ qnameToConcrete q Left SigCubicalNotErasure -> typeError $ CubicalNotErasure q defaultGetConstInfo- :: (HasOptions m, MonadDebug m, MonadTCEnv m)+ :: (HasCallStack, HasOptions m, MonadDebug m) => TCState -> TCEnv -> QName -> m (Either SigError Definition) defaultGetConstInfo st env q = do let defs = st ^. stSignature . sigDefinitions idefs = st ^. stImports . sigDefinitions- case catMaybes [HMap.lookup q defs, HMap.lookup q idefs] of- [] -> return $ Left $ SigUnknown $ "Unbound name: " ++ prettyShow q ++ showQNameId q- [d] -> checkErasureFixQuantity d >>= \case- Left err -> return (Left err)- Right d -> mkAbs env d- ds -> __IMPOSSIBLE_VERBOSE__ $ "Ambiguous name: " ++ prettyShow q+ unambiguous d = checkErasureFixQuantity d >>= \case+ Left err -> return $ Left err+ Right d -> mkAbs env d+ case (HMap.lookup q defs, HMap.lookup q idefs) of+ (Nothing, Nothing) -> return $ Left $ SigUnknown $ "Unbound name: " ++ prettyShow q ++ showQNameId q+ (Just d, Nothing) -> unambiguous d+ (Nothing, Just d) -> unambiguous d+ _ -> __IMPOSSIBLE_VERBOSE__ $ "Ambiguous name: " ++ prettyShow q where mkAbs env d -- Apply the reducibility rules (abstract, opaque) to check -- whether the definition should be hidden behind an -- 'AbstractDef'.- | not (isAccessibleDef env st d{defName = q'}) =+ | not (isAccessibleDef env st d) = case alwaysMakeAbstract d of Just d -> return $ Right d Nothing -> return $ Left SigAbstract- -- the above can happen since the scope checker is a bit sloppy with 'abstract'+ -- the above can happen since the scope checker is a bit sloppy with 'abstract' | otherwise = return $ Right d- where- q' = case theDef d of- -- Hack to make abstract constructors work properly. The constructors- -- live in a module with the same name as the datatype, but for 'abstract'- -- purposes they're considered to be in the same module as the datatype.- Constructor{} -> dropLastModule q- _ -> q - dropLastModule q@QName{ qnameModule = m } =- q{ qnameModule = mnameFromList $- initWithDefault __IMPOSSIBLE__ $ mnameToList m- } -- Names defined in Cubical Agda may only be used in Erased -- Cubical Agda if --erasure is used. In that case they are (to@@ -1014,10 +1218,9 @@ current == Cubical CErased then do erasure <- optErasure <$> pragmaOptions- return $- if erasure- then Right $ setQuantity zeroQuantity d- else Left SigCubicalNotErasure+ if erasure+ then return $! Right $! setQuantity zeroQuantity d+ else return $ Left SigCubicalNotErasure else return $ Right d -- HasConstInfo lifts through monad transformers@@ -1031,19 +1234,23 @@ instance HasConstInfo m => HasConstInfo (ReaderT r m) instance HasConstInfo m => HasConstInfo (StateT s m) instance (Monoid w, HasConstInfo m) => HasConstInfo (WriterT w m)+instance HasConstInfo m => HasConstInfo (Strict.ReaderT r m)+instance HasConstInfo m => HasConstInfo (Strict.StateT s m)+instance (Monoid w, HasConstInfo m) => HasConstInfo (Strict.WriterT w m) instance HasConstInfo m => HasConstInfo (BlockT m) {-# INLINE getConInfo #-}-getConInfo :: HasConstInfo m => ConHead -> m Definition+getConInfo :: (HasCallStack, HasConstInfo m) => ConHead -> m Definition getConInfo = getConstInfo . conName +{-# INLINE getPolarity #-} -- | Look up the polarity of a definition.-getPolarity :: HasConstInfo m => QName -> m [Polarity]+getPolarity :: (HasCallStack, HasConstInfo m) => QName -> m [Polarity] getPolarity q = defPolarity <$> getConstInfo q -- | Look up polarity of a definition and compose with polarity -- represented by 'Comparison'.-getPolarity' :: HasConstInfo m => Comparison -> QName -> m [Polarity]+getPolarity' :: (HasCallStack, HasConstInfo m) => Comparison -> QName -> m [Polarity] getPolarity' CmpEq q = map (composePol Invariant) <$> getPolarity q -- return [] getPolarity' CmpLeq q = getPolarity q -- composition with Covariant is identity @@ -1068,7 +1275,7 @@ else return [] -- | Get argument occurrence info for argument @i@ of definition @d@ (never fails).-getArgOccurrence :: QName -> Nat -> TCM Occurrence+getArgOccurrence :: HasCallStack => QName -> Nat -> TCM Occurrence getArgOccurrence d i = do def <- getConstInfo d case theDef def of@@ -1096,6 +1303,13 @@ modifyArgOccurrences d f = modifySignature $ updateDefinition d $ updateDefArgOccurrences f +getArgOccurrences :: ReadTCState m => QName -> m [Occurrence]+getArgOccurrences q = do+ sig <- getSignature+ case lookupDefinition q sig of+ Nothing -> __IMPOSSIBLE__+ Just def -> pure (defArgOccurrences def)+ setTreeless :: QName -> TTerm -> TCM () setTreeless q t = modifyGlobalDefinition q $ updateTheDef $ \case@@ -1117,7 +1331,7 @@ -- | Returns a list of length 'conArity'. -- If no erasure analysis has been performed yet, this will be a list of 'False's.-getErasedConArgs :: HasConstInfo m => QName -> m [Bool]+getErasedConArgs :: (HasCallStack, HasConstInfo m) => QName -> m [Bool] getErasedConArgs q = do def <- getConstInfo q case theDef def of@@ -1176,7 +1390,7 @@ mutuallyRecursive :: QName -> QName -> TCM Bool mutuallyRecursive d d1 = (d `elem`) . fromMaybe __IMPOSSIBLE__ <$> getMutual d1 --- | A function/data/record definition is nonRecursive if it is not even mutually+-- | A function, data, or record definition is definitely not recursive if it is not even mutually -- recursive with itself. definitelyNonRecursive_ :: Defn -> Bool definitelyNonRecursive_ = maybe False null . getMutual_@@ -1197,11 +1411,11 @@ -- | Compute the number of free variables of a defined name. This is the sum of -- number of parameters shared with the current module and the number of -- anonymous variables (if the name comes from a let-bound module).-getDefFreeVars :: (Functor m, Applicative m, ReadTCState m, MonadTCEnv m) => QName -> m Nat+getDefFreeVars :: (ReadTCState m, MonadTCEnv m) => QName -> m Nat getDefFreeVars = getModuleFreeVars . qnameModule -freeVarsToApply :: (Functor m, HasConstInfo m, HasOptions m,- ReadTCState m, MonadTCEnv m, MonadDebug m)+freeVarsToApply :: (HasConstInfo m,+ ReadTCState m) => QName -> m Args freeVarsToApply q = do vs <- moduleParamsToApply $ qnameModule q@@ -1218,8 +1432,8 @@ {-# SPECIALIZE getModuleFreeVars :: ModuleName -> TCM Nat #-} {-# SPECIALIZE getModuleFreeVars :: ModuleName -> ReduceM Nat #-}-getModuleFreeVars :: (Functor m, Applicative m, MonadTCEnv m, ReadTCState m)- => ModuleName -> m Nat+getModuleFreeVars :: ( MonadTCEnv m, ReadTCState m)+ =>ModuleName -> m Nat getModuleFreeVars m = do m0 <- commonParentModule m <$> currentModule (+) <$> getAnonymousVariables m <*> (size <$> lookupSection m0)@@ -1238,9 +1452,9 @@ -- module M₃ Θ where -- ... M₁.M₂.f [insert Γ raised by Θ] -- @-moduleParamsToApply :: (Functor m, Applicative m, HasOptions m,+moduleParamsToApply :: ( HasOptions m, MonadTCEnv m, ReadTCState m, MonadDebug m)- => ModuleName -> m Args+ =>ModuleName -> m Args moduleParamsToApply m = do traceSDoc "tc.sig.param" 90 ("computing module parameters of " <+> pretty m) $ do@@ -1304,8 +1518,7 @@ -- context. {-# SPECIALIZE instantiateDef :: Definition -> TCM Definition #-} instantiateDef- :: ( Functor m, HasConstInfo m, HasOptions m- , ReadTCState m, MonadTCEnv m, MonadDebug m )+ :: (HasConstInfo m, ReadTCState m ) => Definition -> m Definition instantiateDef d = do vs <- freeVarsToApply $ defName d@@ -1317,20 +1530,23 @@ fsep (map pretty $ zipWith (<$) ctx vs) return $ d `apply` vs -instantiateRewriteRule :: (Functor m, HasConstInfo m, HasOptions m,- ReadTCState m, MonadTCEnv m, MonadDebug m)- => RewriteRule -> m RewriteRule+-- | Instantiate a global rewrite rule+instantiateRewriteRule :: (HasConstInfo m, ReadTCState m)+ => GlobalRewriteRule -> m GlobalRewriteRule instantiateRewriteRule rew = do- traceSDoc "rewriting" 95 ("instantiating rewrite rule" <+> pretty (rewName rew) <+> "to the local context.") $ do- vs <- freeVarsToApply $ rewName rew+ traceSDoc "rewriting" 95+ ("instantiating rewrite rule" <+>+ pretty (grName rew) <+>+ "to the local context.") $ do+ vs <- freeVarsToApply $ grName rew let rew' = rew `apply` vs traceSLn "rewriting" 95 ("instantiated rewrite rule: ") $ do traceSLn "rewriting" 95 (show rew') $ do return rew' -instantiateRewriteRules :: (Functor m, HasConstInfo m, HasOptions m,- ReadTCState m, MonadTCEnv m, MonadDebug m)- => RewriteRules -> m RewriteRules+-- | Instantiate global rewrite rules+instantiateRewriteRules :: (HasConstInfo m, ReadTCState m)+ => GlobalRewriteRules -> m GlobalRewriteRules instantiateRewriteRules = mapM instantiateRewriteRule -- | Return the abstract view of a definition, /regardless/ of whether@@ -1362,33 +1578,33 @@ -- | Enter abstract mode. Abstract definition in the current module are transparent. {-# SPECIALIZE inAbstractMode :: TCM a -> TCM a #-} inAbstractMode :: MonadTCEnv m => m a -> m a-inAbstractMode = localTC $ \e -> e { envAbstractMode = AbstractMode }+inAbstractMode = localTC (set eAbstractMode AbstractMode) -- | Not in abstract mode. All abstract definitions are opaque. {-# SPECIALIZE inConcreteMode :: TCM a -> TCM a #-} inConcreteMode :: MonadTCEnv m => m a -> m a-inConcreteMode = localTC $ \e -> e { envAbstractMode = ConcreteMode }+inConcreteMode = localTC (set eAbstractMode ConcreteMode) -- | Ignore abstract mode. All abstract definitions are transparent. ignoreAbstractMode :: MonadTCEnv m => m a -> m a-ignoreAbstractMode = localTC $ \e -> e { envAbstractMode = IgnoreAbstractMode }+ignoreAbstractMode = localTC (set eAbstractMode IgnoreAbstractMode) -- | Go under the given opaque block. The unfolding set will turn opaque -- definitions transparent. {-# SPECIALIZE underOpaqueId :: OpaqueId -> TCM a -> TCM a #-} underOpaqueId :: MonadTCEnv m => OpaqueId -> m a -> m a-underOpaqueId i = localTC $ \e -> e { envCurrentOpaqueId = Just i }+underOpaqueId i = localTC (set eCurrentOpaqueId (Just i)) -- | Outside of any opaque blocks. {-# SPECIALIZE notUnderOpaque :: TCM a -> TCM a #-} notUnderOpaque :: MonadTCEnv m => m a -> m a-notUnderOpaque = localTC $ \e -> e { envCurrentOpaqueId = Nothing }+notUnderOpaque = localTC (set eCurrentOpaqueId Nothing) -- | Enter the reducibility environment associated with a definition: -- The environment will have the same concreteness as the name, and we -- will be in the opaque block enclosing the name, if any. {-# SPECIALIZE inConcreteOrAbstractMode :: QName -> (Definition -> TCM a) -> TCM a #-}-inConcreteOrAbstractMode :: (MonadTCEnv m, HasConstInfo m) => QName -> (Definition -> m a) -> m a+inConcreteOrAbstractMode :: (HasConstInfo m) => QName -> (Definition -> m a) -> m a inConcreteOrAbstractMode q cont = do -- Andreas, 2015-07-01: If we do not ignoreAbstractMode here, -- we will get ConcreteDef for abstract things, as they are turned into axioms.@@ -1433,22 +1649,23 @@ PrimitiveSort{} -> 0 AbstractDefn{} -> 0 -- not impossible when quoting, PR #7828 --- | Is it the name of a record projection?+-- | Is it the name of a record projection or field or a projection-like function? {-# SPECIALIZE isProjection :: QName -> TCM (Maybe Projection) #-} isProjection :: HasConstInfo m => QName -> m (Maybe Projection) isProjection qn = isProjection_ . theDef <$> getConstInfo qn +-- | Is it a record projection or field or a projection-like function? isProjection_ :: Defn -> Maybe Projection-isProjection_ def =- case def of+isProjection_ = \case Function { funProjection = Right result } -> Just result _ -> Nothing --- | Is it the name of a non-irrelevant record projection?+-- | Is it the name of a non-irrelevant record projection or field or projection-like function? {-# SPECIALIZE isProjection :: QName -> TCM (Maybe Projection) #-} isRelevantProjection :: HasConstInfo m => QName -> m (Maybe Projection) isRelevantProjection qn = isRelevantProjection_ <$> getConstInfo qn +-- | Is it a non-irrelevant record projection or field or projection-like function? isRelevantProjection_ :: Definition -> Maybe Projection isRelevantProjection_ def = if isIrrelevant def then Nothing else isProjection_ $ theDef def@@ -1465,16 +1682,21 @@ -- i.e., not a projection-like function nor a record field value -- (projection applied to argument). isProperProjection :: Defn -> Bool-isProperProjection d = caseMaybe (isProjection_ d) False $ \ isP ->- (projIndex isP > 0) && isJust (projProper isP)+isProperProjection = maybe False isProperProjection_ . isProjection_ +-- | Returns @True@ if we are dealing with a proper projection,+-- i.e., not a projection-like function nor a record field value+-- (projection applied to argument).+isProperProjection_ :: Projection -> Bool+isProperProjection_ isP = projIndex isP > 0 && isJust (projProper isP)+ -- | Number of dropped initial arguments of a projection(-like) function. projectionArgs :: Definition -> Int projectionArgs = maybe 0 (max 0 . pred . projIndex) . isRelevantProjection_ -- | Check whether a definition uses copatterns.-usesCopatterns :: (HasConstInfo m, HasBuiltins m) => QName -> m Bool-usesCopatterns q = defCopatternLHS <$> getConstInfo q+usesCopatterns :: (HasConstInfo m) => QName -> m Bool+usesCopatterns q = defCopatternLHS q =<< getConstInfo q -- | Apply a function @f@ to its first argument, producing the proper -- postfix projection if @f@ is a projection which is not irrelevant.
src/full/Agda/TypeChecking/Monad/Signature.hs-boot view
@@ -6,15 +6,16 @@ import Control.Monad.State import Agda.Syntax.Abstract.Name (QName)-import Agda.Syntax.Internal (ModuleName, Telescope)+import Agda.Syntax.Common.Pretty (prettyShow)+import Agda.Syntax.Internal (ModuleName, Telescope, RewriteHead) import Agda.TypeChecking.Monad.Base ( TCM, ReadTCState, HasOptions, MonadTCEnv- , Definition, RewriteRules+ , Definition, GlobalRewriteRules, RewriteRules ) import {-# SOURCE #-} Agda.TypeChecking.Monad.Debug (MonadDebug) -import Agda.Syntax.Common.Pretty (prettyShow)+import Agda.Utils.CallStack (HasCallStack) data SigError = SigUnknown String | SigAbstract | SigCubicalNotErasure @@ -26,7 +27,7 @@ , MonadDebug m , MonadTCEnv m ) => HasConstInfo m where- getConstInfo :: QName -> m Definition+ getConstInfo :: HasCallStack => QName -> m Definition getConstInfo q = getConstInfo' q >>= \case Right d -> return d Left (SigUnknown err) -> __IMPOSSIBLE_VERBOSE__ err@@ -35,20 +36,24 @@ Left SigCubicalNotErasure -> __IMPOSSIBLE_VERBOSE__ $ notSoPrettySigCubicalNotErasure q - getConstInfo' :: QName -> m (Either SigError Definition)+ getConstInfo' :: HasCallStack => QName -> m (Either SigError Definition) -- getConstInfo' q = Right <$> getConstInfo q- getRewriteRulesFor :: QName -> m RewriteRules+ getGlobalRewriteRulesFor :: QName -> m GlobalRewriteRules+ getLocalRewriteRulesFor :: RewriteHead -> m RewriteRules - default getConstInfo' :: (HasConstInfo n, MonadTrans t, m ~ t n) => QName -> m (Either SigError Definition)+ default getConstInfo' :: (HasCallStack, HasConstInfo n, MonadTrans t, m ~ t n) => QName -> m (Either SigError Definition) getConstInfo' = lift . getConstInfo' - default getRewriteRulesFor :: (HasConstInfo n, MonadTrans t, m ~ t n) => QName -> m RewriteRules- getRewriteRulesFor = lift . getRewriteRulesFor+ default getGlobalRewriteRulesFor :: (HasConstInfo n, MonadTrans t, m ~ t n) => QName -> m GlobalRewriteRules+ getGlobalRewriteRulesFor = lift . getGlobalRewriteRulesFor + default getLocalRewriteRulesFor :: (HasConstInfo n, MonadTrans t, m ~ t n) => RewriteHead -> m RewriteRules+ getLocalRewriteRulesFor = lift . getLocalRewriteRulesFor+ instance HasConstInfo m => HasConstInfo (ReaderT r m) instance HasConstInfo m => HasConstInfo (StateT s m) instance HasConstInfo TCM where inFreshModuleIfFreeParams :: TCM a -> TCM a-lookupSection :: (Functor m, ReadTCState m) => ModuleName -> m Telescope+lookupSection :: (ReadTCState m) => ModuleName -> m Telescope
src/full/Agda/TypeChecking/Monad/SizedTypes.hs view
@@ -21,7 +21,7 @@ import Agda.TypeChecking.Substitute import Agda.Utils.CallStack-import Agda.Utils.List+import Agda.Utils.Function (iterate') import Agda.Utils.List1 (List1, pattern (:|)) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe@@ -138,7 +138,7 @@ {-# SPECIALIZE sizeType :: TCM Type #-} -- | The built-in type @SIZE@.-sizeType :: (HasBuiltins m, MonadTCEnv m, ReadTCState m) => m Type+sizeType :: (HasBuiltins m) => m Type sizeType = El sizeSort . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSize -- | The name of @SIZESUC@.@@ -155,7 +155,7 @@ | n == 0 = return v | otherwise = do suc <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSizeSuc- return $ fromMaybe __IMPOSSIBLE__ (iterate (sizeSuc_ suc) v !!! n)+ return $ iterate' n (sizeSuc_ suc) v sizeSuc_ :: QName -> Term -> Term sizeSuc_ suc v = Def suc [Apply $ defaultArg v]@@ -178,7 +178,7 @@ data SizeView = SizeInf | SizeSuc Term | OtherSize Term -- | Expects argument to be 'reduce'd.-sizeView :: (HasBuiltins m, MonadTCEnv m, ReadTCState m)+sizeView :: (HasBuiltins m) => Term -> m SizeView sizeView v = do inf <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSizeInf
src/full/Agda/TypeChecking/Monad/State.hs view
@@ -29,28 +29,33 @@ import qualified Agda.Syntax.Concrete.Name as C import Agda.Syntax.Abstract (PatternSynDefn, PatternSynDefns) import Agda.Syntax.Abstract.PatternSynonyms+import Agda.Syntax.TopLevelModuleName+import Agda.Syntax.Common.Pretty 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 -import Agda.TypeChecking.Monad.Debug (reportSDoc, reportSLn, verboseS)+import Agda.TypeChecking.Monad.Debug (reportS, reportSDoc, reportSLn, verboseS) import Agda.TypeChecking.Positivity.Occurrence import Agda.TypeChecking.CompiledClause import qualified Agda.Utils.BiMap as BiMap-import Agda.Utils.FileId ( File, getIdFile, registerFileId' )-import Agda.Utils.Lens import qualified Agda.Utils.List1 as List1+import Agda.Utils.FileId ( File, getIdFile, registerFileId' )+import Agda.Utils.Atomic import Agda.Utils.Maybe import Agda.Utils.Monad-import Agda.Syntax.Common.Pretty import Agda.Utils.Tuple+import Agda.Utils.Lens+import Agda.Utils.Tuple.Strict (Pair(..))+import Agda.Utils.Tuple.Strict qualified as Strict+import Agda.Utils.Maybe.Strict qualified as Strict import Agda.Utils.Impossible+import qualified Control.Monad.Catch as Catch -- | Resets the non-persistent part of the type checking state. @@ -62,26 +67,24 @@ -- Keep only the session state (backend information, 'Benchmark', file ids). resetAllState :: TCM ()-resetAllState = modifyTC \ s -> initStateFromSessionState (s ^. lensSessionState)---- | Overwrite the 'TCState', but not the 'SessionTCState' part.-putTCPreservingSession :: TCState -> TCM ()-putTCPreservingSession = bracket_ get put . putTC where- get = (,) <$> useTC lensSessionState <*> useTC stStatistics+resetAllState = modifyTC \ s -> initStateFromSessionState (stPersistentSession (stPersistentState s)) - put (sess, stat) = do- setTCLens lensSessionState sess- setTCLens stStatistics stat+-- | Set the 'TCState', preserving any parts of the state which should+-- persist through speculation (e.g., statistics).+putTCPreservingStats :: TCState -> TCM ()+putTCPreservingStats = bracket_ get put . putTC where+ get = useTC stStatistics+ put = setTCLens stStatistics -- | Restore 'TCState' after performing subcomputation. ----- In contrast to 'Agda.Utils.Monad.localState', the--- 'SessionTCState' from the subcomputation is saved.+-- Parts of the state which should not be reset on speculation (e.g.,+-- statistics) will not be reset. localTCState :: TCM a -> TCM a-localTCState = bracket_ getTC putTCPreservingSession+localTCState = bracket_ getTC putTCPreservingStats --- | Same as 'localTCState' but also returns the state in which we were just--- before reverting it.+-- | Same as 'localTCState', but also returns the state in which we were+-- just before reverting it. localTCStateSaving :: TCM a -> TCM (a, TCState) localTCStateSaving compute = localTCState $ liftA2 (,) compute getTC @@ -155,16 +158,16 @@ setScope :: ScopeInfo -> TCM () setScope scope = modifyScope (const scope) -{-# INLINE modifyScope_ #-}--- | Modify the current scope without updating the inverse maps.-modifyScope_ :: MonadTCState m => (ScopeInfo -> ScopeInfo) -> m ()-modifyScope_ f = stScope `modifyTCLens` f- {-# INLINE modifyScope #-}--- | Modify the current scope.+-- | Modify the current scope without updating the inverse maps. modifyScope :: MonadTCState m => (ScopeInfo -> ScopeInfo) -> m ()-modifyScope f = modifyScope_ (recomputeInverseScopeMaps . f)+modifyScope f = stScope `modifyTCLens` f +{-# INLINE recomputeInverseScope #-}+-- | Recompute inverse names, inverse modules and InScopeSet-s.+recomputeInverseScope :: MonadTCState m => m ()+recomputeInverseScope = modifyScope recomputeInverseScope'+ {-# INLINE useScope #-} -- | Get a part of the current scope. useScope :: ReadTCState m => Lens' ScopeInfo a -> m a@@ -178,12 +181,12 @@ {-# INLINE withScope #-} -- | Run a computation in a local scope. withScope :: ReadTCState m => ScopeInfo -> m a -> m (a, ScopeInfo)-withScope s m = locallyTCState stScope (recomputeInverseScopeMaps . const s) $ (,) <$> m <*> getScope+withScope s m = locallyTCState stScope (const s) $ (,) <$> m <*> getScope -{-# INLINE withScope_ #-}+{-# INLINE evalWithScope #-} -- | Same as 'withScope', but discard the scope from the computation.-withScope_ :: ReadTCState m => ScopeInfo -> m a -> m a-withScope_ s m = fst <$> withScope s m+evalWithScope :: ReadTCState m => ScopeInfo -> m a -> m a+evalWithScope s m = fst <$> withScope s m -- | Discard any changes to the scope by a computation. localScope :: TCM a -> TCM a@@ -208,7 +211,7 @@ printScope :: String -> Int -> String -> TCM () printScope tag v s = verboseS ("scope." ++ tag) v $ do scope <- getScope- reportSDoc ("scope." ++ tag) v $ return $ vcat [ text s, pretty scope ]+ reportS ("scope." ++ tag) v $ vcat [ text s, pretty scope ] --------------------------------------------------------------------------- -- * Signature@@ -228,6 +231,18 @@ getSignature :: ReadTCState m => m Signature getSignature = useR stSignature +{-# INLINE modifyGlobalSignature #-}+-- | The same caveats as with |modifyGlobalDefinition|, applied changes will not+-- persist outside the current module!+modifyGlobalSignature ::+ MonadTCState m+ => (Signature -> Signature)+ -- ^ Function to map over the signatures+ -> m ()+modifyGlobalSignature f = do+ modifySignature f+ modifyImportedSignature f+ {-# SPECIALIZE modifyGlobalDefinition :: QName -> (Definition -> Definition) -> TCM () #-} -- | Update a possibly imported definition. Warning: changes made to imported -- definitions (during type checking) will not persist outside the current@@ -253,23 +268,62 @@ return r -- ** Modifiers for rewrite rules-addRewriteRulesFor :: QName -> RewriteRules -> [QName] -> Signature -> Signature-addRewriteRulesFor f rews matchables =- over sigRewriteRules (HMap.insertWith mappend f rews)- . updateDefinition f (updateTheDef setNotInjective . setCopatternLHS)- . (setMatchableSymbols f matchables)+addRewriteRulesFor ::+ QName+ -- ^ Head symbol of rewrite rules+ -> GlobalRewriteRules+ -- ^ Rewrite rules+ -> [QName]+ -- ^ Matchable symbols+ -> TCM ()+addRewriteRulesFor f rews matchables = do+ modifySignature $ over sigRewriteRules $ HMap.insertWith mappend f rews+ modifyGlobalSignature $ updateDefinitions $ updateDefsForRewrites f rews matchables++updateDefsForRewrites ::+ QName+ -- ^ Head symbol of rewrite rules+ -> GlobalRewriteRules+ -- ^ Rewrites+ -> [QName]+ -- ^ Matchable symbols+ -> Definitions+ -- ^ Definitions we need to update+ -> Definitions+ -- ^ Updated definitions+updateDefsForRewrites f rews matchables+ = HMap.adjust (updateTheDef setNotInjective . setCopatternLHS) f+ . setMatchableSymbols' f matchables where setNotInjective def@Function{} = def { funInv = NotInjective } setNotInjective def = def setCopatternLHS =- updateDefCopatternLHS (|| any hasProjectionPattern rews)+ updateDefCopatternLHS (|| any grHasProjectionPattern rews) - hasProjectionPattern rew = any (isJust . isProjElim) $ rewPats rew+setMatchableSymbols ::+ QName+ -- ^ Head symbol+ -> [QName]+ -- ^ Matchable symbols+ -> Signature+ -- ^ Current signature+ -> Signature+ -- ^ Updated signature+setMatchableSymbols f matchables+ = updateDefinitions $ setMatchableSymbols' f matchables -setMatchableSymbols :: QName -> [QName] -> Signature -> Signature-setMatchableSymbols f matchables =- foldr ((.) . (\g -> updateDefinition g setMatchable)) id matchables+setMatchableSymbols' ::+ QName+ -- ^ Head symbol+ -> [QName]+ -- ^ Matchable symbols+ -> Definitions+ -- ^ Current definitions+ -> Definitions+ -- ^ Updated definitions+setMatchableSymbols' f matchables =+ foldr ((.) . (\g -> HMap.adjust setMatchable g)) id matchables where setMatchable def = def { defMatchable = Set.insert f $ defMatchable def } @@ -321,7 +375,7 @@ updateCompiledClauses f _ = __IMPOSSIBLE__ updateDefCopatternLHS :: (Bool -> Bool) -> Definition -> Definition-updateDefCopatternLHS f def@Defn{ defCopatternLHS = b } = def { defCopatternLHS = f b }+updateDefCopatternLHS f def@Defn{ defCopatternLHS' = b } = def { defCopatternLHS' = f b } updateDefBlocked :: (Blocked_ -> Blocked_) -> Definition -> Definition updateDefBlocked f def@Defn{ defBlocked = b } = def { defBlocked = f b }@@ -343,14 +397,20 @@ Nothing -> b Just c -> EnumMap.insert fi c b -instance MonadIO m => MonadFileId (TCMT m) where- fileFromId fi = useTC stFileDict <&> (`getIdFile` fi)- idFromFile = stateTCLens stFileDict . registerFileIdWithBuiltin+instance (MonadIO m, Catch.MonadMask m) => MonadFileId (TCMT m) where+ fileFromId fi = useSession lensFileDict <&> (`getIdFile` fi)+ idFromFile = stateSessionLens lensFileDict . registerFileIdWithBuiltin +instance MonadFileId ReduceM where+ fileFromId fi = useSession lensFileDict <&> (`getIdFile` fi)+ idFromFile = __IMPOSSIBLE__+ -- we cannot write to the state here, so we cannot do sth like+ -- stateTCLens stFileDict . registerFileIdWithBuiltin+ -- | Does the given 'FileId' belong to one of Agda's builtin modules? isBuiltinModule :: ReadTCState m => FileId -> m (Maybe IsBuiltinModule)-isBuiltinModule fi = EnumMap.lookup fi <$> useTC stBuiltinModuleIds+isBuiltinModule fi = EnumMap.lookup fi <$> useSession lensBuiltinModuleIds -- | Does the given 'FileId' belong to one of Agda's builtin modules that only uses safe postulates? --@@ -362,19 +422,19 @@ Nothing -> False Just IsBuiltinModule -> False Just IsBuiltinModuleWithSafePostulates -> True- Just IsPrimitiveModule -> True+ Just IsAgdaPrimitive -> True+ Just IsAgdaPrimitiveCubical -> True --- | Does the given 'FileId' belong to one of Agda's magical primitive modules?------ Implies 'isBuiltinModuleWithSafePostulates'.+-- | Is the current module, if any, a builtin module that only uses+-- safe postulates? -isPrimitiveModule :: ReadTCState m => FileId -> m Bool-isPrimitiveModule fi = do- isBuiltinModule fi <&> \case- Nothing -> False- Just IsBuiltinModule -> False- Just IsBuiltinModuleWithSafePostulates -> False- Just IsPrimitiveModule -> True+currentModuleIsBuiltinModuleWithSafePostulates ::+ ReadTCState m => m Bool+currentModuleIsBuiltinModuleWithSafePostulates = do+ f <- useTC stFileId+ case f of+ Strict.Nothing -> return False+ Strict.Just f -> isBuiltinModuleWithSafePostulates f --------------------------------------------------------------------------- -- * Top level module@@ -385,15 +445,13 @@ topLevelModuleName :: RawTopLevelModuleName -> TCM TopLevelModuleName topLevelModuleName raw = do- hash <- BiMap.lookup raw <$> useR stTopLevelModuleNames- case hash of+ (BiMap.lookup raw <$> useR stTopLevelModuleNames) >>= \case Just hash -> return (unsafeTopLevelModuleName raw hash) Nothing -> do let hash = hashRawTopLevelModuleName raw when (hash == noModuleNameHash) $ typeError $ ModuleNameHashCollision raw Nothing- raw' <- BiMap.invLookup hash <$> useR stTopLevelModuleNames- case raw' of- Just raw' -> typeError $ ModuleNameHashCollision raw (Just raw')+ (BiMap.invLookup hash <$> useR stTopLevelModuleNames) >>= \case+ raw'@Just{} -> typeError $ ModuleNameHashCollision raw raw' Nothing -> do stTopLevelModuleNames `modifyTCLens'` BiMap.insert (killRange raw) hash@@ -421,8 +479,8 @@ (MonadTCEnv m, ReadTCState m) => m (Maybe TopLevelModuleName) currentTopLevelModule = do useR stCurrentModule >>= \case- Just (_, top) -> return (Just top)- Nothing -> listToMaybe <$> asksTC envImportPath+ Strict.Just (_ :!: top) -> return (Just top)+ Strict.Nothing -> listToMaybe <$> viewTC eImportStack -- | Use a different top-level module for a computation. Used when generating -- names for imported modules.@@ -444,6 +502,14 @@ NameId _ h <- useTC stFreshNameId return h +-- | Get a function that completes 'TopLevelModuleName's+-- with their 'SourceFile' to 'TopLevelModuleNameWithSourceFile's.+topLevelModuleNameWithSourceFileCompleter :: ReadTCState m+ => m (TopLevelModuleName -> TopLevelModuleNameWithSourceFile)+topLevelModuleNameWithSourceFileCompleter = do+ ModuleToSource _dict m2s <- useSession lensModuleToSource+ return \ m -> TopLevelModuleNameWithSourceFile m $ Map.findWithDefault __IMPOSSIBLE__ m m2s+ --------------------------------------------------------------------------- -- * Backends and foreign code ---------------------------------------------------------------------------@@ -451,14 +517,14 @@ -- | Look for a backend of the given name. lookupBackend :: ReadTCState m => BackendName -> m (Maybe Backend)-lookupBackend name = useTC stBackends <&> \ backends ->+lookupBackend name = useSession lensBackends <&> \ backends -> listToMaybe [ b | b@(Backend b') <- backends, backendName b' == name ] -- | Get the currently active backend (if any). activeBackend :: TCM (Maybe Backend) activeBackend = runMaybeT $ do- bname <- MaybeT $ asksTC envActiveBackendName+ bname <- MaybeT $ viewTC eActiveBackendName lift $ fromMaybe __IMPOSSIBLE__ <$> lookupBackend bname -- | Ask the active backend whether a type may be erased.@@ -471,7 +537,7 @@ addForeignCode :: BackendName -> String -> TCM () addForeignCode backend code = do- r <- asksTC envRange -- can't use TypeChecking.Monad.Trace.getCurrentRange without cycle+ r <- viewTC eRange -- can't use TypeChecking.Monad.Trace.getCurrentRange without cycle modifyTCLens (stForeignCode . key backend) $ Just . ForeignCodeStack . (ForeignCode r code :) . maybe [] getForeignCodeStack @@ -479,17 +545,15 @@ -- * Interaction output callback --------------------------------------------------------------------------- +{-# INLINE getInteractionOutputCallback #-} getInteractionOutputCallback :: ReadTCState m => m InteractionOutputCallback-getInteractionOutputCallback- = getsTC $ stInteractionOutputCallback . stPersistentState+getInteractionOutputCallback = useSession lensInteractionOutputCallback appInteractionOutputCallback :: Response -> TCM ()-appInteractionOutputCallback r- = getInteractionOutputCallback >>= \ cb -> cb r+appInteractionOutputCallback r = getInteractionOutputCallback >>= \ cb -> cb r setInteractionOutputCallback :: InteractionOutputCallback -> TCM ()-setInteractionOutputCallback cb- = modifyPersistentState $ \ s -> s { stInteractionOutputCallback = cb }+setInteractionOutputCallback = setSession lensInteractionOutputCallback --------------------------------------------------------------------------- -- * Pattern synonyms@@ -513,7 +577,8 @@ getAllPatternSyns = Map.union <$> getPatternSyns <*> getPatternSynImports lookupPatternSyn :: AmbiguousQName -> TCM PatternSynDefn-lookupPatternSyn (AmbQ xs) = do+lookupPatternSyn ambX = do+ let xs = getAmbiguous ambX defs <- traverse lookupSinglePatternSyn xs case mergePatternSynDefs defs of Just def -> return def@@ -554,7 +619,7 @@ -- | Remove an instance from the set of unresolved instances. clearUnknownInstance :: QName -> TCM ()-clearUnknownInstance q = modifyInstanceDefs $ mapSnd $ Set.delete q+clearUnknownInstance q = modifyInstanceDefs $ second $ Set.delete q -- | Add an instance whose type is still unresolved. addUnknownInstance :: QName -> TCM ()@@ -562,4 +627,4 @@ reportSLn "tc.decl.instance" 10 $ "adding definition " ++ prettyShow x ++ " to the instance table (the type is not yet known)"- modifyInstanceDefs $ mapSnd $ Set.insert x+ modifyInstanceDefs $ second $ Set.insert x
+ src/full/Agda/TypeChecking/Monad/State.hs-boot view
@@ -0,0 +1,7 @@+module Agda.TypeChecking.Monad.State where++import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Catch+import Agda.TypeChecking.Monad.Base (MonadFileId, TCMT)++instance (MonadIO m, MonadMask m) => MonadFileId (TCMT m)
src/full/Agda/TypeChecking/Monad/Statistics.hs view
@@ -3,44 +3,56 @@ -- | Collect statistics. module Agda.TypeChecking.Monad.Statistics- ( MonadStatistics(..), tick, tickN, tickMax, getStatistics, modifyStatistics, printStatistics- ) where+ ( MonadStatistics(..), tick, getStatistics, modifyStatistics, printStatistics+ ) where -import Control.DeepSeq-import Control.Monad.Except-import Control.Monad.Reader-import Control.Monad.State-import Control.Monad.Writer-import Control.Monad.Trans.Maybe+import Control.DeepSeq ( NFData(rnf) )+import Control.Monad.Except ( ExceptT )+import Control.Monad.Reader ( ReaderT )+import Control.Monad.State ( StateT )+import Control.Monad.Writer ( WriterT )+import Control.Monad.Trans.Class ( MonadTrans(lift) )+import Control.Monad.Trans.Maybe ( MaybeT ) -import qualified Data.Map as Map+import qualified Data.HashMap.Strict as HMap+import Data.Semigroup ( Max(..), Sum(..) )+import Data.Coerce ( coerce )++import Data.List ( sortOn )+import Data.Word ( Word64 )+ import qualified Text.PrettyPrint.Boxes as Boxes import Agda.TypeChecking.Monad.Base-import Agda.TypeChecking.Monad.Debug+import Agda.TypeChecking.Monad.Debug ( MonadDebug, alwaysReportSLn ) -import Agda.Utils.Maybe-import Agda.Utils.Null-import Agda.Syntax.Common.Pretty-import Agda.Utils.String+import Agda.Syntax.Common.Pretty ( prettyShow )+import Agda.Utils.String ( showThousandSep )+import Agda.Utils.Maybe ( caseMaybe )+import Agda.Utils.Null ( unlessNull )+import Agda.Utils.StrictReader qualified as Strict class ReadTCState m => MonadStatistics m where- modifyCounter :: String -> (Integer -> Integer) -> m ()+ tickN :: String -> Word64 -> m ()+ tickMax :: String -> Word64 -> m () - default modifyCounter- :: (MonadStatistics n, MonadTrans t, t n ~ m)- => String -> (Integer -> Integer) -> m ()- modifyCounter x = lift . modifyCounter x+ default tickN :: (MonadStatistics n, MonadTrans t, t n ~ m) => String -> Word64 -> m ()+ tickN x = lift . tickN x + default tickMax :: (MonadStatistics n, MonadTrans t, t n ~ m) => String -> Word64 -> m ()+ tickMax x = lift . tickMax x+ instance MonadStatistics m => MonadStatistics (ExceptT e m) instance MonadStatistics m => MonadStatistics (MaybeT m) instance MonadStatistics m => MonadStatistics (ReaderT r m)+instance MonadStatistics m => MonadStatistics (Strict.ReaderT r m) instance MonadStatistics m => MonadStatistics (StateT s m) instance (MonadStatistics m, Monoid w) => MonadStatistics (WriterT w m) instance MonadStatistics TCM where- modifyCounter x f = modifyStatistics $ force . update- where+ tickN x n = modifyStatistics \case+ Statistics a b ->+ let a' = HMap.insertWith (<>) x (Sum n) a -- We need to be strict in the map. -- Andreas, 2014-03-22: Could we take Data.Map.Strict instead of this hack? -- Or force the map by looking up the very element we inserted?@@ -52,41 +64,45 @@ -- map (nor are they less hacky). It's not enough to be strict in the -- values stored in the map, we also need to be strict in the *structure* -- of the map. A less hacky solution is to deepseq the map.- force m = rnf m `seq` m- update = Map.insertWith (\ new old -> f old) x dummy- dummy = f 0+ in rnf a' `seq` Statistics a' b + tickMax x n = modifyStatistics \case+ Statistics a b ->+ let b' = HMap.insertWith (<>) x (Max n) b+ in rnf b' `seq` Statistics a b'+ -- | Get the statistics. getStatistics :: ReadTCState m => m Statistics getStatistics = useR stStatistics -- | Modify the statistics via given function. modifyStatistics :: (Statistics -> Statistics) -> TCM ()-modifyStatistics f = stStatistics `modifyTCLens` f+modifyStatistics f = stStatistics `modifyTCLens'` f -- | Increase specified counter by @1@. tick :: MonadStatistics m => String -> m () tick x = tickN x 1 --- | Increase specified counter by @n@.-tickN :: MonadStatistics m => String -> Integer -> m ()-tickN s n = modifyCounter s (n +)---- | Set the specified counter to the maximum of its current value and @n@.-tickMax :: MonadStatistics m => String -> Integer -> m ()-tickMax s n = modifyCounter s (max n)- -- | Print the given statistics. printStatistics- :: (MonadDebug m, MonadTCEnv m, HasOptions m)+ :: (MonadDebug m) => 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]+printStatistics mmname (Statistics tick max) = do+ let+ counters :: [(String, Word64)]+ counters = sortOn fst $ HMap.toList (coerce tick) <> HMap.toList (coerce max)++ unlessNull counters $ \ 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]+ alwaysReportSLn "" 1 $ caseMaybe mmname "Accumulated statistics" $ \ mname -> "Statistics for " ++ prettyShow mname+ alwaysReportSLn "" 1 $ Boxes.render table
src/full/Agda/TypeChecking/Monad/Trace.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wunused-imports #-}+{-# LANGUAGE MagicHash #-} module Agda.TypeChecking.Monad.Trace where @@ -32,6 +33,10 @@ import Agda.Utils.Monad import Agda.Utils.Null +import Agda.Utils.StrictReader qualified as Strict+import Agda.Utils.StrictWriter qualified as Strict+import Agda.Utils.StrictState qualified as Strict+ --------------------------------------------------------------------------- -- * Trace ---------------------------------------------------------------------------@@ -64,6 +69,7 @@ CheckRecDef{} -> True CheckConstructor{} -> True CheckIApplyConfluence{} -> True+ CheckLocalRewriteConstraint{} -> True CheckConArgFitsIn{} -> True CheckFunDefCall{} -> True CheckPragma{} -> True@@ -82,15 +88,18 @@ class (MonadTCEnv m, ReadTCState m) => MonadTrace m where + {-# INLINE traceCall #-} -- | Record a function call in the trace. traceCall :: Call -> m a -> m a traceCall call m = do cl <- buildClosure call traceClosureCall cl m + {-# INLINE traceCallM #-} traceCallM :: m Call -> m a -> m a traceCallM call m = flip traceCall m =<< call + {-# INLINE traceCallCPS #-} -- | Like 'traceCall', but resets 'envCall' and the current ranges to the -- previous values in the continuation. --@@ -98,14 +107,16 @@ traceCallCPS call k ret = do -- Save current call and ranges.- TCEnv{ envCall = mcall, envRange = r, envHighlightingRange = hr } <- askTC+ e <- askTC+ let mcall = e ^. eCall+ r = e ^. eRange+ hr = e ^. eHighlightingRange -- Run given computation under given call.- traceCall call $ k $ \ a -> do+ traceCall call $ k $ \a -> do -- Restore previous call and ranges for the continuation.- localTC (\ e -> e{ envCall = mcall, envRange = r, envHighlightingRange = hr }) $- ret a+ localTC (set eCall mcall . set eRange r . set eHighlightingRange hr) $ ret a traceClosureCall :: Closure Call -> m a -> m a @@ -135,6 +146,15 @@ instance (MonadTrace m, Monoid w) => MonadTrace (WriterT w m) where traceClosureCall c f = WriterT $ traceClosureCall c $ runWriterT f +instance MonadTrace m => MonadTrace (Strict.ReaderT r m) where+ traceClosureCall c f = Strict.ReaderT $ \r -> traceClosureCall c $ Strict.runReaderT f r++instance MonadTrace m => MonadTrace (Strict.StateT s m) where+ traceClosureCall c f = Strict.StateT (traceClosureCall c . Strict.runStateT# f)++instance (MonadTrace m, Monoid w) => MonadTrace (Strict.WriterT w m) where+ traceClosureCall c (Strict.WriterT f) = Strict.WriterT $ traceClosureCall c f+ instance MonadTrace m => MonadTrace (ExceptT e m) where traceClosureCall c f = ExceptT $ traceClosureCall c $ runExceptT f @@ -147,19 +167,16 @@ -- Compute update to 'Range' and 'Call' components of 'TCEnv'. let withCall = localTC $ foldr (.) id $ concat $- [ [ \e -> e { envCall = Just cl } | interestingCall call ]- , [ \e -> e { envHighlightingRange = callRange }- | callHasRange && highlightCall- || isNoHighlighting- ]- , [ \e -> e { envRange = callRange } | callHasRange ]+ [ [ set eCall (Just cl) | interestingCall call ]+ , [ set eHighlightingRange callRange | callHasRange && highlightCall || isNoHighlighting ]+ , [ set eRange callRange | callHasRange ] ] -- For interactive highlighting, also wrap computation @m@ in 'highlightAsTypeChecked':- ifNotM (pure highlightCall `and2M` do (Interactive ==) . envHighlightingLevel <$> askTC)+ ifNotM (pure highlightCall `and2M` (Interactive ==) <$> viewTC eHighlightingLevel) {-then-} (withCall m) {-else-} $ do- oldRange <- envHighlightingRange <$> askTC+ oldRange <- viewTC eHighlightingRange highlightAsTypeChecked oldRange callRange $ withCall m where@@ -189,12 +206,13 @@ CheckRecDef{} -> True CheckConstructor{} -> True CheckConArgFitsIn{} -> False- CheckFunDefCall _ _ _ h -> h+ CheckFunDefCall _ _ h -> h CheckPragma{} -> True CheckPrimitive{} -> True CheckIsEmpty{} -> True CheckConfluence{} -> False CheckIApplyConfluence{} -> False+ CheckLocalRewriteConstraint{} -> False CheckModuleParameters{} -> False CheckWithFunctionType{} -> True CheckSectionApplication{} -> True@@ -212,9 +230,9 @@ _ -> False printHighlightingInfo remove info = do- modToSrc <- useTC stModuleToSource+ modToSrc <- useSession lensModuleToSource method <- viewTC eHighlightingMethod- reportSDoc "highlighting" 50 $ pure $ vcat+ reportSDoc "highlighting" 90 $ pure $ vcat [ "Printing highlighting info:" , nest 2 $ (text . show) info , "File modules:"@@ -222,11 +240,11 @@ ] unless (null info) $ do appInteractionOutputCallback $- Resp_HighlightingInfo info remove method modToSrc+ Resp_HighlightingInfo info remove method modToSrc Nothing getCurrentRange :: MonadTCEnv m => m Range-getCurrentRange = asksTC envRange+getCurrentRange = viewTC eRange -- | Sets the current range (for error messages etc.) to the range -- of the given object, if it has a range (i.e., its range is not 'noRange').
src/full/Agda/TypeChecking/Names.hs view
@@ -50,6 +50,7 @@ , MonadIO , HasOptions , MonadDebug+ , MonadFileId , MonadTCEnv , MonadTCState , MonadTCM@@ -193,8 +194,7 @@ => List1 ArgName -> (Vars1 m -> NamesT m a) -> NamesT m (AbsN a) bindN1 (x :| xs) f = toAbsN <$> bind x (\ x -> bindN xs (\ xs -> f (x :| xs))) -glamN :: (Functor m, Monad m) =>- [Arg ArgName] -> (NamesT m Args -> NamesT m Term) -> NamesT m Term+glamN :: (Monad 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))
src/full/Agda/TypeChecking/Opacity.hs view
@@ -32,13 +32,14 @@ import Agda.TypeChecking.Monad import Agda.Utils.Impossible-import Agda.Utils.Monad import Agda.Utils.Lens+import Agda.Utils.List+import Agda.Utils.Monad -- | Ensure that opaque blocks defined in the current module have -- saturated unfolding sets. saturateOpaqueBlocks- :: forall m. (MonadTCState m, ReadTCState m, MonadFresh OpaqueId m, MonadDebug m, MonadTrace m, MonadWarning m, MonadIO m)+ :: forall m. (MonadTCState m, MonadFresh OpaqueId m, MonadTrace m, MonadWarning m, MonadIO m) => m () saturateOpaqueBlocks = entry where entry = do@@ -46,7 +47,7 @@ inverse <- useTC stOpaqueIds OpaqueId _ ourmod <- fresh - canonical <- useTC stCopiedNames+ canonical <- useTC stCopiedNames backcopies <- useTC stNameCopies reportSDoc "tc.opaque.copy" 45 $ "Canonical names of copied definitions:" $+$ pretty (HashMap.toList canonical)@@ -78,10 +79,7 @@ reportSDoc "tc.opaque.sat.full" 50 $ text "Saturated opaque blocks:" $+$ pretty blocks - modifyTC' $ \st -> st { stPostScopeState = (stPostScopeState st)- { stPostOpaqueBlocks = blocks- , stPostOpaqueIds = names'- } }+ modifyTC' (set stOpaqueBlocks blocks . set stOpaqueIds names') -- Actually compute the closure. computeClosure@@ -155,13 +153,13 @@ -- getting the original definition (for inConcreteOrAbstractMode), and -- for "normalise ignoring abstract" interactively. isAccessibleDef env state defn- | envAbstractMode env == IgnoreAbstractMode = True+ | (env ^. eAbstractMode) == IgnoreAbstractMode = True -- Otherwise, actually apply the reducibility rules.. isAccessibleDef env state defn = let -- Reducibility rules for abstract definitions:- concretise def = case envAbstractMode env of+ concretise def = case env ^. eAbstractMode of -- Being outside an abstract block has no effect on concreteness ConcreteMode -> def @@ -169,21 +167,25 @@ -- figure it out: IgnoreAbstractMode -> ConcreteDef - AbstractMode- -- Symbols from enclosing modules will be made concrete:- | current `isLeChildModuleOf` m -> ConcreteDef+ AbstractMode -> let+ dropLastModule (MName ms) = MName $ initWithDefault __IMPOSSIBLE__ ms - -- Symbols from child modules, or unrelated modules, will keep- -- the same concreteness:- | otherwise -> def- where- current = dropAnon $ envCurrentModule env- m = dropAnon $ qnameModule (defName defn)- dropAnon (MName ms) = MName $ List.dropWhileEnd isNoName ms+ current = dropAnonymousModules $ env ^. eCurrentModule + modname = case theDef defn of+ -- Hack to make abstract constructors work properly. The constructors+ -- live in a module with the same name as the datatype, but for 'abstract'+ -- purposes they're considered to be in the same module as the datatype.+ Constructor{} -> dropAnonymousModules $ dropLastModule $ qnameModule $ defName defn+ _ -> dropAnonymousModules $ qnameModule $ defName defn++ in if current `isLeChildModuleOf` modname+ then ConcreteDef+ else def+ -- Reducibility rule for opaque definitions: If we are operating -- under an unfolding block,- clarify def = case envCurrentOpaqueId env of+ clarify def = case env ^. eCurrentOpaqueId of Just oid -> let block = fromMaybe __IMPOSSIBLE__ $ Map.lookup oid (view stOpaqueBlocks state)@@ -205,7 +207,7 @@ -- | Will the given 'QName' have a proper definition, or will it be -- wrapped in an 'AbstractDefn'? hasAccessibleDef- :: (ReadTCState m, MonadTCEnv m, HasConstInfo m) => QName -> m Bool+ :: (ReadTCState m, HasConstInfo m) => QName -> m Bool hasAccessibleDef qn = do env <- askTC st <- getTCState
src/full/Agda/TypeChecking/Opacity.hs-boot view
@@ -10,4 +10,4 @@ isAccessibleDef :: TCEnv -> TCState -> Definition -> Bool hasAccessibleDef- :: (ReadTCState m, MonadTCEnv m, HasConstInfo m) => QName -> m Bool+ :: (ReadTCState m, HasConstInfo m) => QName -> m Bool
src/full/Agda/TypeChecking/Patterns/Abstract.hs view
@@ -67,7 +67,7 @@ expandPatternSynonyms' = postTraverseAPatternM $ \case A.PatternSynP i x as -> setCurrentRange i $ do- (ns, p) <- killRange <$> lookupPatternSyn x+ A.PatternSynDefn ns p <- killRange <$> lookupPatternSyn x -- Andreas, 2020-02-11, issue #3734 -- If lookup of ambiguous pattern synonym was successful,@@ -76,7 +76,7 @@ -- This is less than optimal, since we do not rule out -- the invalid alternatives by typing, but we cannot do -- better here.- mapM_ raiseWarningsOnUsage $ A.unAmbQ x+ mapM_ raiseWarningsOnUsage $ A.getAmbiguous x -- Must expand arguments before instantiating otherwise pattern -- synonyms could get into dot patterns (which is __IMPOSSIBLE__).
src/full/Agda/TypeChecking/Patterns/Match.hs view
@@ -12,13 +12,14 @@ import qualified Data.IntMap as IntMap import Agda.Syntax.Common+import qualified Agda.Syntax.Common.Pretty as P import Agda.Syntax.Internal import Agda.Syntax.Internal.Pattern import Agda.TypeChecking.Reduce import Agda.TypeChecking.Reduce.Monad import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Monad hiding (constructorForm)+import Agda.TypeChecking.Monad import Agda.TypeChecking.Monad.Builtin (getName', builtinHComp) import Agda.TypeChecking.Pretty import Agda.TypeChecking.Records@@ -34,18 +35,28 @@ import Agda.Utils.Impossible --- | If matching is inconclusive (@DontKnow@) we want to know whether it is on a--- lazy pattern and whether it is due to a particular meta variable.-data Match a = Yes Simplification (IntMap (Arg a))- | No- | DontKnow OnlyLazy (Blocked ())- deriving Functor+-- | Result of matching a pattern against a term.+data Match a+ = Yes Simplification (IntMap (Arg a))+ -- ^ Matches with the given substitution for the pattern variables.+ | No MatchPrio+ -- ^ Mismatch where the constructor/literal pattern has the given priority.+ | DontKnow MatchPrio OnlyLazy (Blocked ())+ -- ^ Stuck where the constructor/literal pattern has the given priority.+ -- If matching is inconclusive we also want to know whether it is on a+ -- lazy pattern and whether it is due to a particular meta variable.+ deriving (Show, Functor) instance Null (Match a) where empty = Yes empty empty null (Yes simpl as) = null simpl && null as null _ = False +instance P.Pretty a => P.Pretty (Match a) where+ pretty (Yes simp xs) = "Yes" P.<+> P.pretty (IntMap.toList xs)+ pretty (No _) = "No"+ pretty (DontKnow _ _ b) = "DontKnow" P.<+> P.pretty b+ matchedArgs :: Empty -> Int -> IntMap (Arg a) -> [Arg a] matchedArgs err n vs = map (fromMaybe (absurd err)) $ matchedArgs' n vs @@ -61,18 +72,30 @@ where cons Nothing = strengthenS' err 1 cons (Just v) = consS (unArg v) -+-- | Combining match results.+-- When combining 'No' and 'DontKnow', the lower priority wins!+-- See issue #3054 / #8559. instance Semigroup (Match a) where+ m <> m' = case (m, m') of -- @NotBlocked (StuckOn e)@ means blocked by a variable. -- In this case, no instantiation of meta-variables will make progress.- DontKnow l b <> DontKnow l' b' = DontKnow (l <> l') (b <> b')- DontKnow l m <> _ = DontKnow l m- _ <> DontKnow l m = DontKnow l m- -- One could imagine DontKnow _ _ <> No = No, but would break the- -- equivalence to case-trees (Issue 2964).- No <> _ = No- _ <> No = No- Yes s us <> Yes s' vs = Yes (s <> s') (us <> vs)+ (DontKnow p l b , DontKnow p' l' b' ) -> DontKnow (p <> p') (l <> l') (b <> b')+ (DontKnow{} , Yes{} ) -> m+ -- Issue #7181: Whatever splitting order we decide on, non-lazy matches will+ -- happen before lazy ones. Hence if one pattern is blocked on a lazy match+ -- and another pattern is negative, it is safe to assume the overall match+ -- is negative.+ (DontKnow p l _ , No p' ) -> if | OnlyLazy <- l -> m'+ | p < p' -> m+ | otherwise -> m'+ (Yes{} , DontKnow{} ) -> m'+ (No p , DontKnow p' l _ ) -> if | OnlyLazy <- l -> m+ | p' < p -> m'+ | otherwise -> m+ (No p , No p' ) -> No (p <> p')+ (No{} , Yes{} ) -> m+ (Yes{} , No{} ) -> m'+ (Yes s us , Yes s' vs ) -> Yes (s <> s') (us <> vs) instance Monoid (Match a) where mempty = empty@@ -80,6 +103,7 @@ -- | Whether the inconclusive matches are only on lazy patterns. data OnlyLazy = OnlyLazy | NonLazy+ deriving (Show) instance Semigroup OnlyLazy where NonLazy <> _ = NonLazy@@ -120,8 +144,8 @@ (p : ps, v : vs) -> do (r, v') <- match p v case r of- No | Just{} <- isProjP p -> return (No, v' : vs)- No -> do+ No prio | Just{} <- isProjP p -> return (No prio, v' : vs)+ No _ -> do -- Issue 2964: Even when the first pattern doesn't match we should -- continue to the next patterns (and potentially block on them) -- because the splitting order in the case tree may not be@@ -131,10 +155,10 @@ -- contain ill-typed terms due to eta-expansion at wrong -- type. return (r <> r', v' : vs)- DontKnow OnlyLazy _ -> do+ DontKnow _ OnlyLazy _ -> do (r', _vs') <- loop ps vs return (r <> r', v' : vs)- DontKnow NonLazy m -> return (DontKnow NonLazy m, v' : vs)+ DontKnow prio NonLazy m -> return (DontKnow prio NonLazy m, v' : vs) Yes{} -> do (r', vs') <- loop ps vs return (r <> r', v' : vs')@@ -176,7 +200,7 @@ , nest 2 $ "vs =" <+> fsep (punctuate comma $ map prettyTCM vs) ]) $ do -- Buggy, see issue 1124:- -- mapFst mconcat . unzip <$> zipWithM' (matchCopattern . namedArg) ps vs+ -- first mconcat . unzip <$> zipWithM' (matchCopattern . namedArg) ps vs foldMatch (matchCopattern . namedArg) ps vs -- | Match a single copattern.@@ -190,12 +214,12 @@ _ -> __IMPOSSIBLE__ q <- getOriginalProjection q return $ if p == q then (Yes YesSimplification empty, elim)- else (No, elim)+ else (No empty, elim) -- The following two cases are not impossible, see #2964-matchCopattern ProjP{} elim@Apply{} = return (No , elim)-matchCopattern _ elim@Proj{} = return (No , elim)-matchCopattern p (Apply v) = mapSnd Apply <$> matchPattern p v-matchCopattern p e@(IApply x y r) = mapSnd (mergeElim e) <$> matchPattern p (defaultArg r)+matchCopattern ProjP{} elim@Apply{} = return (No empty, elim)+matchCopattern _ elim@Proj{} = return (No empty, elim)+matchCopattern p (Apply v) = second Apply <$> matchPattern p v+matchCopattern p e@(IApply x y r) = second (mergeElim e) <$> matchPattern p (defaultArg r) {-# SPECIALIZE matchPatterns :: [NamedArg DeBruijnPattern] -> [Arg Term] -> TCM (Match Term, [Arg Term]) #-} matchPatterns :: MonadMatch m@@ -211,8 +235,8 @@ traceSDoc "tc.match" 50 (vcat [ "matchPatterns"- , nest 2 $ "ps =" <+> fsep (punctuate comma $ map (text . show) ps)- , nest 2 $ "vs =" <+> fsep (punctuate comma $ map prettyTCM vs)+ , nest 2 $ "ps =" <+> fsep (punctuate comma $ map pretty ps)+ , nest 2 $ "vs =" <+> fsep (punctuate comma $ map pretty vs) ]) $ do -- Buggy, see issue 1124: -- (ms,vs) <- unzip <$> zipWithM' (matchPattern . namedArg) ps vs@@ -224,30 +248,31 @@ => DeBruijnPattern -> Arg Term -> m (Match Term, Arg Term)-matchPattern p u = case (p, u) of+matchPattern p u = debugMatchPattern $ case (p, u) of (ProjP{}, _ ) -> __IMPOSSIBLE__ (IApplyP _ _ _ x , arg ) -> return (Yes NoSimplification entry, arg) where entry = singleton (dbPatVarIndex x, arg) (VarP _ x , arg ) -> return (Yes NoSimplification entry, arg) where entry = singleton (dbPatVarIndex x, arg) (DotP _ _ , arg@(Arg _ v)) -> return (Yes NoSimplification empty, arg)- (LitP _ l , arg@(Arg _ v)) -> do+ (LitP LitPatternInfo{ litPPrio = prio } l , arg@(Arg _ v)) -> do w <- reduceB v let arg' = arg $> ignoreBlocking w case w of NotBlocked _ (Lit l')- | l == l' -> return (Yes YesSimplification empty , arg')- | otherwise -> return (No , arg')- Blocked b _ -> return (DontKnow NonLazy $ Blocked b () , arg')- NotBlocked r t -> return (DontKnow NonLazy $ NotBlocked r' () , arg')+ | l == l' -> return (Yes YesSimplification empty , arg')+ | otherwise -> return (No prio , arg')+ Blocked b _ -> return (DontKnow prio NonLazy $ Blocked b () , arg')+ NotBlocked r t -> return (DontKnow prio NonLazy $ NotBlocked r' () , arg') where r' = stuckOn (Apply arg') r -- Case constructor pattern. (ConP c cpi ps, Arg info v) -> do+ let prio = conPPrio cpi let lazy = if conPLazy cpi then OnlyLazy else NonLazy- if not (conPRecord cpi) then fallback c lazy ps (Arg info v) else do+ if not (conPRecord cpi) then fallback c prio lazy ps (Arg info v) else do isEtaRecordConstructor (conName c) >>= \case- Nothing -> fallback c lazy ps (Arg info v)+ Nothing -> fallback c prio lazy ps (Arg info v) -- Case: Eta record constructor. -- This case is necessary if we want to use the clauses before -- record pattern translation (e.g., in type-checking definitions by copatterns).@@ -262,48 +287,60 @@ -- `v` might be an application of a *different* constructor. -- In that case we certainly have no match. case v of- Con c' _ _ | c /= c' -> return (No, u)+ Con c' _ _ | c /= c' -> return (No prio, u) _ -> do let fs = map argFromDom $ _recFields def unless (size fs == size ps) __IMPOSSIBLE__- mapSnd (Arg info . Con c (fromConPatternInfo cpi) . map Apply) <$> do+ second (Arg info . Con c (fromConPatternInfo cpi) . map Apply) <$> do matchPatterns ps $ for fs $ \ (Arg ai f) -> Arg ai $ v `applyE` [Proj ProjSystem f] (DefP o q ps, v) -> do let f (Def q' vs) | q == q' = Just (Def q, vs) f _ = Nothing- fallback' f NonLazy ps v+ fallback' f empty NonLazy ps v where+ debugMatchPattern go = do+ reportSDoc "tc.match" 20 $+ vcat [ "matchPattern"+ , nest 2 $ "p =" <+> prettyTCM p+ , nest 2 $ "u =" <+> prettyTCM u+ ]+ reportSDoc "tc.match" 60 $+ vcat [ nest 2 $ "p (raw) =" <+> pretty p+ ]+ (m, t) <- go+ reportSDoc "tc.match" 60 $+ vcat [ nest 2 $ "result = " <+> pretty m ]+ -- reportSDoc "tc.match" 20 $+ -- vcat [ nest 2 $ "result = " <+> prettyTCM m ]+ return (m, t)+ -- Default: not an eta record constructor. fallback :: MonadMatch m- => ConHead -> OnlyLazy -> [NamedArg DeBruijnPattern] -> Arg Term -> m (Match Term, Arg Term)- fallback c lazy ps v = do+ => ConHead -> MatchPrio -> OnlyLazy -> [NamedArg DeBruijnPattern] -> Arg Term -> m (Match Term, Arg Term)+ fallback c prio lazy ps v = do let f (Con c' ci' vs) | c == c' = Just (Con c' ci',vs) f _ = Nothing- fallback' f lazy ps v+ fallback' f prio lazy ps v - -- Regardless of blocking, constructors and a properly applied @hcomp@- -- can be matched on.- isMatchable' :: HasBuiltins m => m (Blocked Term -> Maybe Term)- isMatchable' = do- mhcomp <- getName' builtinHComp- return $ \ r ->+ -- Regardless of blocking, constructors can be matched on.+ -- Since hcomp clauses are only computed during coverage checking+ -- and clause-based reduction is only used *before* coverage checking,+ -- we do not consider hcomp patterns here (see issue #8700).+ isMatchable :: Blocked Term -> Maybe Term+ isMatchable r = case ignoreBlocking r of t@Con{} -> Just t- t@(Def q [l,a,phi,u,u0]) | Just q == mhcomp- -> 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. fallback' :: MonadMatch m => (Term -> Maybe (Elims -> Term , Elims))+ -> MatchPrio -> OnlyLazy -> [NamedArg DeBruijnPattern] -> Arg Term -> m (Match Term, Arg Term)- fallback' mtc lazy ps (Arg info v) = do- isMatchable <- isMatchable'+ fallback' mtc prio lazy ps (Arg info v) = do w <- reduceB v -- Unfold delayed (corecursive) definitions one step. This is@@ -326,6 +363,10 @@ let v = ignoreBlocking w arg = Arg info v -- the reduced argument + reportSDoc "tc.match" 40 $ vcat+ [ " v = " <+> prettyTCM v <?> pretty (void w)+ ]+ case w of b | Just t <- isMatchable b -> case mtc t of@@ -333,9 +374,9 @@ (m, vs1) <- matchPatterns ps (fromMaybe __IMPOSSIBLE__ $ allApplyElims vs) return (yesSimplification m, Arg info $ bld (mergeElims vs vs1)) Nothing- -> return (No , arg)- Blocked b _ -> return (DontKnow lazy $ Blocked b () , arg)- NotBlocked r _ -> return (DontKnow lazy $ NotBlocked r' () , arg)+ -> return (No prio , arg)+ Blocked b _ -> return (DontKnow prio lazy $ Blocked b () , arg)+ NotBlocked r _ -> return (DontKnow prio lazy $ NotBlocked r' () , arg) where r' = stuckOn (Apply arg) r yesSimplification :: Match a -> Match a@@ -369,7 +410,7 @@ ConP c cpi ps -> case q of ConP c' _ qs | c == c' -> matchPatternsP ps ((map . fmap) namedThing qs)- | otherwise -> return No+ | otherwise -> return $ No (conPPrio cpi) LitP{} -> fmap toLitP <$> termMatch where toLitP (DotP _ (Lit l)) = litP l -- All bindings should be to literals toLitP _ = __IMPOSSIBLE__@@ -382,7 +423,7 @@ matchPatternsP ps qs = do mconcat <$> zipWithM matchPatternP (map namedArg ps) qs -+{-# SPECIALIZE properlyMatching :: Pattern' a -> TCM Bool #-} -- | Does the pattern perform a match that could fail? properlyMatching :: HasConstInfo m => Pattern' a -> m Bool properlyMatching = properlyMatching' True True
src/full/Agda/TypeChecking/Patterns/Match.hs-boot view
@@ -11,7 +11,10 @@ import Agda.Utils.Impossible -data Match a = Yes Simplification (IntMap (Arg a)) | No | DontKnow OnlyLazy (Blocked ())+data Match a+ = Yes Simplification (IntMap (Arg a))+ | No MatchPrio+ | DontKnow MatchPrio OnlyLazy (Blocked ()) data OnlyLazy = OnlyLazy | NonLazy
src/full/Agda/TypeChecking/Polarity.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE MagicHash #-}+ -- | Computing the polarity (variance) of function arguments, -- for the sake of subtyping. @@ -11,16 +13,19 @@ , polFromOcc ) where +import Prelude hiding ( zip, zipWith )+ import Control.Monad ( forM_, zipWithM ) import Data.Maybe-import Data.Semigroup ( Semigroup(..) ) import Agda.Syntax.Abstract.Name import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.TypeChecking.Monad+import Agda.TypeChecking.Monad.Benchmark (MonadBench)+import Agda.TypeChecking.Monad.Benchmark qualified as Bench import Agda.TypeChecking.Datatypes (getNumberOfParameters) import Agda.TypeChecking.Pretty import Agda.TypeChecking.SizedTypes@@ -31,14 +36,22 @@ import Agda.TypeChecking.Positivity.Occurrence import Agda.Utils.List-import Agda.Utils.Maybe ( whenNothingM )+import Agda.Utils.ListInf qualified as ListInf+import Agda.Utils.Maybe ( whenNothingM, whenJust ) import Agda.Utils.Monad import Agda.Syntax.Common.Pretty ( prettyShow ) import Agda.Utils.Singleton import Agda.Utils.Size+import Agda.Utils.Zip+import Agda.Utils.VarSet (VarSet)+import Agda.Utils.VarSet qualified as VarSet+import Agda.Utils.StrictState import Agda.Utils.Impossible +import Agda.Syntax.Position+import Debug.Trace+ ------------------------------------------------------------------------ -- * Polarity lattice. ------------------------------------------------------------------------@@ -93,7 +106,7 @@ -- | A quick transliterations of occurrences to polarities. polarityFromPositivity- :: (HasConstInfo m, MonadTCEnv m, MonadTCState m, MonadDebug m)+ :: (HasConstInfo m, MonadTCState m) => QName -> m () polarityFromPositivity x = inConcreteOrAbstractMode x $ \ def -> do @@ -111,12 +124,9 @@ ------------------------------------------------------------------------ -- | Main function of this module.-computePolarity- :: ( HasOptions m, HasConstInfo m, HasBuiltins m- , MonadTCEnv m, MonadTCState m, MonadReduce m, MonadAddContext m, MonadTCError m- , MonadDebug m, MonadPretty m )- => [QName] -> m ()-computePolarity xs = do+computePolarity :: [QName] -> TCM ()+computePolarity xs = Bench.billTo [Bench.Polarity] $ do+ reportSDoc "tc.polarity.set" 40 $ "computePolarity" <+> prettyTCM xs -- Andreas, 2017-04-26, issue #2554 -- First, for mutual definitions, obtain a crude polarity from positivity.@@ -155,10 +165,10 @@ -- -- variable occurrence test in dependentPolarity. reportSDoc "tc.polarity.set" 15 $ "Refining polarity with type " <+> prettyTCM t- reportSDoc "tc.polarity.set" 60 $+ reportSDoc "tc.polarity.set" 90 $ "Refining polarity with type (raw): " <+> (text .show) t - pol <- dependentPolarity t (enablePhantomTypes (theDef def) pol1) pol1+ pol <- liftReduce $ dependentPolarity t (enablePhantomTypes (theDef def) pol1) pol1 reportSLn "tc.polarity.set" 10 $ "Polarity of " ++ prettyShow x ++ ": " ++ prettyShow pol -- set the polarity in the signature@@ -197,49 +207,72 @@ usagePat LitP{} = Invariant -} + -- | Make arguments 'Invariant' if the type of a not-'Nonvariant' -- later argument depends on it. -- Also, enable phantom types by turning 'Nonvariant' into something -- else if it is a data/record parameter but not a size argument. [See issue 1596] -- -- Precondition: the "phantom" polarity list has the same length as the polarity list.-dependentPolarity- :: (HasOptions m, HasBuiltins m, MonadReduce m, MonadAddContext m, MonadDebug m)- => Type -> [Polarity] -> [Polarity] -> m [Polarity]-dependentPolarity t _ [] = return [] -- all remaining are 'Invariant'-dependentPolarity t [] (_ : _) = __IMPOSSIBLE__-dependentPolarity t (q:qs) pols@(p:ps) = do- t <- reduce $ unEl t- reportSDoc "tc.polarity.dep" 20 $ "dependentPolarity t = " <+> prettyTCM t- reportSDoc "tc.polarity.dep" 70 $ "dependentPolarity t = " <+> (text . show) t- case t of- Pi dom b -> do- ps <- underAbstraction dom b $ \ c -> dependentPolarity c qs ps- let fallback = ifM (isJust <$> isSizeType (unDom dom)) (return p) (return q)- p <- case b of- Abs{} | p /= Invariant ->- -- Andreas, 2014-04-11 see Issue 1099- -- Free variable analysis is not in the monad,- -- hence metas must have been instantiated before!- ifM (relevantInIgnoringNonvariant 0 (absBody b) ps)- {- then -} (return Invariant)- {- else -} fallback- _ -> fallback- return $ p : ps- _ -> return pols+dependentPolarity :: Type -> [Polarity] -> [Polarity] -> ReduceM [Polarity]+dependentPolarity t qs ps+ | all (== Invariant) qs && all (== Invariant) ps = pure ps -- Nothing can be possibly adjusted+ | otherwise = evalStateT (go t qs ps) mempty where --- | Check whether a variable is relevant in a type expression,--- ignoring domains of non-variant arguments.-relevantInIgnoringNonvariant :: MonadReduce m => Nat -> Type -> [Polarity] -> m Bool-relevantInIgnoringNonvariant i t [] = return $ i `relevantInIgnoringSortAnn` t-relevantInIgnoringNonvariant i t (p:ps) =- ifNotPiType t- {-then-} (\ t -> return $ i `relevantInIgnoringSortAnn` t) $- {-else-} \ a b ->- if p /= Nonvariant && i `relevantInIgnoringSortAnn` a- then return True- else relevantInIgnoringNonvariant (i + 1) (absBody b) ps+ -- 2026-02-26 András: this should exist more generically!+ {-# INLINE extendEnv #-}+ extendEnv :: String -> Dom Type -> StateT VarSet ReduceM a -> StateT VarSet ReduceM a+ extendEnv x a act = StateT \s -> ReduceM \e ->+ unReduceM (runStateT# act s) $! extendReduceEnv x a e + -- Andreas, 2014-04-11 see Issue 1099+ -- Free variable analysis is not in the monad,+ -- hence metas must have been instantiated before!+ go :: Type -> [Polarity] -> [Polarity] -> StateT VarSet ReduceM [Polarity]+ go t qs ps = case (qs, ps) of+ (_, []) -> do+ modify (`setRelInIgnoring` t)+ pure []+ ([], _:_) ->+ __IMPOSSIBLE__+ (q:qs, pols@(p:ps)) -> do+ lift $ reportSDoc "tc.polarity.dep" 20 $ "dependentPolarity t = " <+> prettyTCM t+ lift $ reportSDoc "tc.polarity.dep" 70 $ "dependentPolarity t = " <+> (text . show) t+ lift (reduce (unEl t)) >>= \case+ Pi dom b -> do+ let phantom | p /= q = ifM (lift (isJust <$> isSizeType (unDom dom)))+ (pure p) (pure q)+ | otherwise = pure p+ finish p ps = do+ when (p /= Nonvariant) (modify (`setRelInIgnoring` dom))+ pure (p:ps)+ case b of+ Abs x t -> extendEnv x dom do+ modify (VarSet.weaken 1)+ case p of+ Invariant -> do+ !ps <- go t qs ps+ !p <- phantom+ modify (VarSet.strengthen 1)+ finish p ps+ _ -> do+ modify (VarSet.insert 0)+ !ps <- go t qs ps+ !p <- gets (VarSet.member 0) >>= \case+ -- binder doesn't occur in the rest+ True -> phantom+ -- binder occurs in the rest+ False -> pure Invariant+ modify (VarSet.strengthen 1)+ finish p ps+ NoAbs _ t -> do+ !ps <- go t qs ps+ !p <- phantom+ finish p ps+ t -> do+ modify (`setRelInIgnoring` t)+ pure pols+ ------------------------------------------------------------------------ -- * Sized types ------------------------------------------------------------------------@@ -247,12 +280,7 @@ -- | Hack for polarity of size indices. -- As a side effect, this sets the positivity of the size index. -- See test/succeed/PolaritySizeSucData.agda for a case where this is needed.-sizePolarity- :: forall m .- ( HasOptions m, HasConstInfo m, HasBuiltins m, ReadTCState m- , MonadTCEnv m, MonadTCState m, MonadReduce m, MonadAddContext m, MonadTCError m- , MonadDebug m, MonadPretty m )- => QName -> [Polarity] -> m [Polarity]+sizePolarity :: QName -> [Polarity] -> TCM [Polarity] sizePolarity d pol0 = do let exit = return pol0 ifNotM sizedTypesOption exit $ {- else -} do@@ -263,14 +291,14 @@ (parTel, ixTel) = splitAt np $ telToList tel case ixTel of [] -> exit -- No size index- Dom{unDom = (_,a)} : _ -> ifM ((/= Just BoundedNo) <$> isSizeType a) exit $ do+ (unDom -> (_,a)) : _ -> ifM ((/= Just BoundedNo) <$> isSizeType a) exit $ do -- we assume the size index to be 'Covariant' ... let pol = take np pol0 polCo = pol ++ [Covariant] polIn = pol ++ [Invariant] setPolarity d $ polCo -- and seek confirm it by looking at the constructor types- let check :: QName -> m Bool+ let check :: QName -> TCM Bool check c = do t <- defType <$> getConstInfo c addContext (telFromList parTel) $ do@@ -278,7 +306,7 @@ TelV conTel target <- telView =<< (t `piApplyM` pars) loop target conTel where- loop :: Type -> Telescope -> m Bool+ loop :: Type -> Telescope -> TCM Bool -- no suitable size argument loop _ EmptyTel = do reportSDoc "tc.polarity.size" 15 $@@ -323,9 +351,7 @@ -- has form @d ps (↑ⁿ i) idxs@ where @|ps| = np(d)@. -- -- Precondition: @a@ is reduced and of form @d ps idxs0@.-checkSizeIndex- :: (HasConstInfo m, ReadTCState m, MonadDebug m, MonadPretty m, MonadTCError m)- => QName -> Nat -> Type -> m Bool+checkSizeIndex :: QName -> Nat -> Type -> TCM Bool checkSizeIndex d i a = do reportSDoc "tc.polarity.size" 15 $ withShowAllArguments $ vcat [ "checking that constructor target type " <+> prettyTCM a@@ -416,7 +442,7 @@ Lit _ -> mempty Level l -> polarity' i p l Def x ts -> getPolarity x >>== \ pols ->- let ps = map (composePol p) pols ++ repeat Invariant+ let ps = ListInf.pad (map (composePol p) pols) Invariant in mconcat $ zipWith (polarity' i) ps ts Con _ _ ts -> polarity' i p ts -- Constructors can be seen as monotone in all args. Pi a b -> polarity' i (neg p) a <> polarity' i p b
src/full/Agda/TypeChecking/Polarity.hs-boot view
@@ -2,18 +2,8 @@ module Agda.TypeChecking.Polarity where -import Agda.Syntax.Abstract.Name (QName)-import Agda.TypeChecking.Monad.Base-import Agda.TypeChecking.Monad.Builtin (HasBuiltins)-import Agda.TypeChecking.Monad.Context (MonadAddContext)-import Agda.TypeChecking.Monad.Debug (MonadDebug)-import {-# SOURCE #-} Agda.TypeChecking.Monad.Signature (HasConstInfo)-import {-# SOURCE #-} Agda.TypeChecking.Pretty (MonadPretty)--computePolarity- :: ( HasOptions m, HasConstInfo m, HasBuiltins m- , MonadTCEnv m, MonadTCState m, MonadReduce m, MonadAddContext m, MonadTCError m- , MonadDebug m, MonadPretty m )- => [QName] -> m ()+import Agda.Syntax.Abstract.Name ( QName )+import Agda.TypeChecking.Monad.Base ( Polarity, TCM ) +computePolarity :: [QName] -> TCM () composePol :: Polarity -> Polarity -> Polarity
src/full/Agda/TypeChecking/Positivity.hs view
@@ -1,915 +1,361 @@ {-# LANGUAGE NondecreasingIndentation #-} -- | Check that a datatype is strictly positive.-module Agda.TypeChecking.Positivity where--import Prelude hiding ( null, (!!) )--import Control.Applicative hiding (empty)-import Control.DeepSeq-import Control.Monad.Reader ( MonadReader(..), asks, ReaderT, runReaderT )--import Data.Either-import qualified Data.Foldable as Fold-import Data.Function (on)-import Data.Graph (SCC(..))-import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-import qualified Data.List as List-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Sequence (Seq)-import qualified Data.Sequence as DS-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Strict.These--import Debug.Trace--import Agda.Interaction.Options.Base ( optPolarity )-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-import Agda.TypeChecking.Monad-import Agda.TypeChecking.Patterns.Match ( properlyMatching )-import Agda.TypeChecking.Positivity.Occurrence-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Records-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Warnings--import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as Graph-import Agda.Utils.Function (applyUnless)-import Agda.Utils.Functor-import Agda.Utils.List-import qualified Agda.Utils.List1 as List1-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Null-import qualified Agda.Syntax.Common.Pretty as P-import Agda.Syntax.Common.Pretty (Pretty, prettyShow)-import Agda.Utils.SemiRing-import Agda.Utils.Singleton-import Agda.Utils.Size--import Agda.Utils.Impossible--type Graph n e = Graph.Graph n e---- | Check that the datatypes in the mutual block containing the given--- declarations are strictly positive.------ Find polarity of datatypes parameters and indices.------ Also add information about positivity and recursivity of records--- to the signature.----checkStrictlyPositive :: Info.MutualInfo -> Set QName -> TCM ()-checkStrictlyPositive mi qset = do- -- compute the occurrence graph for qs- let qs = Set.toList qset- reportSDoc "tc.pos.tick" 100 $ "positivity of" <+> prettyTCM qs- g <- buildOccurrenceGraph qset- let (gstar, sccs) =- Graph.gaussJordanFloydWarshallMcNaughtonYamada $ fmap occ g- reportSDoc "tc.pos.tick" 100 $ "constructed graph"- reportSLn "tc.pos.graph" 5 $ "Positivity graph: N=" ++ show (size $ Graph.nodes g) ++- " E=" ++ show (length $ Graph.edges g)- reportSDoc "tc.pos.graph" 10 $ vcat- [ "positivity graph for" <+> fsep (map prettyTCM qs)- , nest 2 $ prettyTCM g- ]- reportSLn "tc.pos.graph" 5 $- "Positivity graph (completed): E=" ++ show (length $ Graph.edges gstar)- reportSDoc "tc.pos.graph" 50 $ vcat- [ "transitive closure of positivity graph for" <+>- prettyTCM qs- , nest 2 $ prettyTCM gstar- ]-- -- remember argument occurrences for qs in the signature- setArgOccs qset qs gstar- reportSDoc "tc.pos.tick" 100 $ "set args"-- -- check positivity for all strongly connected components of the graph for qs- reportSDoc "tc.pos.graph.sccs" 10 $ do- let (triv, others) = partitionEithers $ for sccs $ \case- AcyclicSCC v -> Left v- CyclicSCC vs -> Right vs- sep [ text $ show (length triv) ++ " trivial sccs"- , text $ show (length others) ++ " non-trivial sccs with lengths " ++- show (map length others)- ]- reportSLn "tc.pos.graph.sccs" 15 $- " sccs = " ++ prettyShow [ scc | CyclicSCC scc <- sccs ]-- -- #7133: Note that the graph doesn't necessarily contain all of qs in the case where there are no- -- occurrences of a name, but we still need to setMutual for them.- let sccMap = Map.unions [ case scc of- AcyclicSCC (DefNode q) -> Map.singleton q []- AcyclicSCC ArgNode{} -> mempty- CyclicSCC scc -> Map.fromList [ (q, qs) | q <- qs ]- where qs = [ q | DefNode q <- scc ]- | scc <- sccs ]- inAbstractMode $ forM_ qs $ \ q ->- whenM (isNothing <$> getMutual q) $ do- let qs = fromMaybe [] $ Map.lookup q sccMap- reportSLn "tc.pos.mutual" 10 $ "setting " ++ prettyShow q ++ " to " ++- if | null qs -> "non-recursive"- | length qs == 1 -> "recursive"- | otherwise -> "mutually recursive"- setMutual q qs-- mapM_ (checkPos g gstar) qs- reportSDoc "tc.pos.tick" 100 $ "checked positivity"-- where- checkPos :: Graph Node (Edge OccursWhere) ->- Graph Node Occurrence ->- QName -> TCM ()- checkPos g gstar q = inConcreteOrAbstractMode q $ \ def -> do- -- we check positivity only for data or record definitions- whenJust (isDatatype def) $ \ dr -> do- reportSDoc "tc.pos.check" 10 $ "Checking positivity of" <+> prettyTCM q-- let loop :: Maybe Occurrence- loop = Graph.lookup (DefNode q) (DefNode q) gstar-- g' :: Graph Node (Edge (Seq OccursWhere))- g' = fmap (fmap DS.singleton) g-- -- Note the property- -- Internal.Utils.Graph.AdjacencyMap.Unidirectional.prop_productOfEdgesInBoundedWalk,- -- which relates productOfEdgesInBoundedWalk to- -- gaussJordanFloydWarshallMcNaughtonYamada.-- reason bound =- case productOfEdgesInBoundedWalk- occ g' (DefNode q) (DefNode q) bound of- Just (Edge _ how) -> how- Nothing -> __IMPOSSIBLE__-- how :: String -> Occurrence -> TCM Doc- how msg bound = fsep $- [prettyTCM q] ++ pwords "is" ++- pwords (msg ++ ", because it occurs") ++- [prettyTCM (reason bound)]-- -- if we have a negative loop, raise error-- -- ASR (23 December 2015). We don't raise a strictly positive- -- error if the NO_POSITIVITY_CHECK pragma was set on in the- -- mutual block. See Issue 1614.- when (Info.mutualPositivityCheck mi == YesPositivityCheck) $- whenM positivityCheckEnabled $- case loop of- Just o | o <= JustPos ->- warning $ NotStrictlyPositive q (reason JustPos)- _ -> return ()-- -- if we find an unguarded record, mark it as such- case dr of- IsData -> return ()- IsRecord pat -> case loop of- Just o | o <= StrictPos -> do- reportSDoc "tc.pos.record" 5 $ how "not guarded" StrictPos- unguardedRecord q pat- checkInduction q- -- otherwise, if the record is recursive, mark it as well- Just o | o <= GuardPos -> do- reportSDoc "tc.pos.record" 5 $ how "recursive" GuardPos- recursiveRecord q- checkInduction q- -- If the record is not recursive, switch on eta- -- unless it is coinductive or a no-eta-equality record.- Nothing -> do- reportSDoc "tc.pos.record" 10 $- "record type " <+> prettyTCM q <+>- "is not recursive"- nonRecursiveRecord q- _ -> return ()-- checkInduction :: QName -> TCM ()- checkInduction q =- -- ASR (01 January 2016). We don't raise this error if the- -- NO_POSITIVITY_CHECK pragma was set on in the record. See- -- Issue 1760.- when (Info.mutualPositivityCheck mi == YesPositivityCheck) $- whenM positivityCheckEnabled $ do- -- Check whether the recursive record has been declared as- -- 'Inductive' or 'Coinductive'. Otherwise, error.- unlessM (isJust . recInduction . theDef <$> getConstInfo q) $- setCurrentRange (nameBindingSite $ qnameName q) $- typeError $ RecursiveRecordNeedsInductivity q-- occ (Edge o _) = o-- isDatatype :: Definition -> Maybe DataOrRecord- isDatatype def = do- case theDef def of- Datatype{dataClause = Nothing} -> Just IsData- Record {recClause = Nothing, recPatternMatching } -> Just $ IsRecord recPatternMatching- _ -> Nothing-- -- Set the polarity of the arguments to a couple of definitions- setArgOccs :: Set QName -> [QName] -> Graph Node Occurrence -> TCM ()- setArgOccs qset qs g = do- -- Andreas, 2018-05-11, issue #3049: we need to be pessimistic about- -- argument polarity beyond the formal arity of the function.- --- -- -- Compute a map from each name in q to the maximal argument index- -- let maxs = Map.fromListWith max- -- [ (q, i) | ArgNode q i <- Set.toList $ Graph.nodes g, q `Set.member` qset ]- forM_ qs $ \ q -> inConcreteOrAbstractMode q $ \ def -> when (hasDefinition $ theDef def) $ do- reportSDoc "tc.pos.args" 10 $ "checking args of" <+> prettyTCM q- n <- getDefArity def- -- If there is no outgoing edge @ArgNode q i@, all @n@ arguments are @Unused@.- -- Otherwise, we obtain the occurrences from the Graph.- let findOcc i = fromMaybe Unused $ Graph.lookup (ArgNode q i) (DefNode q) g- args = -- caseMaybe (Map.lookup q maxs) (replicate n Unused) $ \ m ->- map findOcc [0 .. n-1] -- [0 .. max m (n - 1)] -- triggers issue #3049-- reportSDoc "tc.pos.args" 10 $ sep- [ "args of" <+> prettyTCM q <+> "="- , nest 2 $ prettyList $ map prettyTCM args- ]- -- The list args can take a long time to compute, but contains- -- small elements, and is stored in the interface (right?), so- -- it is computed deep-strictly.- modifyArgOccurrences q (mergeOccs $!! args)-- where- mergeOccs :: [Occurrence] -> [Occurrence] -> [Occurrence]- mergeOccs poccs toccs =- -- Lucas, 2022-12-01:- -- `poccs` are the occurences computed by the positivity-checker- -- `toccs` are the occurences/polarities explicitely given by the user- -- (and enforced through type-checking)- -- We consider the polarities explicitely given (toccs) to take priority over the ones- -- found out by the positivity checker.- -- Note: Alas, this is hard to enforce given that non-annotated variables are- -- always annotated with Mixed polarity. If the annotated polarity is Mixed,- -- for now we always rely on the result from the positivity analysis.- align poccs toccs <&> mergeThese (\a b -> if b == Mixed then a else b)-- -- Andreas, 2018-11-23, issue #3404- -- Only assign argument occurrences to things which have a definition.- -- Things without a definition would be judged "constant" in all arguments,- -- since no occurrence could possibly be found, naturally.- hasDefinition :: Defn -> Bool- hasDefinition = \case- Axiom{} -> False- DataOrRecSig{} -> False- GeneralizableVar{} -> False- AbstractDefn{} -> False- Primitive{} -> False- PrimitiveSort{} -> False- Constructor{} -> False- Function{} -> True- Datatype{} -> True- Record{} -> True--getDefArity :: Definition -> TCM Int-getDefArity def = do- TelV tel _ <- telView (defType def)- return $ size tel - projectionArgs def---- Computing occurrences ----------------------------------------------------data Item = AnArg Nat [Occurrence]- | ADef QName- deriving (Eq, Ord, Show)--instance HasRange Item where- getRange (AnArg _ _) = noRange- getRange (ADef qn) = getRange qn--instance Pretty Item where- prettyPrec p (AnArg i t) = P.mparens (p > 9) $ "AnArg" P.<+> P.pretty i P.<+> P.pretty t- prettyPrec p (ADef qn) = P.mparens (p > 9) $ "ADef" P.<+> P.pretty qn--type Occurrences = Map Item [OccursWhere]---- | Used to build 'Occurrences' and occurrence graphs.-data OccurrencesBuilder- = Concat [OccurrencesBuilder]- | OccursAs Where OccurrencesBuilder- | OccursHere Item- | OnlyVarsUpTo Nat OccurrencesBuilder- -- ^ @OnlyVarsUpTo n occs@ discards occurrences of de Bruijn index- -- @>= n@.---- | Used to build 'Occurrences' and occurrence graphs.-data OccurrencesBuilder'- = Concat' [OccurrencesBuilder']- | OccursAs' Where OccurrencesBuilder'- | OccursHere' Item---- | The semigroup laws only hold up to flattening of 'Concat'.-instance Semigroup OccurrencesBuilder where- occs1 <> occs2 = Concat [occs1, occs2]---- | The monoid laws only hold up to flattening of 'Concat'.-instance Monoid OccurrencesBuilder where- mempty = Concat []- mappend = (<>)- mconcat = Concat---- | Removes 'OnlyVarsUpTo' entries.-preprocess :: OccurrencesBuilder -> OccurrencesBuilder'-preprocess ob = case pp Nothing ob of- Nothing -> Concat' []- Just ob -> ob- where- pp :: Maybe Nat -- Variables larger than or equal to this number, if any,- -- are not retained.- -> OccurrencesBuilder- -> Maybe OccurrencesBuilder'- pp !m = \case- Concat obs -> case mapMaybe (pp m) obs of- [] -> Nothing- obs -> return (Concat' obs)-- OccursAs w ob -> OccursAs' w <$> pp m ob-- OnlyVarsUpTo n ob -> pp (Just $! maybe n (min n) m) ob-- OccursHere i -> do- guard keep- return (OccursHere' i)- where- keep = case (m, i) of- (Nothing, _) -> True- (_, ADef _) -> True- (Just m, AnArg i _) -> i < m---- | An interpreter for 'OccurrencesBuilder'.------ WARNING: There can be lots of sharing between the generated--- 'OccursWhere' entries. Traversing all of these entries could be--- expensive. (See 'computeEdges' for an example.)-flatten :: OccurrencesBuilder -> Map Item Integer-flatten =- Map.fromListWith (+) .- flip flatten' [] .- preprocess- where- flatten'- :: OccurrencesBuilder'- -> [(Item, Integer)]- -> [(Item, Integer)]- flatten' (Concat' obs) = foldr (\occs f -> flatten' occs . f) id obs- flatten' (OccursAs' _ ob) = flatten' ob- flatten' (OccursHere' i) = ((i, 1) :)---- | Context for computing occurrences.-data OccEnv = OccEnv- { vars :: [Maybe Item]- -- ^ Items corresponding to the free variables.- --- -- Potential invariant: It seems as if the list has the form- -- @'genericReplicate' n 'Nothing' ++ 'map' ('Just' . 'AnArg') is@,- -- for some @n@ and @is@, where @is@ is decreasing- -- (non-strictly).- , inf :: Maybe QName- -- ^ Name for ∞ builtin.- }---- | Monad for computing occurrences.-type OccM = ReaderT OccEnv ReduceM--instance (Semigroup a, Monoid a) => Monoid (OccM a) where- mempty = return mempty- mappend = (<>)- mconcat = mconcat <.> sequence--withExtendedOccEnv :: Maybe Item -> OccM a -> OccM a-withExtendedOccEnv i = withExtendedOccEnv' [i]--withExtendedOccEnv' :: [Maybe Item] -> OccM a -> OccM a-withExtendedOccEnv' is = local $ \ e -> e { vars = is ++ vars e }---- | Running the monad-getOccurrences- :: (Show a, PrettyTCM a, ComputeOccurrences a)- => [Maybe Item] -- ^ Extension of the 'OccEnv', usually a local variable context.- -> a- -> TCM OccurrencesBuilder-getOccurrences vars a = do- reportSDoc "tc.pos.occ" 70 $ "computing occurrences in " <+> text (show a)- reportSDoc "tc.pos.occ" 20 $ "computing occurrences in " <+> prettyTCM a- reportSDoc "tc.pos.var" 20 $ "variables in context: " <+> pretty vars- env <- OccEnv vars . fmap nameOfInf <$> coinductionKit- runReduceM $ runReaderT (occurrences a) env--class ComputeOccurrences a where- occurrences :: a -> OccM OccurrencesBuilder-- default occurrences :: (Foldable t, ComputeOccurrences b, t b ~ a) => a -> OccM OccurrencesBuilder- occurrences = foldMap occurrences--instance ComputeOccurrences Clause where- 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- argOccs <- mapMaybeM matching $ zip [0..] ps- (Concat argOccs <>) <$> do- withExtendedOccEnv' items $- occurrences $ clauseBody cl- where- matching :: (Int, NamedArg (Pattern' a)) -> OccM (Maybe OccurrencesBuilder)- matching (i, p) = do- properlyMatching (namedThing $ unArg p) >>= \case- True -> return $ Just $ OccursAs Matched $ OccursHere $ AnArg i []- False -> return Nothing-- -- @patItems ps@ creates a map from the pattern variables of @ps@- -- to the index of the argument they are bound in.- patItems ps = mconcat $ zipWith patItem [0..] ps-- -- @patItem i p@ assigns index @i@ to each pattern variable in @p@- patItem :: Int -> NamedArg DeBruijnPattern -> IntMap (Maybe Item)- patItem i p = Fold.foldMap makeEntry ixs- where- ixs = map dbPatVarIndex $ lefts $ map unArg $ patternVars $ namedThing <$> p-- makeEntry x = singleton (x, Just $ AnArg i [])--instance ComputeOccurrences Term where- occurrences v = case unSpine v of- Var i args ->- asks (occI . vars) <> do- occs <- mapM occurrences args-- -- Lucas, 2022-12-01: Now, variables may have the polarities of their arguments- -- stored in the context (say, if the variable refers to a datatype parameter)- item <- reader ((!! i) . vars)-- let getPol i = fromMaybe Mixed $ do- AnArg _ aoccs <- item- aoccs !!! i-- return $ Concat $ zipWith (\i -> OccursAs (VarArg (getPol i) i)) [0..] occs- where- occI vars = maybe mempty OccursHere $ indexWithDefault unbound vars i- unbound = flip trace __IMPOSSIBLE__ $- "impossible: occurrence of de Bruijn index " ++ show i ++- " in vars " ++ show vars ++ " is unbound"-- Def d args -> do- inf <- asks inf- let occsAs = if Just d /= inf then OccursAs . DefArg d else \ n ->- -- the principal argument of builtin INF (∞) is the second (n==1)- -- the first is a level argument (n==0, counting from 0!)- if n == 1 then OccursAs UnderInf else OccursAs (DefArg d n)- occs <- mapM occurrences args- return . Concat $ OccursHere (ADef d) : zipWith occsAs [0..] occs-- Con _ _ args -> occurrences args- MetaV _ args -> OccursAs MetaArg <$> occurrences args- Pi a b -> (OccursAs LeftOfArrow <$> occurrences a) <> occurrences b- Lam _ b -> occurrences b- Level l -> occurrences l- Lit{} -> mempty- Sort{} -> mempty- -- Jesper, 2020-01-12: this information is also used for the- -- occurs check, so we need to look under DontCare (see #4371)- DontCare v -> occurrences v- Dummy{} -> mempty--instance ComputeOccurrences Level where- occurrences (Max _ as) = occurrences as--instance ComputeOccurrences PlusLevel where- occurrences (Plus _ l) = occurrences l--instance ComputeOccurrences Type where- occurrences (El _ v) = occurrences v--instance ComputeOccurrences a => ComputeOccurrences (Tele a) where- occurrences EmptyTel = mempty- occurrences (ExtendTel a b) = occurrences (a, b)--instance ComputeOccurrences a => ComputeOccurrences (Abs a) where- occurrences (Abs _ b) = withExtendedOccEnv Nothing $ occurrences b- occurrences (NoAbs _ b) = occurrences b--instance ComputeOccurrences a => ComputeOccurrences (Elim' a) where- occurrences Proj{} = __IMPOSSIBLE__ -- unSpine- occurrences (Apply a) = occurrences a- occurrences (IApply x y a) = occurrences (x,(y,a)) -- TODO Andrea: conservative--instance (ComputeOccurrences x, ComputeOccurrences a) => ComputeOccurrences (Boundary' x a) where- occurrences = occurrences . theBoundary--instance ComputeOccurrences a => ComputeOccurrences (Arg a) where-instance ComputeOccurrences a => ComputeOccurrences (Dom a) where-instance ComputeOccurrences a => ComputeOccurrences [a] where-instance ComputeOccurrences a => ComputeOccurrences (Maybe a) where--instance (ComputeOccurrences a, ComputeOccurrences b) => ComputeOccurrences (a, b) where- occurrences (x, y) = occurrences x <> occurrences y--instance ComputeOccurrences Int where- occurrences _ = mempty---- | Computes the number of occurrences of different 'Item's in the--- given definition.------ WARNING: There can be lots of sharing between the 'OccursWhere'--- entries. Traversing all of these entries could be expensive. (See--- 'computeEdges' for an example.)-computeOccurrences :: QName -> TCM (Map Item Integer)-computeOccurrences q = flatten <$> computeOccurrences' q---- | Computes the occurrences in the given definition.-computeOccurrences' :: QName -> TCM OccurrencesBuilder-computeOccurrences' q = inConcreteOrAbstractMode q $ \ def -> do- reportSDoc "tc.pos" 25 $ do- let a = defAbstract def- m <- asksTC envAbstractMode- cur <- asksTC envCurrentModule- o <- asksTC envCurrentOpaqueId- "computeOccurrences" <+> prettyTCM q <+> text (show a) <+> text (show o) <+> text (show m)- <+> prettyTCM cur- OccursAs (InDefOf q) <$> case theDef def of-- Function{funClauses = cs} -> do- cs <- mapM etaExpandClause =<< instantiateFull cs- Concat . zipWith (OccursAs . InClause) [0..] <$>- mapM (getOccurrences []) cs-- Datatype{dataClause = Just c} -> getOccurrences [] =<< instantiateFull c- Datatype{dataPars = np0, dataCons = cs, dataTranspIx = trx} -> do- -- Andreas, 2013-02-27 (later edited by someone else): First,- -- include each index of an inductive family.- TelV telD _ <- telView $ defType def- -- Andreas, 2017-04-26, issue #2554: count first index as parameter if it has type Size.- -- We compute sizeIndex=1 if first first index has type Size, otherwise sizeIndex==0- sizeIndex <- caseList (drop np0 $ telToList telD) (return 0) $ \ dom _ -> do- caseMaybeM (isSizeType dom) (return 0) $ \ _ -> return 1- let np = np0 + sizeIndex- let xs = [np .. size telD - 1] -- argument positions corresponding to indices-- let ioccs = Concat $ map (\i -> OccursHere $ AnArg i []) [np0 .. np - 1]- ++ map (\i -> OccursAs IsIndex $ OccursHere $ AnArg i []) xs-- -- Then, we compute the occurrences in the constructor types.- let conOcc c = do- -- Andreas, 2020-02-15, issue #4447:- -- Allow UnconfimedReductions here to make sure we get the constructor type- -- in same way as it was obtained when the data types was checked.- (TelV tel t, bnd) <- putAllowedReductions allReductions $- telViewPathBoundary . defType =<< getConstInfo c- let (tel0,tel1) = splitTelescopeAt np tel- -- Do not collect occurrences in the data parameters.- -- Normalization needed e.g. for test/succeed/Bush.agda.- -- (Actually, for Bush.agda, reducing the parameters should be sufficient.)- tel1' <- addContext tel0 $ normalise $ tel1-- -- Make parameters into context items, with polarity info- pvars <- parametersToItems tel0 np- let telvars = replicate (size tel1') Nothing ++ pvars-- reportSLn "tc.pos.params" 50 $ "Adding datatypes parameters in context " ++ prettyShow pvars-- -- Occurrences in the types of the constructor arguments.- (OccursAs (ConArgType c) <$> getOccurrences pvars tel1') <>- (OccursAs (ConEndpoint c) <$> getOccurrences telvars bnd) <> do- -- Occurrences in the indices of the data type the constructor targets.- -- Andreas, 2020-02-15, issue #4447:- -- WAS: @t@ is not necessarily a data type, but it could be something- -- that reduces to a data type once UnconfirmedReductions are confirmed- -- as safe by the termination checker.- -- In any case, if @t@ is not showing itself as the data type, we need to- -- do something conservative. We will just collect *all* occurrences- -- and flip their sign (variance) using 'LeftOfArrow'.- case unEl t of- Def q' vs- | q == q' -> do- let indices = fromMaybe __IMPOSSIBLE__ $ allApplyElims $ drop np vs- OccursAs (IndArgType c) . OnlyVarsUpTo np <$> getOccurrences telvars indices- | otherwise -> __IMPOSSIBLE__ -- this ought to be impossible now (but wasn't, see #4447)- Pi{} -> __IMPOSSIBLE__ -- eliminated by telView- MetaV{} -> __IMPOSSIBLE__ -- not a constructor target; should have been solved by now- Var{} -> __IMPOSSIBLE__ -- not a constructor target- Sort{} -> __IMPOSSIBLE__ -- not a constructor target- Lam{} -> __IMPOSSIBLE__ -- not a type- Lit{} -> __IMPOSSIBLE__ -- not a type- Con{} -> __IMPOSSIBLE__ -- not a type- Level{} -> __IMPOSSIBLE__ -- not a type- DontCare{} -> __IMPOSSIBLE__ -- not a type- Dummy{} -> __IMPOSSIBLE__-- -- If the data type has a transport constructor (i.e. it's an- -- indexed family in cubical mode) we should also consider it for- -- positivity.- mconcat $ pure ioccs : map conOcc (cs ++ maybeToList trx)-- Record{recClause = Just c} -> getOccurrences [] =<< instantiateFull c- Record{recPars = np, recTel = tel} -> do- let (tel0,tel1) = splitTelescopeAt np tel- pvars <- parametersToItems tel0 np- getOccurrences pvars =<< addContext tel0 (normalise tel1) -- Andreas, 2017-01-01, issue #1899, treat like data types-- -- Arguments to other kinds of definitions are hard-wired.- Constructor{} -> mempty- Axiom{} -> mempty- DataOrRecSig{} -> mempty- Primitive{} -> mempty- PrimitiveSort{} -> mempty- GeneralizableVar{} -> mempty- AbstractDefn{} -> __IMPOSSIBLE__- where- parametersToItems :: Telescope -> Nat -> TCM [Maybe Item]- parametersToItems tel n = reverse <$>- zipWithM (\i -> fmap (Just . AnArg i) . getOccurrencesFromType)- [0 .. n -1]- (snd . unDom <$> telToList tel)----- Building the occurrence graph --------------------------------------------data Node = DefNode !QName- | ArgNode !QName !Nat- deriving (Eq, Ord)---- | Edge labels for the positivity graph.-data Edge a = Edge !Occurrence a- deriving (Eq, Ord, Show, Functor)---- | Merges two edges between the same source and target.--mergeEdges :: Edge a -> Edge a -> Edge a-mergeEdges _ e@(Edge Mixed _) = e -- dominant-mergeEdges e@(Edge Mixed _) _ = e-mergeEdges (Edge Unused _) e = e -- neutral-mergeEdges e (Edge Unused _) = e-mergeEdges (Edge JustNeg _) e@(Edge JustNeg _) = e-mergeEdges _ e@(Edge JustNeg w) = Edge Mixed w-mergeEdges e@(Edge JustNeg w) _ = Edge Mixed w-mergeEdges _ e@(Edge JustPos _) = e -- dominates strict pos.-mergeEdges e@(Edge JustPos _) _ = e-mergeEdges _ e@(Edge StrictPos _) = e -- dominates 'GuardPos'-mergeEdges e@(Edge StrictPos _) _ = e-mergeEdges (Edge GuardPos _) e@(Edge GuardPos _) = e---- | These operations form a semiring if we quotient by the relation--- \"the 'Occurrence' components are equal\".--instance SemiRing (Edge (Seq OccursWhere)) where- ozero = Edge ozero DS.empty- oone = Edge oone DS.empty-- oplus = mergeEdges-- otimes (Edge o1 w1) (Edge o2 w2) = Edge (otimes o1 o2) (w1 DS.>< w2)---- | WARNING: There can be lots of sharing between the 'OccursWhere'--- entries in the edges. Traversing all of these entries could be--- expensive. (See 'computeEdges' for an example.)-buildOccurrenceGraph :: Set QName -> TCM (Graph Node (Edge OccursWhere))-buildOccurrenceGraph qs =- Graph.fromEdgesWith mergeEdges . concat <$>- mapM defGraph (Set.toList qs)- where- defGraph :: QName -> TCM [Graph.Edge Node (Edge OccursWhere)]- defGraph q = inConcreteOrAbstractMode q $ \ _def -> do- occs <- computeOccurrences' q-- reportSDoc "tc.pos.occs" 40 $- (("Occurrences in" <+> prettyTCM q) <> ":")- $+$- nest 2 (vcat $- map (\(i, n) ->- (pretty i <> ":") <+> text (show n) <+>- "occurrences") $- List.sortBy (compare `on` snd) $- Map.toList (flatten occs))-- -- Placing this line before the reportSDoc lines above creates a- -- space leak: occs is retained for too long.- es <- computeEdges qs q occs-- reportSDoc "tc.pos.occs.edges" 60 $- "Edges:"- $+$- nest 2 (vcat $- map (\e ->- let Edge o w = Graph.label e in- prettyTCM (Graph.source e) <+>- "-[" <+> (return (P.pretty o) <> ",") <+>- return (P.pretty w) <+> "]->" <+>- prettyTCM (Graph.target e))- es)-- return es---- | Computes all non-'ozero' occurrence graph edges represented by--- the given 'OccurrencesBuilder'.------ WARNING: There can be lots of sharing between the 'OccursWhere'--- entries in the edges. Traversing all of these entries could be--- expensive. For instance, for the function @F@ in--- @benchmark/misc/SlowOccurrences.agda@ a large number of edges from--- the argument @X@ to the function @F@ are computed. These edges have--- polarity 'StrictPos', 'JustNeg' or 'JustPos', and contain the--- following 'OccursWhere' elements:------ * @'OccursWhere' _ 'DS.empty' ('DS.fromList' ['InDefOf' "F", 'InClause' 0])@,------ * @'OccursWhere' _ 'DS.empty' ('DS.fromList' ['InDefOf' "F", 'InClause' 0, 'LeftOfArrow'])@,------ * @'OccursWhere' _ 'DS.empty' ('DS.fromList' ['InDefOf' "F", 'InClause' 0, 'LeftOfArrow', 'LeftOfArrow'])@,------ * @'OccursWhere' _ 'DS.empty' ('DS.fromList' ['InDefOf' "F", 'InClause' 0, 'LeftOfArrow', 'LeftOfArrow', 'LeftOfArrow'])@,------ * and so on.-computeEdges- :: Set QName- -- ^ The names in the current mutual block.- -> QName- -- ^ The current name.- -> OccurrencesBuilder- -> TCM [Graph.Edge Node (Edge OccursWhere)]-computeEdges muts q ob =- ($ []) <$> mkEdge StrictPos (preprocess ob)- __IMPOSSIBLE__ DS.empty DS.empty- where- mkEdge- :: Occurrence- -> OccurrencesBuilder'- -> Node -- The current target node.- -> DS.Seq Where -- 'Where' information encountered before the current target- -- node was (re)selected.- -> DS.Seq Where -- 'Where' information encountered after the current target- -- node was (re)selected.- -> TCM ([Graph.Edge Node (Edge OccursWhere)] ->- [Graph.Edge Node (Edge OccursWhere)])- mkEdge !pol ob to cs os = case ob of- Concat' obs ->- foldr (liftM2 (.)) (return id)- [ mkEdge pol ob to cs os | ob <- obs ]-- OccursAs' w ob -> do- (to', pol) <- mkEdge' to pol w- let mk = mkEdge pol ob- case to' of- Nothing -> mk to cs (os DS.|> w)- Just to -> mk to (cs DS.>< os) (DS.singleton w)-- OccursHere' i ->- let o = OccursWhere (getRange i) cs os in- case i of- AnArg i t ->- return $ applyUnless (null pol) (Graph.Edge- { Graph.source = ArgNode q i- , Graph.target = to- , Graph.label = Edge pol o- } :)- ADef q' ->- -- Andreas, 2017-04-26, issue #2555- -- Skip nodes pointing outside the mutual block.- return $ applyUnless (null pol || Set.notMember q' muts)- (Graph.Edge- { Graph.source = DefNode q'- , Graph.target = to- , Graph.label = Edge pol o- } :)-- -- This function might return a new target node.- mkEdge'- :: Node -- The current target node.- -> Occurrence- -> Where- -> TCM (Maybe Node, Occurrence)- mkEdge' to !pol = \case- VarArg p i -> addPol p- MetaArg -> mixed- LeftOfArrow -> negative- DefArg d i -> do- pol' <- isGuarding d- if Set.member d muts- then return (Just (ArgNode d i), pol')- else addPol =<< otimes pol' <$> getArgOccurrence d i- UnderInf -> addPol GuardPos -- Andreas, 2012-06-09: ∞ is guarding- ConArgType _ -> keepGoing- IndArgType _ -> mixed- ConEndpoint _ -> keepGoing- InClause _ -> keepGoing- Matched -> mixed -- consider arguments matched against as used- IsIndex -> mixed -- And similarly for indices.- InDefOf d -> do- pol' <- isGuarding d- return (Just (DefNode d), pol')- where- keepGoing = return (Nothing, pol)- mixed = return (Nothing, Mixed)- negative = return (Nothing, otimes pol JustNeg)- addPol pol' = return (Nothing, otimes pol pol')-- isGuarding d = do- isDataOrRecordType d <&> \case- Just IsData -> GuardPos -- a datatype is guarding- _ -> StrictPos---- Pretty-printing -------------------------------------------------------instance Pretty Node where- pretty = \case- DefNode q -> P.pretty q- ArgNode q i -> P.pretty q <> P.text ("." ++ show i)--instance PrettyTCM Node where- prettyTCM = return . P.pretty--instance PrettyTCMWithNode (Edge OccursWhere) where- prettyTCMWithNode (WithNode n (Edge o w)) = vcat- [ prettyTCM o <+> prettyTCM n- , nest 2 $ return $ P.pretty w- ]--instance PrettyTCM (Seq OccursWhere) where- prettyTCM =- fmap snd . prettyOWs . map adjustLeftOfArrow . uniq . Fold.toList- where- nth 0 = pwords "first"- nth 1 = pwords "second"- nth 2 = pwords "third"- nth n = pwords $ show (n + 1) ++ "th"-- -- Removes consecutive duplicates.- uniq :: [OccursWhere] -> [OccursWhere]- uniq = map List1.head . List1.groupBy ((==) `on` snd')- where- snd' (OccursWhere _ _ ws) = ws-- prettyOWs :: MonadPretty m => [OccursWhere] -> m (String, Doc)- prettyOWs [] = __IMPOSSIBLE__- prettyOWs [o] = do- (s, d) <- prettyOW o- return (s, d <> ".")- prettyOWs (o:os) = do- (s1, d1) <- prettyOW o- (s2, d2) <- prettyOWs os- return (s1, d1 <> ("," P.<+> "which" P.<+> P.text s2 P.$$ d2))-- prettyOW :: MonadPretty m => OccursWhere -> m (String, Doc)- prettyOW (OccursWhere _ cs ws)- | null cs = prettyWs ws- | otherwise = do- (s, d1) <- prettyWs ws- (_, d2) <- prettyWs cs- return (s, d1 P.$$ "(" <> d2 <> ")")-- prettyWs :: MonadPretty m => Seq Where -> m (String, Doc)- prettyWs ws = case Fold.toList ws of- [InDefOf d, IsIndex] ->- (,) "is" <$> fsep (pwords "an index of" ++ [prettyTCM d])- _ ->- (,) "occurs" <$>- Fold.foldrM (\w d -> return d $$ fsep (prettyW w)) empty ws-- prettyW :: MonadPretty m => Where -> [m Doc]- prettyW = \case- LeftOfArrow -> pwords "to the left of an arrow"- DefArg q i -> pwords "in the" ++ nth i ++ pwords "argument of" ++- [prettyTCM q]- UnderInf -> pwords "under" ++- [do -- this cannot fail if an 'UnderInf' has been generated- inf <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinInf- prettyTCM inf]- VarArg p i -> pwords "in an argument of a bound variable at position" ++ [prettyTCM i]- ++ pwords "which uses its argument with polarity" ++ [ pretty p ]- MetaArg -> pwords "in an argument of a metavariable"- ConArgType c -> pwords "in the type of the constructor" ++ [prettyTCM c]- IndArgType c -> pwords "in an index of the target type of the constructor" ++ [prettyTCM c]- ConEndpoint c- -> pwords "in an endpoint of the target of the" ++- pwords "higher constructor" ++ [prettyTCM c]- InClause i -> pwords "in the" ++ nth i ++ pwords "clause"- Matched -> pwords "as matched against"- IsIndex -> pwords "as an index"- InDefOf d -> pwords "in the definition of" ++ [prettyTCM d]-- adjustLeftOfArrow :: OccursWhere -> OccursWhere- adjustLeftOfArrow (OccursWhere r cs os) =- OccursWhere r (DS.filter (not . isArrow) cs) $- noArrows- DS.><- case DS.viewl startsWithArrow of- DS.EmptyL -> DS.empty- w DS.:< ws -> w DS.<| DS.filter (not . isArrow) ws- where- (noArrows, startsWithArrow) = DS.breakl isArrow os-- isArrow LeftOfArrow{} = True- isArrow _ = False++module Agda.TypeChecking.Positivity where++import Prelude hiding ( null, (!!) )++import Control.DeepSeq+import Data.Either+import Data.Foldable (toList)+import Data.Foldable qualified as Fold+import Data.Function (on)+import Data.Graph (SCC(..))+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Sequence (Seq)+import Data.Sequence qualified as DS+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Strict.These++import Agda.Syntax.Common+import Agda.Syntax.Info qualified as Info+import Agda.Syntax.Internal+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Monad.Benchmark (MonadBench, Phase)+import Agda.TypeChecking.Monad.Benchmark qualified as Bench+import Agda.TypeChecking.Positivity.Occurrence+import Agda.TypeChecking.Positivity.OccurrenceAnalysis+import Agda.TypeChecking.Positivity.Warnings qualified as W+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Records+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Warnings++import Agda.Syntax.Common.Pretty (prettyShow)+import Agda.Syntax.Common.Pretty qualified as P+import Agda.Utils.Functor+import Agda.Utils.Graph.AdjacencyMap.Unidirectional qualified as Graph+import Agda.Utils.List+import Agda.Utils.List1 qualified as List1+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.Size++import Agda.Utils.Impossible++-- | Check that the datatypes in the mutual block containing the given+-- declarations are strictly positive.+--+-- Find polarity of datatypes parameters and indices.+--+-- Also add information about positivity and recursivity of records+-- to the signature.+checkStrictlyPositive :: Info.MutualInfo -> Set QName -> TCM ()+checkStrictlyPositive mi qset = Bench.billTo [Bench.Positivity] do++ let qs = Set.toList qset+ reportSDoc "tc.pos.tick" 100 $ "positivity of" <+> prettyTCM qs++ -- Collect relevant information about the block.+ preprocessBlock qs >>= \case+ Nothing -> do+ pure () -- skip the whole thing if there's nothing to check+ Just blockInfo -> do++ -- compute the occurrence graph+ --------------------------------------------------------------------------------+ (g, mutuals) <- buildOccurrenceGraph qs+ sccs <- lift $ stronglyConnComp g++ -- /lazily computed/ generic graph for debug printing and warnings+ let ggeneric = toGenericGraph g++ reportSDoc "tc.pos.tick" 100 $ "constructed graph"+ reportSLn "tc.pos.graph" 5 $ "Positivity graph: N=" ++ show (size $ Graph.nodes ggeneric) +++ " E=" ++ show (length $ Graph.edges ggeneric)+ reportSDoc "tc.pos.graph" 10 $ vcat+ [ "positivity graph for" <+> fsep (map prettyTCM qs)+ , nest 2 $ prettyTCM ggeneric+ ]++ -- set mutual blocks+ --------------------------------------------------------------------------------+ reportSDoc "tc.pos.graph.sccs" 10 $ do+ let (triv, others) = partitionEithers $ for sccs $ \case+ AcyclicSCC v -> Left v+ CyclicSCC vs -> Right vs+ sep [ text $ show (length triv) ++ " trivial sccs"+ , text $ show (length others) ++ " non-trivial sccs with lengths " +++ show (map length others)+ ]+ reportSLn "tc.pos.graph.sccs" 15 $+ " sccs = " ++ prettyShow [ scc | CyclicSCC scc <- sccs ]++ -- #7133: Note that the graph doesn't necessarily contain all of qs in the case where there are no+ -- occurrences of a name, but we still need to setMutual for them.+ let ~sccMap = Map.unions [ case scc of+ AcyclicSCC (DefNode q) -> Map.singleton q []+ AcyclicSCC ArgNode{} -> mempty+ CyclicSCC scc -> Map.fromList [ (q, qs) | q <- qs ]+ where qs = [ q | DefNode q <- scc ]+ | scc <- sccs ]++ inAbstractMode $ forM_ qs \q -> do+ whenM (isNothing <$> getMutual q) do++ let qs = fromMaybe [] $ Map.lookup q sccMap+ reportSLn "tc.pos.mutual" 10 $ "setting " ++ prettyShow q ++ " to " +++ if | null qs -> "non-recursive"+ | length qs == 1 -> "recursive"+ | otherwise -> "mutually recursive"+ setMutual q qs++ forM_ blockInfo \(q, arity, dataTypeOrRec, _) -> inConcreteOrAbstractMode q \_ -> do++ -- set argument occurrences+ --------------------------------------------------------------------------------+ when (arity > 0) do+ reportSDoc "tc.pos.args" 10 $ "computing arg occurrences of " <+> prettyTCM q++ -- If there is no outgoing edge @ArgNode q i@, all @n@ arguments are @Unused@.+ -- Otherwise, we obtain the occurrences from the Graph.+ !args <- forM [0 .. arity-1] \i -> lift $ transitiveOccurrence g (ArgNode q i) (DefNode q)+ -- [0 .. max m (arity - 1)] -- triggers issue #3049++ reportSDoc "tc.pos.args" 10 $ sep+ [ "args of" <+> prettyTCM q <+> "="+ , nest 2 $ prettyList $ map prettyTCM args+ ]++ let mergeOccs :: [Occurrence] -> [Occurrence] -> [Occurrence]+ mergeOccs poccs toccs =+ -- Lucas, 2022-12-01:+ -- `poccs` are the occurences computed by the positivity-checker+ -- `toccs` are the occurences/polarities explicitely given by the user+ -- (and enforced through type-checking)+ -- We consider the polarities explicitely given (toccs) to take priority over the ones+ -- found out by the positivity checker.+ -- Note: Alas, this is hard to enforce given that non-annotated variables are+ -- always annotated with Mixed polarity. If the annotated polarity is Mixed,+ -- for now we always rely on the result from the positivity analysis.+ align poccs toccs <&> mergeThese (\a b -> if b == Mixed then a else b)++ !oldOccs <- getArgOccurrences q+ let !newOccs = let x = mergeOccs args oldOccs in deepseq x x+ setArgOccurrences q newOccs+ reportSDoc "tc.pos.tick" 100 $ "set args"+++ -- check positivity+ --------------------------------------------------------------------------------+ case dataTypeOrRec of+ Nothing -> pure ()+ Just (pc, dr) -> do+ reportSDoc "tc.pos.check" 10 $ "Checking positivity of" <+> prettyTCM q++ let ~ggeneric' = fmap (fmap DS.singleton) ggeneric++ reason bound =+ case W.productOfEdgesInBoundedWalk+ (\(Edge o _) -> o) ggeneric' (DefNode q) (DefNode q) bound of+ Just (Edge _ how) -> how+ Nothing -> __IMPOSSIBLE__++ how :: String -> Occurrence -> TCM Doc+ how msg bound = fsep $+ [prettyTCM q] ++ pwords "is" +++ pwords (msg ++ ", because it occurs") +++ [prettyTCM (reason bound)]++ -- if we have a negative loop, raise error+ -- ASR (23 December 2015). We don't raise a strictly positive+ -- error if the NO_POSITIVITY_CHECK pragma was set. See Issue 1614.+ -- Andreas, 2026-02-27:+ -- This information now comes either with the mututal block+ -- or with the data/record type, see issue #3355.+ loop <- do+ posCheck <- positivityCheckEnabled+ let nopc = NoPositivityCheck+ if Info.mutualPositivityCheck mi == nopc || pc == nopc || not posCheck then+ pure Nothing+ else do+ loop <- lift $ transitiveOccurrence g (DefNode q) (DefNode q)+ when (loop <= JustPos) $ warning $ NotStrictlyPositive q (reason JustPos)+ pure $ Just loop++ let checkInduction :: QName -> TCM ()+ checkInduction q =+ -- Check whether the recursive record has been declared as+ -- 'Inductive' or 'Coinductive'. Otherwise, error.+ unlessM (isJust . recInduction . theDef <$> getConstInfo q) $+ setCurrentRange (nameBindingSite q) $+ warning $ RecursiveRecordNeedsInductivity q++ -- Recursivity needs to be declared for inductive records.+ -- Eta should be off for unguarded records.+ case dr of+ IsData -> return ()+ IsRecord pat -> do+ loop <- case loop of+ Nothing -> lift $ transitiveOccurrence g (DefNode q) (DefNode q)+ Just loop -> pure loop+ case loop of+ o | o <= StrictPos -> do+ reportSDoc "tc.pos.record" 5 $ how "not guarded" StrictPos+ unguardedRecord q+ checkInduction q+ o | o <= GuardPos -> do+ reportSDoc "tc.pos.record" 5 $ how "recursive" GuardPos+ checkInduction q+ Unused -> reportSDoc "tc.pos.record" 10 $+ "record type" <+> prettyTCM q <+> "is not recursive"+ _ -> return ()++ reportSDoc "tc.pos.tick" 100 $ "checked positivity"++getDefArity :: Definition -> TCM Int+getDefArity def = do+ let go :: Type -> Int -> ReduceM Int+ go !a !n = (unEl <$> reduce a) >>= \case+ Pi a b -> underAbsReduceM a b \b -> go b (n + 1)+ _ -> pure n+ n <- liftReduce (go (defType def) 0)+ pure $! n - projectionArgs def++-- Andreas, 2018-11-23, issue #3404+-- Only assign argument occurrences to things which have a definition.+-- Things without a definition would be judged "constant" in all arguments,+-- since no occurrence could possibly be found, naturally.+hasDefinition :: Defn -> Bool+hasDefinition = \case+ Axiom{} -> False+ DataOrRecSig{} -> False+ GeneralizableVar{} -> False+ AbstractDefn{} -> False+ Primitive{} -> False+ PrimitiveSort{} -> False+ Constructor{} -> False+ Function{} -> True+ Datatype{} -> True+ Record{} -> True++isDatatype :: Definition -> Maybe (PositivityCheck, DataOrRecord)+isDatatype def = do+ case theDef def of+ Datatype{dataClause = Nothing, dataPositivityCheck} ->+ Just (dataPositivityCheck, IsData)+ Record {recClause = Nothing, recPositivityCheck, recPatternMatching } ->+ Just (recPositivityCheck, IsRecord recPatternMatching)+ _ -> Nothing++-- Result: [(name, arity, data or record, do we need to setMutual)] or Nothing if we don't need any+-- occurrence analysis.+preprocessBlock :: [QName] -> TCM (Maybe ([(QName, Int, Maybe (PositivityCheck, DataOrRecord), Bool)]))+preprocessBlock qs = do+ let go [] = pure []+ go (q:qs) = inConcreteOrAbstractMode q \def -> do+ !arity <- case hasDefinition (theDef def) of+ True -> getDefArity def+ False -> pure 0+ let !dr = isDatatype def+ let !needToSetMutual = isNothing (getMutual_ (theDef def))+ !rest <- go qs+ pure ((q, arity, dr, needToSetMutual) : rest)+ info <- go qs+ case any (\(_, arity, dr, setMut) -> arity /= 0 || isJust dr || setMut) info of+ True -> pure $ Just info+ _ -> pure Nothing+++-- Pretty printing+----------------------------------------------------------------------------------------------------++instance PrettyTCM Node where+ prettyTCM = return . P.pretty++instance P.Pretty a => PrettyTCMWithNode (Edge a) where+ prettyTCMWithNode (WithNode n (Edge o w)) = vcat+ [ prettyTCM o <+> prettyTCM n+ , nest 2 $ return $ P.pretty w+ ]++instance PrettyTCM (Seq W.OccursWhere) where+ prettyTCM =+ fmap snd . prettyOWs . map adjustLeftOfArrow . uniq . Fold.toList+ where+ nth 0 = pwords "first"+ nth 1 = pwords "second"+ nth 2 = pwords "third"+ nth n = pwords $ show (n + 1) ++ "th"++ -- Removes consecutive duplicates.+ uniq :: [W.OccursWhere] -> [W.OccursWhere]+ uniq = map List1.head . List1.groupBy ((==) `on` snd')+ where+ snd' (W.OccursWhere _ _ ws) = ws++ prettyOWs :: MonadPretty m => [W.OccursWhere] -> m (String, Doc)+ prettyOWs [] = __IMPOSSIBLE__+ prettyOWs [o] = do+ (s, d) <- prettyOW o+ return (s, d <> ".")+ prettyOWs (o:os) = do+ (s1, d1) <- prettyOW o+ (s2, d2) <- prettyOWs os+ return (s1, d1 <> ("," P.<+> "which" P.<+> P.text s2 P.$$ d2))++ prettyOW :: MonadPretty m => W.OccursWhere -> m (String, Doc)+ prettyOW (W.OccursWhere _ cs ws)+ | null cs = prettyWs ws+ | otherwise = do+ (s, d1) <- prettyWs ws+ (_, d2) <- prettyWs cs+ return (s, d1 P.$$ "(" <> d2 <> ")")++ prettyWs :: MonadPretty m => Seq W.Where -> m (String, Doc)+ prettyWs ws = case Fold.toList ws of+ [W.InDefOf d, W.InIndex] ->+ (,) "is" <$> fsep (pwords "an index of" ++ [prettyTCM d])+ _ ->+ (,) "occurs" <$>+ Fold.foldrM (\w d -> return d $$ fsep (prettyW w)) empty ws++ prettyW :: MonadPretty m => W.Where -> [m Doc]+ prettyW = \case+ W.LeftOfArrow -> pwords "to the left of an arrow"+ W.DefArg q i -> pwords "in the" ++ nth i ++ pwords "argument of" +++ [prettyTCM q]+ W.UnderInf -> pwords "under" +++ [do -- this cannot fail if an 'UnderInf' has been generated+ inf <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinInf+ prettyTCM inf]+ W.VarArg p i -> pwords "in an argument of a bound variable at position" ++ [prettyTCM i]+ ++ pwords "which uses its argument with polarity" ++ [ pretty p ]+ W.MetaArg -> pwords "in an argument of a metavariable"+ W.ConArgType c -> pwords "in the type of the constructor" ++ [prettyTCM c]+ W.IndArgType c -> pwords "in an index of the target type of the constructor" ++ [prettyTCM c]+ W.ConEndpoint c -> pwords "in an endpoint of the target of the" +++ pwords "higher constructor" ++ [prettyTCM c]+ W.InClause i -> pwords "in the" ++ nth i ++ pwords "clause"+ W.Matched -> pwords "as matched against"+ W.InIndex -> pwords "as an index"+ W.InSort -> pwords "in a sort"+ W.InDefOf d -> pwords "in the definition of" ++ [prettyTCM d]++ adjustLeftOfArrow :: W.OccursWhere -> W.OccursWhere+ adjustLeftOfArrow (W.OccursWhere r cs os) =+ W.OccursWhere r (DS.filter (not . isArrow) cs) $+ noArrows+ DS.><+ case DS.viewl startsWithArrow of+ DS.EmptyL -> DS.empty+ w DS.:< ws -> w DS.<| DS.filter (not . isArrow) ws+ where+ (noArrows, startsWithArrow) = DS.breakl isArrow os++ isArrow W.LeftOfArrow{} = True+ isArrow _ = False
src/full/Agda/TypeChecking/Positivity/Occurrence.hs view
@@ -2,87 +2,28 @@ -- | Occurrences. -module Agda.TypeChecking.Positivity.Occurrence- ( PragmaPolarities- , Occurrence(..)- , OccursWhere(..)- , Where(..)- , boundToEverySome- , productOfEdgesInBoundedWalk- , modalPolarityToOccurrence- ) where+module Agda.TypeChecking.Positivity.Occurrence where import Prelude hiding (null)- import Control.DeepSeq-import Control.Monad--import Data.Foldable (toList)--import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import Data.Sequence (Seq)--import GHC.Generics (Generic)+import Data.Hashable import Agda.Syntax.Common-import Agda.Syntax.Common.Pretty import Agda.Syntax.Abstract.Name+import Agda.Syntax.Common.Pretty qualified as P import Agda.Syntax.Position--import Agda.Utils.Graph.AdjacencyMap.Unidirectional (Graph)-import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as Graph+import Agda.Utils.Hash import Agda.Utils.List1 (List1) import Agda.Utils.Null import Agda.Utils.SemiRing-import Agda.Utils.Size -import Agda.Utils.Impossible --- Specification of occurrences ----------------------------------------------- Operations and instances in Agda.TypeChecking.Positivity.+-- Occurrences+---------------------------------------------------------------------------------------------------- -- | List of polarities stemming from POLARITY pragma. type PragmaPolarities = List1 (Ranged Occurrence) --- | Description of an occurrence.-data OccursWhere- = OccursWhere Range (Seq Where) (Seq Where)- -- ^ The elements of the sequences, read from left to right,- -- explain how to get to the occurrence. The second sequence- -- 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, Generic)--instance NFData OccursWhere--instance Null OccursWhere where- empty = OccursWhere empty empty empty- null (OccursWhere r wh1 wh2) = and [ null r, null wh1, null wh2 ]---- | One part of the description of an occurrence.-data Where- = LeftOfArrow- | DefArg QName Nat -- ^ in the nth argument of a define constant- | UnderInf -- ^ in the principal argument of built-in ∞- | VarArg Occurrence Nat -- ^ as an argument to a bound variable.- -- The polarity, if given, is the polarity of- -- the argument the occurence is in- | MetaArg -- ^ as an argument of a metavariable- | ConArgType QName -- ^ in the type of a constructor- | IndArgType QName -- ^ in a datatype index of a constructor- | ConEndpoint QName- -- ^ in an endpoint of a higher constructor- | InClause Nat -- ^ in the nth clause of a defined function- | 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, Generic)--instance NFData Where- -- | Subterm occurrences for positivity checking. -- The constructors are listed in increasing information they provide: -- @Mixed <= JustPos <= StrictPos <= GuardPos <= Unused@@@ -93,13 +34,11 @@ | JustPos -- ^ Positive occurrence, but not strictly positive. | StrictPos -- ^ Strictly positive occurrence. | GuardPos -- ^ Guarded strictly positive occurrence (i.e., under ∞). For checking recursive records.- | Unused -- ^ No occurrence.+ | Unused -- ^ No occurrence. deriving (Show, Eq, Ord, Enum, Bounded) --- Pretty instances.--instance Pretty Occurrence where- pretty = text . \case+instance P.Pretty Occurrence where+ pretty = P.text . \case Unused -> "_" Mixed -> "*" JustNeg -> "-"@@ -107,33 +46,9 @@ StrictPos -> "++" GuardPos -> "g+" -instance Pretty Where where- pretty = \case- LeftOfArrow -> "LeftOfArrow"- DefArg q i -> "DefArg" <+> pretty q <+> pretty i- UnderInf -> "UnderInf"- VarArg k i -> "VarArg" <+> pretty k <+> pretty i- MetaArg -> "MetaArg"- ConArgType q -> "ConArgType" <+> pretty q- IndArgType q -> "IndArgType" <+> pretty q- ConEndpoint q- -> "ConEndpoint" <+> pretty q- InClause i -> "InClause" <+> pretty i- Matched -> "Matched"- IsIndex -> "IsIndex"- InDefOf q -> "InDefOf" <+> pretty q--instance Pretty OccursWhere where- pretty = \case- OccursWhere _r ws1 ws2 ->- "OccursWhere _" <+> pretty (toList ws1) <+> pretty (toList ws2)---- Other instances for 'Occurrence'.- instance NFData Occurrence where rnf x = seq x () -instance KillRange Occurrence where- killRange = id+instance KillRange Occurrence where killRange = id -- | 'Occurrence' is a complete lattice with least element 'Mixed' -- and greatest element 'Unused'.@@ -143,7 +58,6 @@ -- -- For 'oplus', 'Unused' is neutral (zero) and 'Mixed' is dominant. -- For 'otimes', 'StrictPos' is neutral (one) and 'Unused' is dominant.- instance SemiRing Occurrence where ozero = Unused oone = StrictPos@@ -185,69 +99,111 @@ instance Null Occurrence where empty = Unused --- Other instances for 'OccursWhere'.+modalPolarityToOccurrence :: ModalPolarity -> Occurrence+modalPolarityToOccurrence = \case+ UnusedPolarity -> Unused+ StrictlyPositive -> StrictPos+ Positive -> JustPos+ Negative -> JustNeg+ MixedPolarity -> Mixed --- There is an orphan PrettyTCM instance for Seq OccursWhere in--- Agda.TypeChecking.Positivity.+-- Paths to occurrences+---------------------------------------------------------------------------------------------------- -instance Sized OccursWhere where- size (OccursWhere _ cs os) = 1 + size cs + size os- natSize (OccursWhere _ cs os) = 1 + natSize cs + natSize os+data OccursPath+ = Root+ | LeftOfArrow !OccursPath+ | DefArg !OccursPath !QName !Nat -- ^ in the nth argument of a defined constant+ | MutDefArg !OccursPath !QName !Nat -- ^ in the nth argument of a def in the current mutual block.+ -- (def given by Int index in the block)+ | UnderInf !OccursPath -- ^ in the principal argument of built-in ∞+ | VarArg !OccursPath !Nat !Occurrence -- ^ as an argument to a bound variable with given polarity.+ -- The polarity is only used for warning printing.+ | MetaArg !OccursPath -- ^ as an argument of a metavariable+ | ConArgType !OccursPath !QName -- ^ in the type of a constructor+ | IndArgType !OccursPath !QName -- ^ in a datatype index of a constructor+ | ConEndpoint !OccursPath !QName -- ^ in an endpoint of a higher constructor+ | InClause !OccursPath !Nat -- ^ in the nth clause of a defined function+ | Matched !OccursPath -- ^ matched against in a clause of a defined function+ | InIndex !OccursPath -- ^ is an index of an inductive family+ | InSort !OccursPath -- ^ in a sort, e.g. in the level of a universe+ | InDefOf !OccursPath !QName -- ^ in the definition of a constant+ deriving Eq --- | The map contains bindings of the form @bound |-> ess@, satisfying--- the following property: for every non-empty list @w@,--- @'foldr1' 'otimes' w '<=' bound@ iff--- @'or' [ 'all' every w '&&' 'any' some w | (every, some) <- ess ]@.+instance NFData OccursPath where+ rnf x = seq x () -boundToEverySome ::- Map Occurrence [(Occurrence -> Bool, Occurrence -> Bool)]-boundToEverySome = Map.fromListWith __IMPOSSIBLE__- [ ( JustPos- , [((/= Unused), (`elem` [Mixed, JustNeg, JustPos]))]- )- , ( StrictPos- , [ ((/= Unused), (`elem` [Mixed, JustNeg, JustPos]))- , ((not . (`elem` [Unused, GuardPos])), const True)- ]- )- , ( GuardPos- , [((/= Unused), const True)]- )- ]+instance Show OccursPath where+ show p = go p [] where+ go p acc = case p of+ Root -> acc+ LeftOfArrow p -> go p $ " InLeftOfArrow" ++ acc+ DefArg p q i -> go p $ " InDefArg " ++ P.prettyShow q ++ " " ++ P.prettyShow i ++ acc+ MutDefArg p q i -> go p $ " InMutDefArg " ++ P.prettyShow q ++ " " ++ P.prettyShow i ++ acc+ UnderInf p -> go p $ " InUnderInf" ++ acc+ VarArg p i o -> go p $ " InVarArg " ++ P.prettyShow i ++ " " ++ P.prettyShow o ++ acc+ MetaArg p -> go p $ " InMetaArg" ++ acc+ ConArgType p q -> go p $ " InConArgType " ++ P.prettyShow q ++ acc+ IndArgType p q -> go p $ " InIndArgType " ++ P.prettyShow q ++ acc+ ConEndpoint p q -> go p $ " InConEndpoint " ++ P.prettyShow q ++ acc+ InClause p i -> go p $ " InClause " ++ P.prettyShow i ++ acc+ Matched p -> go p $ " Matched" ++ acc+ InIndex p -> go p $ " InIndex" ++ acc+ InSort p -> go p $ " InSort" ++ acc+ InDefOf p q -> go p $ " InDefOf " ++ P.prettyShow q ++ acc --- | @productOfEdgesInBoundedWalk occ g u v bound@ returns a value--- distinct from 'Nothing' iff there is a walk @c@ (a list of edges)--- in @g@, from @u@ to @v@, for which the product @'foldr1' 'otimes'--- ('map' occ c) '<=' bound@. In this case the returned value is--- @'Just' ('foldr1' 'otimes' c)@ for one such walk @c@.------ Preconditions: @u@ and @v@ must belong to @g@, and @bound@ must--- belong to the domain of @boundToEverySome@.+instance P.Pretty OccursPath where+ pretty = P.text . show --- There is a property for this function in--- Internal.Utils.Graph.AdjacencyMap.Unidirectional.+data OccursWhere = OccursWhere !Range !OccursPath+ deriving (Eq, Show) -productOfEdgesInBoundedWalk ::- (SemiRing e, Ord n) =>- (e -> Occurrence) -> Graph n e -> n -> n -> Occurrence -> Maybe e-productOfEdgesInBoundedWalk occ g u v bound =- case Map.lookup bound boundToEverySome of- Nothing -> __IMPOSSIBLE__- Just ess ->- case msum [ Graph.walkSatisfying- (every . occ . Graph.label)- (some . occ . Graph.label)- g u v- | (every, some) <- ess- ] of- Just es@(_ : _) -> Just (foldr1 otimes (map Graph.label es))- Just [] -> __IMPOSSIBLE__- Nothing -> Nothing+instance P.Pretty OccursWhere where+ pretty (OccursWhere x y) = "OccursWhere" P.<+> P.pretty x P.<+> P.pretty y -modalPolarityToOccurrence :: ModalPolarity -> Occurrence-modalPolarityToOccurrence = \case- UnusedPolarity -> Unused- StrictlyPositive -> StrictPos- Positive -> JustPos- Negative -> JustNeg- MixedPolarity -> Mixed++-- Occurrence graph nodes+----------------------------------------------------------------------------------------------------++data Node+ = DefNode QName -- ^ Definition site of a mutual definition+ | ArgNode QName Int -- ^ Occurrence of the nth definition argument inside+ -- the definition.+ deriving (Eq, Ord, Show)++instance Hashable Node where+ hashWithSalt h = \case+ DefNode x -> h + 1 `hashWithSalt` x+ ArgNode x i -> fromIntegral+ (fromIntegral (h + 2 `hashWithSalt` x) `combineWord` fromIntegral i)++instance P.Pretty Node where+ pretty = \case+ DefNode q -> P.pretty q+ ArgNode q i -> P.pretty q <> P.text ("." ++ show i)++-- Occurrence graph edges+----------------------------------------------------------------------------------------------------++data Edge a = Edge !Occurrence !a+ deriving (Eq, Ord, Show, Functor)++mergeEdges :: Edge a -> Edge a -> Edge a+mergeEdges _ e@(Edge Mixed _) = e -- dominant+mergeEdges e@(Edge Mixed _) _ = e+mergeEdges (Edge Unused _) e = e -- neutral+mergeEdges e (Edge Unused _) = e+mergeEdges (Edge JustNeg _) e@(Edge JustNeg _) = e+mergeEdges _ e@(Edge JustNeg a) = Edge Mixed a+mergeEdges e@(Edge JustNeg a) _ = Edge Mixed a+mergeEdges _ e@(Edge JustPos _) = e -- dominates strict pos.+mergeEdges e@(Edge JustPos _) _ = e+mergeEdges _ e@(Edge StrictPos _) = e -- dominates 'GuardPos'+mergeEdges e@(Edge StrictPos _) _ = e+mergeEdges (Edge GuardPos _) e@(Edge GuardPos _) = e++instance Monoid a => SemiRing (Edge a) where+ ozero = Edge ozero mempty+ oone = Edge oone mempty+ oplus = mergeEdges+ otimes (Edge o1 w1) (Edge o2 w2) = Edge (otimes o1 o2) (w1 <> w2)
+ src/full/Agda/TypeChecking/Positivity/OccurrenceAnalysis.hs view
@@ -0,0 +1,989 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE MagicHash #-}+{-# OPTIONS_GHC -Wno-redundant-bang-patterns #-}+{-# OPTIONS_GHC -fmax-worker-args=20 #-}++#if __GLASGOW_HASKELL__ > 902+{-# OPTIONS_GHC -fworker-wrapper-cbv #-}+#endif++{- |+Computing the occurrence graph for a mutual block. This is used to compute polarities of arguments+and to check positivity.++- We do a traversal over internal syntax.+- The occurrence graph is 'NodeMap (NodeMap Edge)', where 'NodeMap' is a mutable hashtable keyed by+ graph nodes. The outer keys are sources and the inner keys are targets. We insert edges into the+ graph during the traversal.+- An edge from source to target means that source occurs in target.+- A graph node is either 'DefNode QName', which is a definition site of a mutual name, or 'ArgNode+ QName Int', which is an argument of a mutual name, indexed left-right starting from 0.+- An edge contains an 'Occurrence', the 'Range' of the actual occurrence in the internal syntax and+ an 'OccursPath' that can be used to produce a textual warning message.++The occurrence graph is imprecise in several ways.++- We only normalize types of data constructors and don't compute anything else.+- We have at most a single edge between two nodes. We aggregate multiple actual occurrences into a+ single edge, using 'mergeEdges'.++Lastly, applications of mutual names to arguments is handled in a rather imprecise way. See Issue+1984 for illustration:++@+mutual+ record Fun (A : Set) (B : A → Set) : Set where+ field fun : (x : A) → B x++ data U : Set where+ Π : (A : U) (B : El A → U) → U++ El : U → Set+ El (Π A B) = Fun (El A) (λ x → El (B x))+@++In this case:++- @Fun@ occurs in @El@.+- @El A@ occurs in the first argument of @Fun@.+- The first argument of @Fun@ occurs in @Fun@.++In short, when we apply a mutual name to an argument, we view that as if the argument was+__substituted__ inside the body of the mutual name definition.++Hence, @Fun@ "occurs" in @Fun@, and it does so negatively. This is kinda bogus, because @Fun@ could+be moved outside of the mutual block.++A potential fix of this issue would be to first split the mutual block into strongly connected+components based on only QName occurrences, and afterwards do the current occurrence analysis for+each sub-block.++__Immutable representation__++Instead of using the mutable hashtable, we use immutable "generic" graphs from+'Agda.Utils.Graph.AdjacencyMap.Unidirectional' for printing warnings and debug messages, and also to+define tests in internal property tests. One reason is convenience. Another reason is that the+previous (less optimized) implementation before PR 8411 used the generic graphs, and we just reuse+the old implementation for printing. See 'toGenericGraph' and 'fromGenericGraph'.+-}++module Agda.TypeChecking.Positivity.OccurrenceAnalysis (+ Node+ , pattern DefNode+ , pattern ArgNode+ , Edge(..)+ , type OccGraph+ , buildOccurrenceGraph+ , stronglyConnComp+ , transitiveOccurrence+ , adjacencyList+ , lookupNode+ , toGenericGraph+ , fromGenericGraph+ ) where++import Prelude hiding ( null, (!!) )++import Data.Coerce+import Data.Foldable (foldl')+import Data.Hashable+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Sequence (Seq, pattern (:|>))+import Data.Sequence qualified as DS+import Data.Graph qualified+import Data.Word+import Data.Bits+import Control.Exception+import System.IO.Unsafe++import Agda.Interaction.Options.Base (optCumulativity, optOccurrence, optPolarity)+import Agda.Syntax.Internal+import Agda.Syntax.Internal.Pattern+import Agda.Syntax.Position (HasRange(..), noRange, Range)+import Agda.TypeChecking.Functions+import Agda.TypeChecking.Monad hiding (getOccurrencesFromType)+import Agda.TypeChecking.Patterns.Match (properlyMatching)+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Positivity.Occurrence+import Agda.TypeChecking.Positivity.Warnings qualified as W+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope++import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty qualified as P+import Agda.Utils.ExpandCase+import Agda.Utils.Hash+import Agda.Utils.HashTable qualified as HT+import Agda.Utils.Impossible+import Agda.Utils.List+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.SemiRing+import Agda.Utils.Size+import Agda.Utils.StrictReader+import Agda.Utils.Graph.AdjacencyMap.Unidirectional qualified as Graph+import Agda.Utils.MinimalArray.MutableLifted qualified as MArr+import Agda.Utils.MinimalArray.Lifted qualified as Arr+++-- Maps keyed by Node+----------------------------------------------------------------------------------------------------++type NodeMap v = HT.HashTableLL Node v++-- | Getting the "found" and "not found" branches as arguments. We+-- do this to fuse away the 'Maybe' in the lookup result.+{-# INLINE lookupNode #-}+lookupNode :: Node -> NodeMap v -> (v -> IO a) -> IO a -> IO a+lookupNode node map found notfound = HT.lookupCPS node map found notfound++{-# INLINE lookupMutual #-}+lookupMutual :: QName -> (Int -> OccM a) -> OccM a -> OccM a+lookupMutual q found notfound = ReaderT \e -> TCM \tcs tce ->+ HT.lookupCPS q (mutuals e)+ (\x -> unTCM (runReaderT (found x) e) tcs tce)+ (unTCM (runReaderT notfound e) tcs tce)++{-# NOINLINE insertMutual #-}+insertMutual :: Mutuals -> QName -> Int -> IO ()+insertMutual muts q arity = HT.insert muts q arity++{-# NOINLINE insertNode #-}+insertNode :: Node -> v -> NodeMap v -> IO ()+insertNode n v map = HT.insert map n v++{-# NOINLINE nodeMapToList #-}+nodeMapToList :: NodeMap v -> IO [(Node, v)]+nodeMapToList map = coerce (HT.toList map)++{-# NOINLINE cloneNodeMap #-}+cloneNodeMap :: NodeMap v -> IO (NodeMap v)+cloneNodeMap = HT.clone++-- Occurrence graph+----------------------------------------------------------------------------------------------------++-- | Meaning of the graph: the keys in the outer NodeMap occur in the keys of the inner NodeMap.+type OccGraph = NodeMap (NodeMap (Edge OccursWhere))++{-# NOINLINE addEdgeToGraph #-}+addEdgeToGraph :: Node -> Node -> Edge OccursWhere -> OccGraph -> IO ()+addEdgeToGraph src tgt e graph = lookupNode src graph+ (\tgts -> lookupNode tgt tgts+ (\e' -> insertNode tgt (mergeEdges e e') tgts)+ (insertNode tgt e tgts))+ (do+ tgts <- HT.empty+ insertNode tgt e tgts+ insertNode src tgts graph)++{-# NOINLINE adjacencyList #-}+adjacencyList :: OccGraph -> IO [(Node, Node, Edge OccursWhere)]+adjacencyList graph = do+ assocs <- nodeMapToList graph+ assocs <- forM assocs \(src, tgts) -> (src,) <$!> nodeMapToList tgts+ pure [(src, tgt, e) | (src, tgts) <- assocs, (tgt, e) <- tgts]++{-# NOINLINE addTargetNodesAsSource #-}+-- | For every node appearing as a target but not as a source, add it as a source node with empty+-- map for targets. This is an invariant that's required by Data.Graph.stronglyConnComp.+addTargetNodesAsSource :: OccGraph -> IO OccGraph+addTargetNodesAsSource graph = do+ graph' <- cloneNodeMap graph+ HT.forAssocs graph \src tgts ->+ HT.forAssocs tgts \tgt _ -> lookupNode tgt graph+ (\_ -> pure ())+ (do+ edges <- HT.empty+ insertNode tgt edges graph')+ pure graph'++{-# NOINLINE stronglyConnComp #-}+-- | Strongly connected components, in reverse topological order.+stronglyConnComp :: OccGraph -> IO [Data.Graph.SCC Node]+stronglyConnComp graph = do+ graph <- addTargetNodesAsSource graph+ assocs <- nodeMapToList graph+ assocs <- forM assocs \(src, tgts) -> (src,src,) . map' fst <$!> nodeMapToList tgts+ pure $! Data.Graph.stronglyConnComp assocs++{-# NOINLINE toGenericGraph #-}+-- | Convert to generic Utils graph, for the purpose of testing and warning rendering.+toGenericGraph :: OccGraph -> Graph.Graph Node (Edge W.OccursWhere)+toGenericGraph graph = unsafeDupablePerformIO do++ let convEdge :: Edge OccursWhere -> Edge W.OccursWhere+ convEdge (Edge occ (OccursWhere rng path)) = Edge occ (convPath rng path)++ convPath :: Range -> OccursPath -> W.OccursWhere+ convPath rng path = let++ go' :: OccursPath -> Seq W.Where+ go' = \case+ Root -> mempty+ MutDefArg p x i -> go' p :|> W.DefArg x i+ LeftOfArrow p -> go' p :|> W.LeftOfArrow+ DefArg p x i -> go' p :|> W.DefArg x i+ UnderInf p -> go' p :|> W.UnderInf+ VarArg p i o -> go' p :|> W.VarArg o i+ MetaArg p -> go' p :|> W.MetaArg+ ConArgType p x -> go' p :|> W.ConArgType x+ IndArgType p x -> go' p :|> W.IndArgType x+ ConEndpoint p x -> go' p :|> W.ConEndpoint x+ InClause p i -> go' p :|> W.InClause i+ Matched p -> go' p :|> W.Matched+ InIndex p -> go' p :|> W.InIndex+ InSort p -> go' p :|> W.InSort+ InDefOf p x -> go' p :|> W.InDefOf x++ go :: OccursPath -> (Seq W.Where, Seq W.Where)+ go = \case+ Root -> (mempty, mempty)+ MutDefArg p x i -> let s1 = go' p+ s2 = DS.singleton (W.DefArg x i)+ in (s1, s2)+ LeftOfArrow p -> (:|> W.LeftOfArrow) <$!> go p+ DefArg p x i -> (:|> W.DefArg x i) <$!> go p+ UnderInf p -> (:|> W.UnderInf) <$!> go p+ VarArg p i o -> (:|> W.VarArg o i) <$!> go p+ MetaArg p -> (:|> W.MetaArg) <$!> go p+ ConArgType p x -> (:|> W.ConArgType x) <$!> go p+ IndArgType p x -> (:|> W.IndArgType x) <$!> go p+ ConEndpoint p x -> (:|> W.ConEndpoint x) <$!> go p+ InClause p i -> (:|> W.InClause i) <$!> go p+ Matched p -> (:|> W.Matched) <$!> go p+ InIndex p -> (:|> W.InIndex) <$!> go p+ InSort p -> (:|> W.InSort) <$!> go p+ InDefOf p x -> (:|> W.InDefOf x) <$!> go p++ in case go path of (s1, s2) -> W.OccursWhere rng s1 s2++ let go :: Map Node (Map Node (Edge W.OccursWhere))+ -> (Node, Node, Edge OccursWhere)+ -> Map Node (Map Node (Edge W.OccursWhere))+ go m (src, tgt, convEdge -> e) =+ Map.insertWith (\_ -> Map.insert tgt e) src (Map.singleton tgt e) $+ Map.insertWith (\_ tgts -> tgts) tgt mempty $+ m++ assocs <- adjacencyList graph+ pure $! Graph.Graph $! foldl' go mempty assocs++-- | Make a graph from a generic one. We use this in testing in Internal.TypeChecking.Positivity+-- where it's much more convenient to generate immutable graphs. Note: we ignore occurrence+-- location info.+{-# NOINLINE fromGenericGraph #-}+fromGenericGraph :: Graph.Graph Node (Edge a) -> OccGraph+fromGenericGraph (Graph.Graph graph) = unsafeDupablePerformIO do+ graph' <- HT.empty+ forM_ (Map.toList graph) \(src, tgts) ->+ forM_ (Map.toList tgts) \(tgt, Edge o _) ->+ addEdgeToGraph src tgt (Edge o (OccursWhere noRange Root)) graph'+ pure graph'+++-- Occurrence analysis+----------------------------------------------------------------------------------------------------++{-+Occurrence analysis is a single traversal over definitions which builds a mutable graph in IO. We+keep track of the "path" during traversal that leads from the current position to a top definition.+-}++-- | Occurrence information for a variable that is bound as an argument of the+-- definition we are currently analysing.+data DefArgInEnv = DefArgInEnv+ Int+ -- ^ Which argument of the top-level definition this variable was bound as.+ [Occurrence]+ -- ^ How this variable uses its /own/ arguments: one 'Occurrence' per+ -- argument of the variable's type, in order.+ -- This is for instance computed by 'getOccurrencesFromType'+ -- from the polarity annotations on the domains of that type.+ deriving Show++-- | Mutual definition names in the block.+-- Each name is mapped to an arity. It's meaningful for 'FunctionDefn'-s; see 'preprocessMutuals'+-- for docs. For everything else it's set to @maxBound :: Int@.+type Mutuals = HT.HashTableLU QName Int++data OccEnv = OccEnv {+ topDef :: QName -- ^ The definition we're working under (as n-th definition in the mutual block)+ , topDefArgs :: [DefArgInEnv] -- ^ Occurrence info for definition args.+ , inf :: Maybe QName -- ^ Name for ∞ builtin.+ , sortOcc :: Occurrence -- ^ Occurrence to compose with when descending into a 'Sort'.+ -- See 'sortOccurrence'.+ , locals :: Int -- ^ Number of local binders (on the top of the definition args).+ , mutuals :: Mutuals -- ^ Set of mutual QName-s in the block.+ , target :: Node -- ^ We add occurrences pointing to this node.+ , path :: OccursPath -- ^ Path from the target node to the current position.+ , occ :: Occurrence -- ^ Occurence of current position.+ , graph :: OccGraph -- ^ Graph that's being built.+ }++type OccM = ReaderT OccEnv TCM++instance PrettyTCMWithNode (Edge OccursWhere) where+ prettyTCMWithNode (WithNode n (Edge o (OccursWhere _ w))) = vcat+ [ prettyTCM o <+> prettyTCM n+ , nest 2 $ return $ P.pretty w+ ]++{-# INLINE underPath #-}+underPath :: (OccursPath -> OccursPath) -> OccM a -> OccM a+underPath f = local \env -> env {path = f (path env)}++{-# INLINE underOcc #-}+underOcc :: Occurrence -> OccM a -> OccM a+underOcc p = local \env -> env {occ = otimes (occ env) p}++{-# INLINE underBinder #-}+underBinder :: OccM a -> OccM a+underBinder = local \env -> env {locals = locals env + 1}++{-# INLINE underPathOcc #-}+-- | Modify the current path and 'otimes' a new 'Occurrence' to the+-- current occurrence.+underPathOcc :: (OccursPath -> OccursPath) -> Occurrence -> OccM a -> OccM a+underPathOcc f p = local \e -> e {path = f (path e), occ = otimes (occ e) p}++{-# INLINE underPathSetOcc #-}+-- | Modify the current path and set the current 'Occurence' to+-- the given value.+underPathSetOcc :: (OccursPath -> OccursPath) -> Occurrence -> OccM a -> OccM a+underPathSetOcc f p = local \e -> e {path = f (path e), occ = p}++getOccurrencesFromType :: Type -> TCM [Occurrence]+getOccurrencesFromType a = (optPolarity <$> pragmaOptions) >>= \case+ False -> pure []+ True -> do+ let go :: Type -> ReduceM [Occurrence]+ go a = (unEl <$> reduce a) >>= \case+ Pi a b -> do+ let p = modalPolarityToOccurrence $ modPolarityAnn $ getModalPolarity a+ -- We're working under a Strict pragma, and we want this to be lazy,+ -- because we might have under-applied names where we don't want to+ -- unnecessarily compute types.+ ~ps <- underAbsReduceM a b \b -> go b+ pure (p:ps)+ _ -> pure []+ liftReduce (go a)++-- | The 'DefArgInEnv's for the variables bound by the given telescope,+-- when that telescope is the parameter telescope of the definition under+-- analysis.+--+-- The result is indexed by de Bruijn index (innermost first), as expected+-- by 'topDefArgs'. Variable @i@ stands for argument @n - 1 - i@.+paramsToDefArgs :: Telescope -> TCM [DefArgInEnv]+paramsToDefArgs tel = go 0 (telToList tel) [] where+ go i as acc = expand \ret -> case as of+ [] -> ret $ pure acc+ a:as -> ret do occs <- getOccurrencesFromType (snd (unDom a))+ go (i + 1) as (DefArgInEnv i occs : acc)++addRawEdge :: Range -> Occurrence -> Node -> Node -> OccM ()+addRawEdge rng occ src tgt = do+ path <- asks path+ graph <- asks graph+ let e = Edge occ (OccursWhere rng path)+ lift $ lift $ addEdgeToGraph src tgt e graph++addEdge :: Range -> Node -> OccM ()+addEdge rng src = do+ target <- asks target+ path <- asks path+ occ <- asks occ+ graph <- asks graph+ expand \ret -> case occ of+ Unused -> ret $ pure ()+ occ -> ret do+ let e = Edge occ (OccursWhere rng path)+ lift $ lift $ addEdgeToGraph src target e graph++-- | Recurse into an argument of a non-mutual definition.+occurrencesInDefArg :: QName -> Occurrence -> Int -> Elim -> OccM ()+occurrencesInDefArg d p i e = expand \ret -> case p of+ Unused -> ret $ pure ()+ p -> ret $ underPathOcc (\p -> DefArg p d i) p $ occurrences e++-- | Recurse into an argument of an argument of the top definition.+occurrencesInDefArgArg :: Occurrence -> Int -> Elim -> OccM ()+occurrencesInDefArgArg p i e = expand \ret -> case p of+ Unused -> ret $ pure ()+ p -> ret $ underPathOcc (\x -> VarArg x i p) p $ occurrences e++-- | Recurse into an argument of a mutual definition.+occurrencesInMutDefArg :: QName -> Occurrence -> Int -> Elim -> OccM ()+occurrencesInMutDefArg d p i e = expand \ret -> case p of+ Unused -> ret $ pure ()+ p -> ret $ local (\e -> e {path = MutDefArg (path e) d i, target = ArgNode d i, occ = p}) $+ occurrences e++-- | The 'Occurrence' to compose with when the analysis descends from a 'Term'+-- into a 'Sort' (issue #8688).+--+-- Without @--cumulativity@, distinct universes are unrelated: @Set x@ and+-- @Set y@ are neither equal nor in a subtyping relation unless @x@ and @y@ are+-- equal. So whatever a sort depends on has to be compared invariantly by the+-- conversion checker, and we return 'Mixed'.+--+-- With @--cumulativity@, universes are monotone in their level+-- (@Set x =< Set y@ iff @x =< y@, see @leqSort@ in+-- "Agda.TypeChecking.Conversion"), so a /positive/ occurrence is justified.+--+-- We deliberately return 'JustPos' and not 'StrictPos' here. Both give+-- 'Agda.TypeChecking.Polarity.Covariant' polarity, but only 'StrictPos' would+-- be accepted by the positivity checker, and an occurrence inside a sort must+-- not count as strictly positive: a definition like+-- @data D : Setω where c : Set (f D) → D@ defines @D@ by quantifying over a+-- universe whose size depends on @D@ itself.+--+-- Since @--no-cumulativity@ is a /coinfective/ option, a module that does not+-- use cumulativity can never import occurrence information that was computed+-- with cumulativity turned on.+sortOccurrence :: HasOptions m => m Occurrence+sortOccurrence = do+ cumulativity <- optCumulativity <$> pragmaOptions+ pure $! if cumulativity then JustPos else Mixed++-- | The initial 'Occurrence' when processing a definition.+mutualDefOcc :: Definition -> Occurrence+mutualDefOcc d = case theDef d of+ Datatype{} -> GuardPos+ Record{ recEtaEquality' = EtaEquality NoEta{} _ } -> GuardPos+ _ -> StrictPos++class ComputeOccurrences a where+ occurrences :: a -> OccM ()++ {-# INLINE occurrences #-}+ default occurrences :: (Foldable t, ComputeOccurrences b, a ~ t b) => a -> OccM ()+ occurrences = mapM_ occurrences++instance ComputeOccurrences Term where+ occurrences t = expand \ret -> case unSpine t of++ Var x es -> ret do+ locals <- asks locals++ -- it's a locally bound variable, all args are Mixed occurrence,+ -- we don't record an occurrence for the variable+ if x < locals then do+ let elims i es = expand \ret -> case es of+ [] -> ret $ pure ()+ e:es -> ret $ underPath (\p -> VarArg p i Mixed) (occurrences e) >> elims (i + 1) es++ underOcc Mixed $ elims 0 es++ -- it's bound in a top-level definition argument+ else do+ let elims i ps es = expand \ret -> case (ps, es) of+ (_ , [] ) -> ret $ pure ()+ ([] , e:es) -> ret $ occurrencesInDefArgArg Mixed i e >> elims (i + 1) [] es+ (p:ps, e:es) -> ret $ occurrencesInDefArgArg p i e >> elims (i + 1) ps es+ topDefArgs <- asks topDefArgs+ topDef <- asks topDef+ let DefArgInEnv argix ps = topDefArgs !! (x - locals)+ addEdge noRange (ArgNode topDef argix)+ elims 0 ps es++ Def d es -> ret $ asks inf >>= \case++ -- check for ∞ application+ Just inf | d == inf -> case es of+ [] -> pure ()+ [_] -> pure () -- unused arg+ [_, e] -> underPathOcc UnderInf GuardPos $ occurrences e+ _ -> __IMPOSSIBLE__++ _ -> do+ lookupMutual d++ -- it's a mutual definition+ (\arity -> do+ let range = getRange d+ addEdge range (DefNode d)+ expand \ret -> case es of+ [] -> ret $ pure () -- we skip the mutualDefOcc in this case+ es -> ret do+ def <- lift $ getConstInfo d+ let defOcc = mutualDefOcc def+ let elims d p i arity es = expand \ret -> case es of+ [] -> ret $ pure ()+ e:es -> ret $ expand \ret -> case i < arity of++ True -> ret do+ occurrencesInMutDefArg d p i e+ elims d p (i + 1) arity es++ -- we're over the formal arity of the definition so every arg occurs Mixed+ -- in its definition+ False -> ret do+ addRawEdge range Mixed (ArgNode d i) (DefNode d)+ occurrencesInMutDefArg d p i e+ elims d p (i + 1) arity es+ elims d defOcc 0 arity es+ )++ -- it's not a mutual definition, we use existing defArgOccurrences+ -- in each argument in the Elims+ (do+ def <- lift $ getConstInfo d+ case theDef def of+ Constructor{} -> do+ let elims i es = expand \ret -> case es of+ [] -> ret $ pure ()+ e:es -> ret do occurrencesInDefArg d StrictPos i e+ elims (i + 1) es+ elims 0 es++ _ -> do+ -- process Elims where we get Occurrence information from the type+ -- of the definition+ let elims' :: QName -> Int -> [Occurrence] -> Elims -> OccM ()+ elims' d i ps es = expand \ret -> case (ps, es) of+ (_ , [] ) -> ret $ pure ()+ (p:ps, e:es) -> ret do occurrencesInDefArg d p i e+ elims' d (i + 1) ps es+ ([], e:es) -> ret do occurrencesInDefArg d Mixed i e+ elims' d (i + 1) ps es++ -- process Elims where we get Occurrences from defArgOccurrences+ let elims :: QName -> Type -> Int -> [Occurrence] -> Elims -> OccM ()+ elims d a i ps es = expand \ret -> case (ps, es) of+ (_ , [] ) -> ret $ pure ()+ (p:ps, e:es) -> ret do occurrencesInDefArg d p i e+ elims d a (i + 1) ps es+ ([] , e:es) -> ret do ps <- lift $ getOccurrencesFromType a+ elims' d i (drop i ps) (e:es)++ let defOcc = mutualDefOcc def+ let argOccs = defArgOccurrences def+ underOcc defOcc $ elims d (defType def) 0 argOccs es+ )++ Con _ _ es -> ret $ occurrences es+ MetaV m es -> ret $ underPathSetOcc MetaArg Mixed (occurrences es)+ Pi a b -> ret $ underPathOcc LeftOfArrow JustNeg (occurrences a) >> occurrences b+ Lam _ t -> ret $ occurrences t+ Level l -> ret $ occurrences l+ Lit{} -> ret $ pure ()+ -- Andreas, 2026-08-27, issue #8688: we have to descend into sorts.+ -- How an occurrence inside a sort is counted depends on @--cumulativity@,+ -- see 'sortOccurrence'.+ Sort s -> ret do+ o <- asks sortOcc+ underPathOcc InSort o $ occurrences s+ -- Jesper, 2020-01-12: this information is also used for the+ -- occurs check, so we need to look under DontCare (see #4371)+ DontCare t -> ret $ occurrences t+ Dummy{} -> ret $ pure ()++-- | Record that every matched argument of a def occurs in the def.+addClauseArgMatches :: NAPs -> OccM ()+addClauseArgMatches ps = underPathSetOcc Matched Mixed $ go 0 ps where+ go :: Int -> NAPs -> OccM ()+ go i ps = expand \ret -> case ps of+ [] -> ret $ pure ()+ p:ps -> ret do+ lift (properlyMatching (namedThing $ unArg p)) >>= \case+ True -> do topDef <- asks topDef+ addEdge noRange (ArgNode topDef i)+ False -> pure ()+ go (i + 1) ps++instance ComputeOccurrences Clause where+ occurrences cl = do+ let ps = namedClausePats cl+ -- TODO #3733: handle hcomp/transp clauses properly+ if hasDefP ps then+ pure ()+ else do+ -- add edges for matched args+ addClauseArgMatches ps++ let collectArgs :: NAPs -> [DefArgInEnv]+ collectArgs ps = IntMap.elems $ go 0 ps mempty where+ go :: Int -> NAPs -> IntMap DefArgInEnv -> IntMap DefArgInEnv+ go i [] acc = acc+ go i (p:ps) acc =+ -- TODO: we get crappy GHC Core for Pattern' foldl'+ let acc' = foldl'+ (\acc j -> IntMap.insert (dbPatVarIndex j) (DefArgInEnv i []) acc)+ acc (namedThing $ unArg p)+ in go (i + 1) ps acc'++ let items = collectArgs ps+ -- process body+ local (\env -> env {topDefArgs = items}) do+ occurrences $ clauseBody cl++-- | Occurrences in a sort.+--+-- The traversal stays on the level of sorts: we only descend into+-- subexpressions that are sorts themselves, or that are part of the identity+-- of the sort (the 'Level' of a universe, the eliminations of a stuck sort).+-- In particular we do /not/ descend into the 'Dom' of a 'PiSort': that is the+-- type of the domain, living one level below, and it is only stored in the+-- 'PiSort' for context extension (see the documentation of 'PiSort').+instance ComputeOccurrences Sort where+ occurrences s = expand \ret -> case s of+ Univ _ l -> ret $ occurrences l+ Inf _ _ -> ret $ pure ()+ SizeUniv -> ret $ pure ()+ LockUniv -> ret $ pure ()+ LevelUniv -> ret $ pure ()+ IntervalUniv -> ret $ pure ()+ -- NB: we skip the domain type stored in the 'PiSort', see the note above.+ -- We also skip the blocked dependency check (occurrences there will+ -- vanish after 'PiSort' reduces)+ PiSort _ _ s1 s2 -> ret $+ underPath LeftOfArrow (occurrences s1) >> occurrences s2+ FunSort s1 s2 -> ret $ underPath LeftOfArrow (occurrences s1) >> occurrences s2+ UnivSort s -> ret $ occurrences s+ -- @MetaS x es@ and @DefS q es@ are just the applications @x es@ and @q es@+ -- that happen to be sorts, so we reuse the corresponding 'Term' cases+ -- rather than duplicating the (subtle) treatment of eliminations.+ MetaS x es -> ret $ occurrences $ MetaV x es+ DefS q es -> ret $ occurrences $ Def q es+ DummyS _ -> ret $ pure ()++instance ComputeOccurrences Level where+ occurrences (Max _ as) = occurrences as++instance ComputeOccurrences PlusLevel where+ occurrences (Plus _ l) = occurrences l++instance ComputeOccurrences Type where+ occurrences (El _ v) = occurrences v++-- | A closed term paired with its type.+data TypedTerm = TypedTerm+ { ttType :: Type -- ^ Closed.+ , ttTerm :: Term -- ^ Closed.+ }++-- | Occurrences in a /closed/ term, treating the arguments it takes according+-- to its type like the arguments of the definition we are analysing.+--+-- This is how the definition of a data or record type copy is analysed+-- (issue #8696). Such a copy @N.D = M.D args@ is stored as a term that is+-- kept eta-contracted (see '_dataClause'), so the parameters and indices of+-- @N.D@ need not occur in it syntactically at all. Applying it to the+-- variables of its own telescope brings them back, and registering those+-- variables in 'topDefArgs' makes the analysis attribute their occurrences+-- to the corresponding arguments of @N.D@. Without this, the analysis would+-- wrongly conclude that they are all 'Unused'.+instance ComputeOccurrences TypedTerm where+ occurrences (TypedTerm t v) = do+ TelV tel _ <- lift $ telView t+ v <- lift $ instantiateFull v+ args <- lift $ paramsToDefArgs tel+ -- Note: @v@ is closed, so it needs no raising into @tel@.+ local (\ env -> env{ topDefArgs = args }) $+ occurrences $ v `apply` teleArgs tel++instance ComputeOccurrences a => ComputeOccurrences (Tele a) where+ occurrences EmptyTel = mempty+ occurrences (ExtendTel a b) = occurrences a >> occurrences b++instance ComputeOccurrences a => ComputeOccurrences (Abs a) where+ {-# INLINE occurrences #-}+ occurrences = \case+ Abs _ t -> underBinder $ occurrences t+ NoAbs _ t -> occurrences t++instance ComputeOccurrences a => ComputeOccurrences (Elim' a) where+ occurrences = \case+ Proj{} -> __IMPOSSIBLE__+ Apply a -> occurrences a+ IApply x y a -> occurrences x >> occurrences y >> occurrences a -- TODO Andrea: conservative++instance (ComputeOccurrences x, ComputeOccurrences a) => ComputeOccurrences (Boundary' x a) where+ occurrences = occurrences . theBoundary++-- András 2026-02-18: CAUTION. Make sure to only use this instance if+-- there's no Path or Occurrence to be adjusted.+instance ComputeOccurrences a => ComputeOccurrences [a] where+ occurrences = \case+ [] -> pure ()+ a:as -> occurrences a >> occurrences as++instance ComputeOccurrences a => ComputeOccurrences (Arg a)+instance ComputeOccurrences a => ComputeOccurrences (Dom a)+instance ComputeOccurrences a => ComputeOccurrences (Maybe a)++instance (ComputeOccurrences a, ComputeOccurrences b) => ComputeOccurrences (a, b) where+ {-# INLINE occurrences #-}+ occurrences (x, y) = occurrences x >> occurrences y++instance ComputeOccurrences Int where+ {-# INLINE occurrences #-}+ occurrences _ = pure ()++-- | Compute occurrences in a given definition.+computeDefOccurrences :: QName -> Maybe [Clause] -> OccM ()+computeDefOccurrences q clauses = inConcreteOrAbstractMode q \def -> do+ reportSDoc "tc.pos" 25 do+ let a = defAbstract def+ m <- viewTC eAbstractMode+ cur <- viewTC eCurrentModule+ o <- viewTC eCurrentOpaqueId+ "computeOccurrences" <+> prettyTCM q <+> text (show a) <+> text (show o) <+> text (show m)+ <+> prettyTCM cur++ let defOcc = mutualDefOcc def+ underPathOcc (`InDefOf` q) defOcc $ expand \ret -> case theDef def of++ Function{} -> ret do+ -- eta-expanded clauses are already computed by+ -- etaExpandFunctionClauses+ cs <- case clauses of+ Just cs -> pure cs+ Nothing -> __IMPOSSIBLE__++ performAnalysis <- lift $ optOccurrence <$> pragmaOptions+ if performAnalysis then do+ let clauses i cs = expand \ret -> case cs of+ [] -> ret $ pure ()+ c:cs -> ret $ underPath (`InClause` i) (occurrences c) >> clauses (i + 1) cs+ clauses 0 cs+ else case cs of+ [] -> __IMPOSSIBLE__++ -- András 2026-02-18: this looks dodgy?+ cl:_ -> underPathSetOcc Matched Mixed do+ let go i ps = expand \ret -> case ps of+ [] -> ret $ pure ()+ _:ps -> ret do d <- asks topDef+ addEdge noRange (ArgNode q i)+ go (i + 1) ps+ go 0 (namedClausePats cl)++ -- Andreas, 2026-08-29, issue #8696:+ -- A data or record type created by a module application (a /copy/) is+ -- defined by a term rather than by clauses. See the 'ComputeOccurrences'+ -- instance for 'TypedTerm' for how its arguments are accounted for.+ Datatype{dataClause = Just v} -> ret $ occurrences $ TypedTerm (defType def) v++ Datatype{dataPars = np0, dataCons = cs, dataTranspIx = trx} -> ret do+ -- Andreas, 2013-02-27 (later edited by someone else): First,+ -- include each index of an inductive family.+ TelV telD _ <- lift $ telView $ defType def+ -- Andreas, 2017-04-26, issue #2554: count first index as parameter if it has type Size.+ -- We compute sizeIndex=1 if first first index has type Size, otherwise sizeIndex==0+ sizeIndex <- lift $ caseList (drop np0 $ telToList telD) (pure 0) \dom _ ->+ caseMaybeM (isSizeType dom) (pure 0) \_ ->+ pure 1++ let np = np0 + sizeIndex -- number of parameters++ -- add edge for size index, if it exists+ expand \ret -> case sizeIndex of+ 1 -> ret $ addEdge noRange (ArgNode q np0)+ _ -> ret $ pure ()++ -- add edges for indices+ underPathSetOcc InIndex Mixed $+ rangeM_ np (size telD - 1) \i -> addEdge noRange (ArgNode q i)+++ -- Then, we compute the occurrences in the constructor types.+ --------------------------------------------------------------------------------++ -- If the data type has a transport constructor (i.e. it's an+ -- indexed family in cubical mode) we should also consider it for+ -- positivity.+ cs <- maybe (pure cs) (\c -> pure (cs ++! [c])) trx+ forM_ cs \c -> do+ -- Andreas, 2020-02-15, issue #4447:+ -- Allow UnconfimedReductions here to make sure we get the constructor type+ -- in same way as it was obtained when the data types was checked.+ (TelV tel t, bnd) <- lift $ putAllowedReductions allReductions $+ telViewPathBoundary . defType =<< getConstInfo c+ let (tel0,tel1) = splitTelescopeAt np tel+ -- Do not collect occurrences in the data parameters.+ -- Normalization needed e.g. for test/succeed/Bush.agda.+ -- (Actually, for Bush.agda, reducing the parameters should be sufficient.)+ tel1' <- lift $ addContext tel0 $ normalise tel1+ pvars <- lift $ paramsToDefArgs tel0++ local (\env -> env {topDefArgs = pvars}) do+ -- edges in the types of constructor arguments+ underPath (`ConArgType` c) $ occurrences tel1'++ local (\env -> env {locals = size tel - np}) do++ -- edges in path boundary+ underPath (`ConEndpoint` c) $ occurrences bnd++ -- Occurrences in the indices of the data type the constructor targets.+ -- Andreas, 2020-02-15, issue #4447:+ -- WAS: @t@ is not necessarily a data type, but it could be something+ -- that reduces to a data type once UnconfirmedReductions are confirmed+ -- as safe by the termination checker.+ -- In any case, if @t@ is not showing itself as the data type, we need to+ -- do something conservative. We will just collect *all* occurrences+ -- and flip their sign (variance) using 'LeftOfArrow'.+ case unEl t of+ Def q' vs+ | q == q' -> do+ let indices = fromMaybe __IMPOSSIBLE__ $ allApplyElims $ drop np vs+ underPathSetOcc (`IndArgType` c) Mixed $ occurrences indices+ | otherwise -> __IMPOSSIBLE__ -- this ought to be impossible now (but wasn't, see #4447)+ Pi{} -> __IMPOSSIBLE__ -- eliminated by telView+ MetaV{} -> __IMPOSSIBLE__ -- not a constructor target; should have been solved by now+ Var{} -> __IMPOSSIBLE__ -- not a constructor target+ Sort{} -> __IMPOSSIBLE__ -- not a constructor target+ Lam{} -> __IMPOSSIBLE__ -- not a type+ Lit{} -> __IMPOSSIBLE__ -- not a type+ Con{} -> __IMPOSSIBLE__ -- not a type+ Level{} -> __IMPOSSIBLE__ -- not a type+ DontCare{} -> __IMPOSSIBLE__ -- not a type+ Dummy{} -> __IMPOSSIBLE__++ -- See the 'Datatype' case above.+ Record{recClause = Just v} -> ret $ occurrences $ TypedTerm (defType def) v++ Record{recPars = np, recTel = tel} -> ret do+ let (tel0, tel1) = splitTelescopeAt np tel+ pvars <- lift $ paramsToDefArgs tel0+ local (\env -> env {topDefArgs = pvars}) do+ occurrences =<< liftTCM (addContext tel0 (normalise tel1))+ -- Andreas, 2017-01-01, issue #1899, treat like data types++ -- Arguments to other kinds of definitions are hard-wired.+ Constructor{} -> ret mempty+ Axiom{} -> ret mempty+ DataOrRecSig{} -> ret mempty+ Primitive{} -> ret mempty+ PrimitiveSort{} -> ret mempty+ GeneralizableVar{} -> ret mempty+ AbstractDefn{} -> ret __IMPOSSIBLE__++-- | Pre-pass that eta-expands function clauses and records the "formal arity" of the function in+-- the signature. Any argument beyond this arity is considered to have 'Mixed' polarity.+-- The analysis does not compute terms (or types) and cannot see arities that depend on argument values,+-- it can only look at arities of eta-expanded definition clauses.+-- See also issue 8564.+-- We return the original names paired with the eta-expanded clauses.+-- We also build up 'Mutuals' and record arities for each QName.+-- A definition that's not a Function gets @maxBound@ for arity.+preprocessMutuals :: [QName] -> Mutuals -> TCM [(QName, Maybe [Clause])]+preprocessMutuals qs mutuals = forM qs \q -> inConcreteOrAbstractMode q \def -> case theDef def of++ -- Postulates and primities are taken to be external to the mutual block.+ -- User-given polarity pragmas may influence occurrence computation+ -- in their arguments, but that's it.+ Axiom{} -> pure (q, Nothing)+ Primitive{} -> pure (q, Nothing)++ Function {funClauses = cs} -> do+ cs <- mapM etaExpandClause =<< instantiateFull cs+ let !arity = case cs of [] -> 0+ (c,_):cs -> foldl' (\acc (arity, _) -> min acc arity) c cs+ let !clauses = map' snd cs+ lift $ insertMutual mutuals q arity++ reportSDoc "tc.pos.preprocess" 30 $+ "added function" <+> prettyTCM q <+> "to mutual block with arity" <+> pretty arity+ pure (q, Just clauses)++ _ -> do+ reportSDoc "tc.pos.preprocess" 30 $+ "added definition" <+> prettyTCM q <+> "to mutual block"+ lift $ insertMutual mutuals q maxBound+ pure (q, Nothing)++buildOccurrenceGraph :: [QName] -> TCM (OccGraph, Mutuals)+buildOccurrenceGraph qs = do+ inf <- maybe Nothing (\x -> Just $! nameOfInf x) <$> coinductionKit+ so <- sortOccurrence++ mutuals <- lift HT.empty+ qs <- preprocessMutuals qs mutuals++ graph <- lift HT.empty+ TCM \st tce -> forM_ qs \(q, clauses) -> do+ let env = OccEnv q [] inf so 0 mutuals (DefNode q) Root StrictPos graph+ unTCM (runReaderT (computeDefOccurrences q clauses) env) st tce++ pure (graph, mutuals)++-- Computing transitive occurrences, to be used in positivity checking+----------------------------------------------------------------------------------------------------++data Seen = Seen Node Occurrence+ deriving (Eq, Show)++instance Hashable Seen where+ hashWithSalt h (Seen x y) =+ fromIntegral (fromIntegral (hashWithSalt h x) `combineWord` fromIntegral (fromEnum y))++-- | Set of visited nodes during graph search.+type SeenNodes = HT.HashTableLL Seen ()++memberSeen :: Seen -> SeenNodes -> IO Bool+memberSeen x map = HT.lookup map x >>= \case+ Nothing -> pure False+ _ -> pure True++{-# NOINLINE insertSeen #-}+insertSeen :: Seen -> SeenNodes -> IO ()+insertSeen x map = HT.insert map x ()++-- | Exception for short-circuiting when finding a Mixed path from source to target.+instance Exception Occurrence++-- | Search for transitive occurrences through the occurrence graph. We compute the 'oplus' sum of+-- all paths from the source to the target. This is not as bad as it sounds, becuse a) we can+-- short-circuit a search when a 'Mixed' path is found b) only 4 possible 'Occurrences' remain,+-- (discounting 'Mixed' and 'Unused') and we can use a DFS where each node is visited at most 4+-- times, for each 'Occurence' of the path to the node from the source.+transitiveOccurrence :: OccGraph -> Node -> Node -> IO Occurrence+transitiveOccurrence graph src tgt = do++ -- Function for visiting a node.+ let go :: OccGraph -> Node -> Node -> Occurrence -> Occurrence -> SeenNodes -> IO Occurrence+ go graph tgt src path acc seen = do+ let s = Seen src path+ memberSeen s seen >>= \case+ True -> pure acc+ False -> do+ insertSeen s seen+ if src == tgt then+ case oplus path acc of+ Mixed -> throwIO Mixed -- Mixed path found, abort search+ acc -> go' graph tgt src path acc seen+ else+ go' graph tgt src path acc seen++ -- Function for visiting the children of a node+ go' :: OccGraph -> Node -> Node -> Occurrence -> Occurrence -> SeenNodes -> IO Occurrence+ go' graph tgt src path acc seen = lookupNode src graph+ (\map -> lookupNode tgt map+ -- if there's a direct edge to the target, we follow that first.+ -- this should make it faster to find Mixed edges (if there's one)+ (\(Edge occ _) -> do+ acc <- go graph tgt tgt (otimes path occ) acc seen+ goMap graph tgt map path acc seen)++ (goMap graph tgt map path acc seen))++ (pure acc)++ -- Function for traversing the map of children for a node+ goMap :: OccGraph -> Node -> NodeMap (Edge OccursWhere) -> Occurrence -> Occurrence -> SeenNodes -> IO Occurrence+ goMap graph tgt map path acc seen =+ HT.forAssocsAccum map acc \src (Edge occ _) acc ->+ if src == tgt then pure acc -- already covered this case in go'+ else go graph tgt src (otimes path occ) acc seen++ seen <- HT.empty+ go' graph tgt src StrictPos Unused seen `catch` pure
+ src/full/Agda/TypeChecking/Positivity/Warnings.hs view
@@ -0,0 +1,137 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.TypeChecking.Positivity.Warnings where++import Prelude hiding (null)++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Control.DeepSeq++import Data.Foldable (toList, msum)+import Data.Sequence (Seq)+import GHC.Generics++import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty+import Agda.Syntax.Internal+import Agda.Syntax.Position (Range)+import Agda.TypeChecking.Positivity.Occurrence (Occurrence(..))++import Agda.Utils.Graph.AdjacencyMap.Unidirectional (Graph)+import Agda.Utils.Graph.AdjacencyMap.Unidirectional qualified as Graph+import Agda.Utils.Impossible+import Agda.Utils.Null+import Agda.Utils.SemiRing++{-+András 2026-03-11: these definitions are only used to represent and render positivity warnings.+They used to be the basis of the main occurrence/positivity implementation. I rewrote the main+implementation in PR 8411 but I left the warning rendering as it is.+-}++-- | Description of an occurrence.+data OccursWhere+ = OccursWhere Range (Seq Where) (Seq Where)+ -- ^ The elements of the sequences, read from left to right,+ -- explain how to get to the occurrence. The second sequence+ -- 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, Generic)++instance NFData OccursWhere++instance Null OccursWhere where+ empty = OccursWhere empty empty empty+ null (OccursWhere r wh1 wh2) = and [ null r, null wh1, null wh2 ]++-- | One part of the description of an occurrence.+data Where+ = LeftOfArrow+ | DefArg QName Nat -- ^ in the nth argument of a define constant+ | UnderInf -- ^ in the principal argument of built-in ∞+ | VarArg Occurrence Nat -- ^ as an argument to a bound variable.+ | MetaArg -- ^ as an argument of a metavariable+ | ConArgType QName -- ^ in the type of a constructor+ | IndArgType QName -- ^ in a datatype index of a constructor+ | ConEndpoint QName+ -- ^ in an endpoint of a higher constructor+ | InClause Nat -- ^ in the nth clause of a defined function+ | Matched -- ^ matched against in a clause of a defined function+ | InIndex -- ^ is an index of an inductive family+ | InSort -- ^ in a sort, e.g. in the level of a universe+ | InDefOf QName -- ^ in the definition of a constant+ deriving (Show, Eq, Ord, Generic)++instance NFData Where++instance Pretty Where where+ pretty = \case+ LeftOfArrow -> "LeftOfArrow"+ DefArg q i -> "DefArg" <+> pretty q <+> pretty i+ UnderInf -> "UnderInf"+ VarArg k i -> "VarArg" <+> pretty k <+> pretty i+ MetaArg -> "MetaArg"+ ConArgType q -> "ConArgType" <+> pretty q+ IndArgType q -> "IndArgType" <+> pretty q+ ConEndpoint q+ -> "ConEndpoint" <+> pretty q+ InClause i -> "InClause" <+> pretty i+ Matched -> "Matched"+ InIndex -> "IsIndex"+ InSort -> "InSort"+ InDefOf q -> "InDefOf" <+> pretty q++instance Pretty OccursWhere where+ pretty = \case+ OccursWhere r ws1 ws2 ->+ "OccursWhere" <+> pretty (toList ws1) <+> pretty (toList ws2)++-- | The map contains bindings of the form @bound |-> ess@, satisfying+-- the following property: for every non-empty list @w@,+-- @'foldr1' 'otimes' w '<=' bound@ iff+-- @'or' [ 'all' every w '&&' 'any' some w | (every, some) <- ess ]@.+boundToEverySome ::+ Map Occurrence [(Occurrence -> Bool, Occurrence -> Bool)]+boundToEverySome = Map.fromListWith __IMPOSSIBLE__+ [ ( JustPos+ , [((/= Unused), (`elem` [Mixed, JustNeg, JustPos]))]+ )+ , ( StrictPos+ , [ ((/= Unused), (`elem` [Mixed, JustNeg, JustPos]))+ , ((not . (`elem` [Unused, GuardPos])), const True)+ ]+ )+ , ( GuardPos+ , [((/= Unused), const True)]+ )+ ]++-- | @productOfEdgesInBoundedWalk occ g u v bound@ returns a value+-- distinct from 'Nothing' iff there is a walk @c@ (a list of edges)+-- in @g@, from @u@ to @v@, for which the product @'foldr1' 'otimes'+-- ('map' occ c) '<=' bound@. In this case the returned value is+-- @'Just' ('foldr1' 'otimes' c)@ for one such walk @c@.+--+-- Preconditions: @u@ and @v@ must belong to @g@, and @bound@ must+-- belong to the domain of @boundToEverySome@.+--+-- There is a property for this function in+-- Internal.Utils.Graph.AdjacencyMap.Unidirectional.+productOfEdgesInBoundedWalk ::+ (SemiRing e, Ord n) =>+ (e -> Occurrence) -> Graph n e -> n -> n -> Occurrence -> Maybe e+productOfEdgesInBoundedWalk occ g u v bound =+ case Map.lookup bound boundToEverySome of+ Nothing -> __IMPOSSIBLE__+ Just ess ->+ case msum [ Graph.walkSatisfying+ (every . occ . Graph.label)+ (some . occ . Graph.label)+ g u v+ | (every, some) <- ess+ ] of+ Just es@(_ : _) -> Just (foldr1 otimes (map Graph.label es))+ Just [] -> __IMPOSSIBLE__+ Nothing -> Nothing
src/full/Agda/TypeChecking/Pretty.hs view
@@ -13,17 +13,19 @@ import qualified Data.Foldable as Fold import Data.Map (Map)+import qualified Data.IntMap as IntMap import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import Data.Maybe import Data.String ()-import Data.Semigroup (Semigroup((<>))) import Data.Text (Text)+import Data.Functor import Agda.Syntax.Position import Agda.Syntax.Common import Agda.Syntax.Common.Pretty ( Pretty, prettyShow )+import qualified Agda.Syntax.Common.Aspect as Asp import qualified Agda.Syntax.Common.Pretty as P import Agda.Syntax.Fixity import Agda.Syntax.Internal@@ -33,13 +35,13 @@ import Agda.Syntax.Translation.AbstractToConcrete import qualified Agda.Syntax.Translation.AbstractToConcrete as Reexport (MonadAbsToCon) import qualified Agda.Syntax.Translation.ReflectedToAbstract as R-import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Abstract.Name (AbstractName (..), AbstractModule (..), KindOfName(..))+import Agda.Syntax.Abstract qualified as A import qualified Agda.Syntax.Concrete as C import qualified Agda.Syntax.Abstract.Pretty as AP import Agda.Syntax.Concrete.Pretty (bracesAndSemicolons) import qualified Agda.Syntax.Concrete.Pretty as CP import qualified Agda.Syntax.Info as A-import Agda.Syntax.Scope.Base (AbstractName(..)) import Agda.Syntax.Scope.Monad (withContextPrecedence) import Agda.Syntax.TopLevelModuleName @@ -49,10 +51,13 @@ import Agda.TypeChecking.DiscrimTree.Types import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Free.Base+import Agda.TypeChecking.Free.Generic 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.List ( last1 ) import Agda.Utils.List1 ( List1, pattern (:|) ) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe@@ -60,7 +65,7 @@ import Agda.Utils.Trie import Agda.Utils.Permutation ( Permutation ) import qualified Agda.Utils.Maybe.Strict as S-import Agda.Utils.Size ( Sized, natSize )+import Agda.Utils.Size ( Sized, natSize, size ) import Agda.Utils.Impossible @@ -89,15 +94,21 @@ prettyAs :: (ToConcrete a, ConOfAbs a ~ [ce], P.Pretty ce, MonadAbsToCon m) => a -> m Doc prettyAs = AP.prettyAs -fwords, text, multiLineText :: Applicative m => String -> m Doc+fwords, text, multiLineText, url :: Applicative m => String -> m Doc fwords = pure . P.fwords ; {-# INLINE fwords #-} text = pure . P.text ; {-# INLINE text #-} multiLineText = pure . P.multiLineText ; {-# INLINE multiLineText #-}+url = pure . P.url ; {-# INLINE url #-} {-# INLINE pwords #-} pwords :: Applicative m => String -> [m Doc] pwords = map pure . P.pwords +-- | Link to an issue on the Agda bug tracker.+{-# INLINE githubIssue #-}+githubIssue :: Applicative m => Int -> m Doc+githubIssue = pure . P.githubIssue+ sep, fsep, hsep, hcat, vcat, vsep :: (Applicative m, Foldable t) => t (m Doc) -> m Doc sep = fmap P.sep . sequenceAFoldable ; {-# SPECIALIZE NOINLINE sep :: [TCM Doc] -> TCM Doc #-} ; {-# SPECIALIZE NOINLINE sep :: List1 (TCM Doc) -> TCM Doc #-} fsep = fmap P.fsep . sequenceAFoldable ; {-# SPECIALIZE NOINLINE fsep :: [TCM Doc] -> TCM Doc #-} ; {-# SPECIALIZE NOINLINE fsep :: List1 (TCM Doc) -> TCM Doc #-}@@ -173,6 +184,50 @@ | k <= 9 = [digit k] | otherwise = digit (k `mod` 10):go (k `div` 10) +hlBound, hlGeneralizable, hlDatatype, hlField,+ hlFunction, hlModule, hlPostulate, hlPrimitive, hlRecord, hlArgument,+ hlMacro :: Functor m => m Doc -> m Doc++hlBound = fmap P.hlBound+hlGeneralizable = fmap P.hlGeneralizable+hlDatatype = fmap P.hlDatatype+hlField = fmap P.hlField+hlFunction = fmap P.hlFunction+hlModule = fmap P.hlModule+hlPostulate = fmap P.hlPostulate+hlPrimitive = fmap P.hlPrimitive+hlRecord = fmap P.hlRecord+hlArgument = fmap P.hlArgument+hlMacro = fmap P.hlMacro++hlComment, hlSymbol, hlKeyword, hlString, hlNumber, hlHole, hlPrimitiveType, hlPragma+ :: Functor m => m Doc -> m Doc++hlComment = fmap P.hlComment+hlSymbol = fmap P.hlSymbol+hlKeyword = fmap P.hlKeyword+hlString = fmap P.hlString+hlNumber = fmap P.hlNumber+hlHole = fmap P.hlHole+hlPrimitiveType = fmap P.hlPrimitiveType+hlPragma = fmap P.hlPragma++hlConstructor :: Functor m => Induction -> m Doc -> m Doc+hlConstructor = fmap . P.hlConstructor++{-# SPECIALISE hlBound :: TCM Doc -> TCM Doc #-}+{-# SPECIALISE hlGeneralizable :: TCM Doc -> TCM Doc #-}+{-# SPECIALISE hlDatatype :: TCM Doc -> TCM Doc #-}+{-# SPECIALISE hlField :: TCM Doc -> TCM Doc #-}+{-# SPECIALISE hlFunction :: TCM Doc -> TCM Doc #-}+{-# SPECIALISE hlModule :: TCM Doc -> TCM Doc #-}+{-# SPECIALISE hlPostulate :: TCM Doc -> TCM Doc #-}+{-# SPECIALISE hlPrimitive :: TCM Doc -> TCM Doc #-}+{-# SPECIALISE hlRecord :: TCM Doc -> TCM Doc #-}+{-# SPECIALISE hlArgument :: TCM Doc -> TCM Doc #-}+{-# SPECIALISE hlMacro :: TCM Doc -> TCM Doc #-}+{-# SPECIALISE hlConstructor :: Induction -> TCM Doc -> TCM Doc #-}+ --------------------------------------------------------------------------- -- * The PrettyTCM class ---------------------------------------------------------------------------@@ -211,7 +266,9 @@ instance PrettyTCM Quantity where prettyTCM = pretty ; {-# INLINE prettyTCM #-} instance PrettyTCM Erased where prettyTCM = pretty ; {-# INLINE prettyTCM #-} instance PrettyTCM ModalPolarity where prettyTCM = pretty ; {-# INLINE prettyTCM #-}+instance PrettyTCM Cohesion where prettyTCM = pretty ; {-# INLINE prettyTCM #-} instance PrettyTCM PolarityModality where prettyTCM = pretty ; {-# INLINE prettyTCM #-}+instance PrettyTCM MetaSet where prettyTCM = pretty ; {-# INLINE prettyTCM #-} instance PrettyTCM A.Expr where prettyTCM = prettyA; {-# INLINE prettyTCM #-} instance PrettyTCM A.Pattern where prettyTCM = prettyA; {-# INLINE prettyTCM #-}@@ -233,6 +290,7 @@ instance PrettyTCM (NamedArg A.Expr) where prettyTCM = prettyA <=< reify ; {-# SPECIALIZE prettyTCM :: (NamedArg A.Expr) -> TCM Doc #-} instance PrettyTCM (NamedArg Term) where prettyTCM = prettyA <=< reify ; {-# SPECIALIZE prettyTCM :: (NamedArg Term) -> TCM Doc #-} instance PrettyTCM (Dom Type) where prettyTCM = prettyA <=< reify ; {-# SPECIALIZE prettyTCM :: (Dom Type) -> TCM Doc #-}+instance PrettyTCM Context where prettyTCM = prettyA <=< reify ; {-# SPECIALISE prettyTCM :: Context -> TCM Doc #-} instance PrettyTCM ContextEntry where prettyTCM = prettyA <=< reify ; {-# SPECIALIZE prettyTCM :: ContextEntry -> TCM Doc #-} instance PrettyTCM Permutation where prettyTCM = text . show ; {-# SPECIALIZE prettyTCM :: Permutation -> TCM Doc #-}@@ -240,14 +298,61 @@ instance PrettyTCM IsForced where prettyTCM = text . show ; {-# SPECIALIZE prettyTCM :: IsForced -> TCM Doc #-} instance PrettyTCM Name where prettyTCM = fmap P.pretty . abstractToConcrete_ ; {-# SPECIALIZE prettyTCM :: Name -> TCM Doc #-}-instance PrettyTCM QName where prettyTCM = fmap P.pretty . abstractToConcrete_ ; {-# SPECIALIZE prettyTCM :: QName -> TCM Doc #-}-instance PrettyTCM ModuleName where prettyTCM = fmap P.pretty . abstractToConcrete_ ; {-# SPECIALIZE prettyTCM :: ModuleName -> TCM Doc #-} instance PrettyTCM AbstractName where prettyTCM = prettyTCM . anameName ; {-# SPECIALIZE prettyTCM :: AbstractName -> TCM Doc #-} instance PrettyTCM ConHead where prettyTCM = prettyTCM . conName ; {-# SPECIALIZE prettyTCM :: ConHead -> TCM Doc #-} instance PrettyTCM DBPatVar where prettyTCM = prettyTCM . var . dbPatVarIndex ; {-# SPECIALIZE prettyTCM :: DBPatVar -> TCM Doc #-} instance PrettyTCM EqualityView where prettyTCM = prettyTCM . equalityUnview ; {-# SPECIALIZE prettyTCM :: EqualityView -> TCM Doc #-} +instance PrettyTCM a => PrettyTCM (VarOcc' a) where+ prettyTCM (VarOcc a b) = prettyTCM a <+> pretty b+ {-# SPECIALIZE prettyTCM :: PrettyTCM a => VarOcc' a -> TCM Doc #-}++instance PrettyTCM a => PrettyTCM (FlexRig' a) where+ prettyTCM = \case+ Flexible a -> "FL" <> parens (prettyTCM a)+ WeaklyRigid -> "WR"+ StronglyRigid -> "SR"+ Unguarded -> empty+ {-# SPECIALIZE prettyTCM :: PrettyTCM a => FlexRig' a -> TCM Doc #-}++instance PrettyTCM ModuleName where+ prettyTCM x =+ let+ def = case mnameToList x of+ [] -> id+ x:xs -> flip P.definedAt (nameBindingSite (last1 x xs))+ in fmap (P.hlModule . def . P.pretty) $ abstractToConcrete_ x++ {-# SPECIALIZE prettyTCM :: ModuleName -> TCM Doc #-}++-- | Automatically highlights the resulting document with the correct+-- name kind.+instance PrettyTCM QName where+ prettyTCM x = do+ nk <- getConstInfo' x <&> \case+ Left _ -> Nothing+ Right d -> Just (defnToNameKind (theDef d))+ fmap (flip P.definedAt (nameBindingSite x) . maybe id P.hlNameKind nk . P.pretty) (abstractToConcrete_ x)++ {-# SPECIALIZE prettyTCM :: QName -> TCM Doc #-}++defnToNameKind :: Defn -> Asp.NameKind+defnToNameKind Axiom{} = Asp.Postulate+defnToNameKind DataOrRecSig{} = Asp.Postulate+ -- TODO: ^ maybe break down into Data/Record?+defnToNameKind GeneralizableVar{} = Asp.Generalizable+defnToNameKind d@Function{}+ | isProperProjection d = Asp.Field+ | isMacro d = Asp.Macro -- AIM XL, issue #7324+ | otherwise = Asp.Function+defnToNameKind Datatype{} = Asp.Datatype+defnToNameKind Record{} = Asp.Record+defnToNameKind Constructor{ conSrcCon = c } = Asp.Constructor $ conInductive c+defnToNameKind Primitive{} = Asp.Primitive+defnToNameKind PrimitiveSort{} = Asp.Primitive+defnToNameKind AbstractDefn{} = Asp.Function+ -- Functors instance (PrettyTCM a, Subst a) => PrettyTCM (Abs a) where@@ -297,6 +402,12 @@ u = lookupS rho2 0 {-# SPECIALIZE prettyTCM :: (Pretty a, PrettyTCM a, EndoSubst a) => Substitution' a -> TCM Doc #-} +instance {-# OVERLAPPABLE #-} PrettyTCM a => PrettyTCM (IsWithFunction a) where+ prettyTCM = \case+ NoWithFunction -> "(no with function)"+ WithFunction a -> prettyTCM a+{-# SPECIALIZE prettyTCM :: PrettyTCM a => IsWithFunction a -> TCM Doc #-}+ instance PrettyTCM Clause where prettyTCM cl = do x <- qualify_ <$> freshName_ ("<unnamedclause>" :: String)@@ -343,6 +454,11 @@ [ hang (prettyTCM k <+> "=") 2 (prettyTCM v) | (k, v) <- Map.toList m ]) {-# SPECIALIZE prettyTCM :: (PrettyTCM k, PrettyTCM v) => Map k v -> TCM Doc #-} +instance PrettyTCM a => PrettyTCM (VarMap' a) where+ prettyTCM (VarMap vars) = "VarMap" <> braces (sep $ punctuate comma+ [ hang (prettyTCM (var k) <+> "=") 2 (prettyTCM v) | (k, v) <- IntMap.toList vars ])+ {-# SPECIALIZE prettyTCM :: PrettyTCM a => VarMap' a -> TCM Doc #-}+ -- instance {-# OVERLAPPING #-} PrettyTCM ArgName where -- prettyTCM = text . P.prettyShow @@ -360,6 +476,7 @@ [ prettyTCM (getQuantity mod) , prettyTCM (getRelevance mod) , prettyTCM (getModalPolarity mod)+ , prettyTCM (getCohesion mod) ] {-# SPECIALIZE prettyTCM :: Modality -> TCM Doc #-} @@ -455,7 +572,7 @@ prettyTCMPatterns = mapM prettyA <=< reifyPatterns {-# SPECIALIZE prettyTCMPatternList :: [NamedArg DeBruijnPattern] -> TCM Doc #-}-prettyTCMPatternList :: MonadPretty m => [NamedArg DeBruijnPattern] -> m Doc+prettyTCMPatternList :: (MonadPretty m) => [NamedArg DeBruijnPattern] -> m Doc prettyTCMPatternList = prettyList . map prettyA <=< reifyPatterns -- | For unquote.@@ -470,7 +587,10 @@ {-# SPECIALIZE prettyTCM :: Elim' DisplayTerm -> TCM Doc #-} instance PrettyTCM NLPat where- prettyTCM (PVar x bvs) = prettyTCM (Var x (map (Apply . fmap var) bvs))+ -- We print variables in NLPats with "?" prefixes to indicate that they are+ -- not bound vars+ prettyTCM (PVar s x bvs) =+ ("?" <> prettyTCM (var x)) <+> fsep (map (prettyTCM . fmap var) bvs) prettyTCM (PDef f es) = parens $ prettyTCM f <+> fsep (map prettyTCM es) prettyTCM (PLam i u) = parens $ fsep@@ -515,8 +635,8 @@ prettyTCM = prettyTCM . unEl {-# SPECIALIZE prettyTCM :: Type' NLPat -> TCM Doc #-} -instance PrettyTCM RewriteRule where- prettyTCM (RewriteRule q gamma f ps rhs b _c _top) = fsep+instance PrettyTCM GlobalRewriteRule where+ prettyTCM (GlobalRewriteRule q gamma f ps rhs b _c _top) = fsep [ prettyTCM q , prettyTCM gamma <+> " |- " , addContext gamma $ sep@@ -527,7 +647,41 @@ , prettyTCM b ] ]-{-# SPECIALIZE prettyTCM :: RewriteRule -> TCM Doc #-}+{-# SPECIALIZE prettyTCM :: GlobalRewriteRule -> TCM Doc #-}++instance PrettyTCM LocalEquation where+ prettyTCM (LocalEquation gamma lhs rhs b) = fsep+ [ prettyTCM gamma <+> " |- "+ , addContext gamma $ sep+ [ prettyTCM lhs+ , " = "+ , prettyTCM rhs+ , " : "+ , prettyTCM b+ ]+ ]++instance PrettyTCM RewriteHead where+ prettyTCM (RewDefHead f) = prettyTCM f+ prettyTCM (RewVarHead x) = prettyTCM (var x)++instance PrettyTCM RewriteRule where+ prettyTCM (RewriteRule gamma f ps rhs b) = fsep+ [ prettyTCM gamma <+> " |- "+ , addContext gamma $ sep+ [ prettyTCM (headToPat (size gamma) f ps)+ , " --> "+ , prettyTCM rhs+ , " : "+ , prettyTCM b+ ]+ ]++instance PrettyTCM RewDom where+ prettyTCM (RewDom e r) = fsep+ [ prettyTCM e+ , if isJust r then "(rewrite present)" else "(rewrite invalidated)"+ ] instance PrettyTCM Occurrence where prettyTCM occ = text $ "-[" ++ prettyShow occ ++ "]->"
src/full/Agda/TypeChecking/Pretty.hs-boot view
@@ -30,7 +30,8 @@ -- Agda.Syntax.Translation.AbstractToConcrete does not need to be -- imported. type MonadPretty m =- ( MonadFresh NameId m+ ( MonadFileId m+ , MonadFresh NameId m , MonadInteractionPoints m , MonadStConcreteNames m , HasOptions m
src/full/Agda/TypeChecking/Pretty/Call.hs view
@@ -149,7 +149,7 @@ pwords "fits in the sort" ++ [prettyTCM s] ++ pwords "of the datatype." - CheckFunDefCall _ f _ _ ->+ CheckFunDefCall _ f _ -> fsep $ pwords "when checking the definition of" ++ [prettyTCM f] CheckPragma _ p ->@@ -166,7 +166,7 @@ CheckWithFunctionType a -> fsep $ pwords "when checking that the type" ++ [prettyTCM a] ++ pwords "of the generated with function is well-formed" ++- [parens $ text $ docsUrl "language/with-abstraction.html#ill-typed-with-abstractions"]+ [parens $ url $ docsUrl "language/with-abstraction.html#ill-typed-with-abstractions"] CheckDotPattern e v -> fsep $ pwords "when checking that the given dot pattern" ++ [prettyA e] ++@@ -206,11 +206,13 @@ SetRange r -> fsep (pwords "when doing something at") <+> prettyTCM r - CheckSectionApplication _ erased m1 modapp -> fsep $- pwords "when checking the module application" ++- [prettyA $ A.Apply info erased m1 modapp initCopyInfo empty]+ CheckSectionApplication _ erased m1 modapp -> do+ fsep $+ pwords "when checking the module application" +++ [prettyA $ A.Apply info erased m1 modapp copy empty] where- info = A.ModuleInfo noRange noRange Nothing Nothing Nothing+ info = A.ModuleInfo noRange noRange Nothing empty Nothing+ copy = ScopeCopyInfo { renNames = mempty, renModules = mempty } ModuleContents -> fsep $ pwords "when retrieving the contents of a module" @@ -224,6 +226,12 @@ , nest 2 (prettyTCM r) , fsep (pwords "must be equal, since" ++ [prettyTCM fn] ++ pwords "could reduce to either.") ]++ CheckLocalRewriteConstraint e c -> vcat+ [ fsep $ pwords "when checking the following local rewrite rule constraint:"+ , nest 2 $ prettyTCM e+ , prettyTCM c+ ] where hPretty :: MonadPretty m => Arg (Named_ Expr) -> m Doc
src/full/Agda/TypeChecking/Pretty/Constraint.hs view
@@ -146,7 +146,7 @@ | c <- cnds ] - ResolveInstanceHead q ->+ ResolveInstanceHead _kwr q -> "Resolve target type of instance: " <?> prettyTCM q IsEmpty r t -> "Is empty:" <?> prettyTCMCtx TopCtx t@@ -175,7 +175,9 @@ CheckLockedVars t ty lk lk_ty -> do "Lock" <+> prettyTCM lk <+> "|-" <+> prettyTCMCtx TopCtx t <+> ":" <+> prettyTCM ty UsableAtModality _ ms mod t -> "Is usable at" <+> text (verbalize mod) <+> "modality:" <+> prettyTCM t- -- TODO: print @ms : Maybe Sort@ as well?+ -- TODO: print @ms : Maybe Sort@ as well?+ RewConstraint (LocalEquation g t u a) ->+ addContext g $ prettyCmp (prettyTCM CmpEq) t u <?> prettyTCM a where prettyCmp
src/full/Agda/TypeChecking/Pretty/Warning.hs view
@@ -23,8 +23,6 @@ import Data.Char ( toLower ) import qualified Data.Foldable as Fold import Data.Function (on)-import Data.IntSet (IntSet)-import qualified Data.IntSet as IntSet import qualified Data.List as List import Data.Maybe import Data.Set (Set)@@ -39,6 +37,7 @@ import Agda.TypeChecking.Monad.Options import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Monad.Constraints+import Agda.TypeChecking.Monad.Context ( addContext ) import Agda.TypeChecking.Monad.State ( getScope ) import Agda.TypeChecking.Monad ( localTCState, enterClosure ) import Agda.TypeChecking.Positivity () --instance only@@ -52,10 +51,11 @@ ( ImportedName'(..), fromImportedName, partitionImportedNames , IsOpaque(OpaqueDef, TransparentDef) , ProjOrigin(..)- , getHiding+ , getHiding, DataOrRecord_, DataOrRecord'(IsData, IsRecord) ) import Agda.Syntax.Common.Pretty ( Pretty, prettyShow, singPlural ) import qualified Agda.Syntax.Common.Pretty as P+import qualified Agda.Syntax.Abstract as A import qualified Agda.Syntax.Concrete as C import Agda.Syntax.Internal import Agda.Syntax.Position@@ -78,6 +78,7 @@ import Agda.Utils.Singleton import qualified Agda.Utils.Set1 as Set1 import Agda.Utils.WithDefault ( pattern Value )+import qualified Agda.Utils.VarSet as VarSet import Agda.Utils.Impossible @@ -119,16 +120,16 @@ let (guardednessHelps, guardednessHelpsNot) = List.partition (toBool . termErrGuardednessHelps) errs let report hint because = if null because then empty else do+ let+ fs = concatMap termErrFunctions because+ calls = concatMap termErrCalls because vcat- [ fwords "Termination checking failed for the following functions:"+ [ fsep $ pwords "Termination checking failed for the following" ++ [ pluralS fs "function" <> colon ] , fwords hint- , nest 2 $ fsep $ punctuate comma $- map (pretty . dropTopLevel) $- concatMap termErrFunctions because- , fwords "Problematic calls:"+ , nest 2 $ fsep $ map (prettyTCM . dropTopLevel) fs+ , fsep [ "Problematic", pluralS calls "call" <> colon ] , nest 2 $ fmap (P.vcat . List.nub) $- mapM prettyTCM $ List.sortOn getRange $- concatMap termErrCalls because+ mapM prettyTCM $ List.sortOn getRange calls ] -- Andreas, 2025-04-01, issue #6657 -- Hint towards --guardedness where appropriate, but not when --sized-types is on.@@ -199,9 +200,14 @@ CoinductiveEtaRecord name -> vcat [ fsep $ pwords "Not switching on eta-equality for coinductive records."- , fsep $ pwords "If you must, use pragma" ++ [ "{-# ETA", prettyTCM name, "#-}" ]+ , fsep $ pwords "If you must, use pragma" ++ [ "{-# ETA_EQUALITY #-}" ] ] + UnguardedEtaRecordW name -> vcat+ [ fsep $ pwords "Recursive occurrence of this record in its definition is unguarded, so eta-equality for this record might lead to non-termination in the type checker."+ , fsep $ pwords "To suppress this warning, use pragma" ++ [ "{-# ETA_EQUALITY #-}" ]+ ]+ 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."@@ -241,22 +247,25 @@ FixingRelevance s r r' -> fsep $ concat [ pwords "Replacing illegal relevance", [ p r ]- , pwords s, [ "by", p r' ]+ , ["of", text s], [ "by", p r' ] ] where p r = text $ "`" ++ verbalize r ++ "'" FixingCohesion s c c' -> fsep $ concat [ pwords "Replacing illegal cohesion", [ p c ]- , pwords s, [ "by", p c' ]+ , ["of", text s], [ "by", p c' ] ] where p c = text $ "`" ++ verbalize c ++ "'" FixingPolarity s q q' -> fsep $ concat [ pwords "Replacing illegal polarity", [ p q ]- , pwords s, [ "by", p q' ]+ , ["of", text s], [ "by", p q' ] ] where p q = text $ "`" ++ verbalize q ++ "'" + IgnoringRew s r -> fsep $ concat+ [pwords "Ignoring illegal local rewrite attribute on", pwords s]+ IllformedAsClause s -> fsep . pwords $ "`as' must be followed by an identifier" ++ s @@ -281,10 +290,10 @@ UselessPublicAnonymousModule -> fwords $ "Ignoring `public'; cannot reexport from unopened anonymous module" - UselessHiding xs -> fsep $ concat- [ pwords "Ignoring names in `hiding' directive:"- , punctuate "," $ fmap pretty xs- ]+ UselessHiding xs ->+ fwords "Ignoring names in `hiding' directive:"+ <?> fsep (punctuate ";" $ fmap pretty xs)+ -- Andreas, 2026-02-14 punctuate with semicolon since xs may contain "module M" or even "," UselessInline q -> fsep $ pwords "It is pointless for INLINE'd function" ++ [prettyTCM q] ++@@ -292,11 +301,11 @@ UselessTactic -> fwords $ "Ignoring `tactic' attribute for non-hidden (explicit or instance) binder" - WrongInstanceDeclaration -> fwords $+ WrongInstanceDeclaration _kwr -> 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 $+ InstanceWithExplicitArg _kwr 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." @@ -321,6 +330,13 @@ pwords "Invalid character literal" ++ [text $ show c] ++ pwords "(surrogate code points are not supported)" + UnusedImports m Nothing -> fsep $+ pwords "Redundant opening of" ++ [ prettyTCM m ]++ UnusedImports m (Just xs) -> fsep $+ [ "Opening", prettyTCM m ] ++ pwords "brings the following unused names into scope:"+ ++ fmap pretty (List1.toList xs)+ UselessPragma _r d -> return d SafeFlagPostulate q -> fsep $@@ -348,9 +364,11 @@ ParseWarning pw -> pretty pw - DeprecationWarning old new version -> fsep $- [text old] ++ pwords "has been deprecated. Use" ++ [text new] ++ pwords- "instead. This will be an error in Agda" ++ [text version <> "."]+ DeprecationWarning old mnew version -> fsep $ concat $ concat+ [ [ [text old], pwords "has been deprecated." ]+ , [ ["Use", text new, "instead." ] | new <- maybeToList mnew ]+ , [ pwords "This will be an error in", [text version <> "."] ]+ ] NicifierIssue w -> pretty w @@ -386,78 +404,154 @@ NotAmbiguous -> pwords "neither a defined symbol nor a constructor" ] - IllegalRewriteRule q reason -> case reason of- LHSNotDefinitionOrConstructor -> hsep- [ prettyTCM q , " is not a legal rewrite rule, since the left-hand side is neither a defined symbol nor a constructor" ]- VariablesNotBoundByLHS xs -> 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)- ]- VariablesBoundMoreThanOnce xs -> 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?"- LHSReduces v v' -> fsep- [ prettyTCM q <+> " is not a legal rewrite rule, since the left-hand side "- , prettyTCM v <+> " reduces to " <+> prettyTCM v' ]- HeadSymbolIsProjectionLikeFunction f -> 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- HeadSymbolIsTypeConstructor f -> hsep- [ prettyTCM q , " is not a legal rewrite rule, since the head symbol"- , prettyTCM f , "is a type constructor."- ]- HeadSymbolContainsMetas f -> hsep- [ prettyTCM q , "is not a legal rewrite rule, since the definition of the head symbol"- , prettyTCM f , "contains unsolved metavariables and confluence checking is enabled."- ]- ConstructorParametersNotGeneral c vs -> vcat- [ prettyTCM q <+> text " is not a legal rewrite rule, since the constructor parameters are not fully general:"- , nest 2 $ text "Constructor: " <+> prettyTCM c- , nest 2 $ text "Parameters: " <+> prettyList (map prettyTCM vs)- ]- ContainsUnsolvedMetaVariables ms -> hsep- [ prettyTCM q , " is not a legal rewrite rule, since"- , "it contains the unsolved meta variable(s)", prettyList_ (fmap prettyTCM $ Set1.toList ms)- ]- BlockedOnProblems ps -> hsep- [ prettyTCM q , " is not a legal rewrite rule, since"- , "it is blocked on problem(s)", prettyList_ (fmap prettyTCM $ Set1.toList ps)- ]- RequiresDefinitions qs -> hsep- [ prettyTCM q , " is not a legal rewrite rule, since"- , "it requires the definition(s) of", prettyList_ (fmap prettyTCM $ Set1.toList qs)- ]- DoesNotTargetRewriteRelation -> hsep- [ prettyTCM q , " does not target rewrite relation" ]- BeforeFunctionDefinition -> hsep- [ "Rewrite rule from function "- , prettyTCM q- , " cannot be added before the function definition"- ]- BeforeMutualFunctionDefinition r -> hsep- [ "Rewrite rule from function "- , prettyTCM q- , " cannot be added before the definition of mutually defined"- , prettyTCM r- ]- DuplicateRewriteRule ->- "Rewrite rule " <+> prettyTCM q <+> " has already been added"+ IllegalRewriteRule q reason -> do+ let illegalSince q = [ prettyTCM q, "" ] ++ pwords "is not a legal rewrite rule, since"+ case reason of - ConfluenceCheckingIncompleteBecauseOfMeta f -> fsep- [ "Confluence checking incomplete because the definition of"- , prettyTCM f- , text "contains unsolved metavariables."+ LHSNotDefinitionOrConstructor -> do+ (fsep . concat)+ [ illegalSince q+ , pwords "the left-hand side is neither a defined symbol nor a constructor"+ ]++ VariablesNotBoundByLHS xs -> do+ (fsep . concat)+ [ illegalSince q+ , pwords "the following"+ , pwords $ singPlural ys "variable is" "variables are"+ , pwords "not bound by the left hand side:"+ ]+ <?> fsep (map (prettyTCM . var) ys)+ where ys = VarSet.toAscList xs++ VariablesBoundMoreThanOnce xs -> do+ (fsep . concat)+ [ illegalSince q+ , pwords "the following"+ , pwords $ singPlural ys "parameter is" "parameters are"+ , pwords "bound more than once on the left hand side:"+ ]+ <?> fsep (map (prettyTCM . var) ys)+ $$ fwords "(Perhaps you can use a postulate instead of a constructor as the head symbol?)"+ where ys = VarSet.toAscList xs++ VariablesBoundInSingleton xs -> do+ -- This warning is motivated in #8238. If #6636 is implemented, then+ -- this warning should be disabled.+ (fsep . concat)+ [ pwords "I am not certain that the rewrite rule"+ , [ "", prettyTCM q, "" ]+ , pwords "is safe because it appears that the following"+ , pwords $ singPlural ys "variable is" "variables are"+ , pwords "only bound in contexts which might become definitionally singular:"+ ]+ <?> fsep (map (prettyTCM . var) ys)+ $$ fwords "This warning can be silenced with"+ <?> hcat [ "-Wno", text (warningNameToString RewriteVariablesBoundInSingleton_) ]+ $$ fwords "but be aware that this rewrite might behave strangely in the presence of e.g. eta records with no fields"+ where ys = VarSet.toAscList xs++ LHSReduces v v' -> vcat+ [ (fsep . concat) [ illegalSince q, pwords "the left-hand side" ]+ , nest 2 $ prettyTCM v+ , fwords "reduces to"+ , nest 2 $ prettyTCM v'+ ]++ HeadSymbolIsProjectionLikeFunction f -> vcat+ [ (fsep . concat)+ [ illegalSince q , pwords "the head symbol"+ , [ "", hd, ""]+ , pwords "is a projection-like function."+ ]+ , (fsep . concat)+ [ pwords "You can turn off the projection-like optimization for"+ , [ hd ]+ , pwords "with the pragma"+ ]+ , nest 2 $ fsep [ "{-# NOT_PROJECTION_LIKE", hd, "#-}" ]+ , fwords "or globally with the flag --no-projection-like"+ ]+ where hd = prettyTCM f++ HeadSymbolIsTypeConstructor f -> (fsep . concat)+ [ illegalSince q+ , pwords "the head symbol"+ , [ prettyTCM f ]+ , pwords "is a type constructor."+ ]++ HeadSymbolContainsMetas f -> (fsep . concat)+ [ illegalSince q+ , pwords "the definition of the head symbol"+ , [ prettyTCM f ]+ , pwords "contains unsolved metavariables and confluence checking is enabled."+ ]++ ConstructorParametersNotGeneral c vs -> vcat+ [ (fsep . concat) [ illegalSince q, pwords "the constructor parameters are not fully general:" ]+ , nest 2 $ text "Constructor: " <+> prettyTCM c+ , nest 2 $ (pluralS vs "Parameter" <> ": ") <+> fsep (punctuate ";" $ fmap prettyTCM vs)+ ]++ ContainsUnsolvedMetaVariables ms -> do+ (fsep . concat)+ [ illegalSince q+ , pwords "it contains the unsolved meta"+ , [ pluralS ms "variable" <> colon ]+ ]+ <?> fsep (fmap prettyTCM $ Set1.toList ms)++ BlockedOnProblems ps -> do+ (fsep . concat)+ [ illegalSince q+ , pwords "it is blocked on"+ , [ pluralS ps "problem" <> colon]+ ]+ <?> fsep (fmap prettyTCM $ Set1.toList ps)++ RequiresDefinitions qs -> do+ (fsep . concat)+ [ illegalSince q+ , pwords "it requires the"+ , [ pluralS qs "definition", "of" <> colon]+ ]+ <?> fsep (fmap prettyTCM $ Set1.toList qs)++ DoesNotTargetRewriteRelation -> (fsep . concat)+ [ [ prettyTCM q, "" ], pwords "does not target rewrite relation" ]++ BeforeFunctionDefinition -> (fsep . concat)+ [ pwords "Rewrite rule from function"+ , [ "", prettyTCM q, ""]+ , pwords "cannot be added before the function definition"+ ]++ BeforeMutualFunctionDefinition r -> (fsep . concat)+ [ pwords "Rewrite rule from function"+ , [ "", prettyTCM q, ""]+ , pwords "cannot be added before the definition of mutually defined"+ , [ prettyTCM r ]+ ]++ DuplicateRewriteRule -> (fsep . concat)+ [ pwords "Rewrite rule"+ , [ "", prettyTCM q, ""]+ , pwords "has already been added"+ ]++ LocalRewriteOutsideTelescope -> (fsep . concat)+ [ illegalSince q+ , pwords "local rewrite rules are (currently) only allowed in module telescopes. Consider creating an anonymous module"+ ]++ ConfluenceCheckingIncompleteBecauseOfMeta f -> (fsep . concat)+ [ pwords "Confluence checking incomplete because the definition of"+ , [ prettyTCM f ]+ , pwords "contains unsolved metavariables." ] - ConfluenceForCubicalNotSupported -> fsep $ pwords $+ ConfluenceForCubicalNotSupported -> fwords $ "Confluence checking for --cubical is not yet supported, confluence checking might be incomplete" RewriteNonConfluent lhs rhs1 rhs2 err -> fsep@@ -502,9 +596,23 @@ ] ] + InferredLocalRewrite m v -> vcat+ [ fsep $ pwords "Tried to solve"+ , nest 2 $ prettyTCM m+ , fsep $ pwords "with the following function (containing a local rewrite rule parameter):"+ , nest 2 $ prettyTCM v+ , fsep $ pwords "Local rewrite rules must be explicitly annotated (never inferred)."+ , fsep $ pwords "Please annotate all local rewrite rules explicitly." ]+ DuplicateRecordDirective dir -> "Ignoring duplicate record directive: " <+> pretty dir + UnknownJSPrimitive p -> fsep $ concat+ [ pwords "The primitive"+ , [ text p ]+ , pwords "is not known to the JS backend and will be compiled to undefined."+ ]+ PragmaCompileErased bn qn -> fsep $ concat [ pwords "The backend" , [ prettyTCM bn@@ -628,6 +736,11 @@ [pretty e] ++ pwords "cannot appear by itself. It needs to be the argument to" ++ pwords "a function expecting an instance argument." + IllegalDeclarationInDataDefinition ds -> vcat+ [ "Illegal declaration in data type definition"+ , nest 2 $ vcat $ fmap pretty ds+ ]+ InvalidDisplayForm x reason -> fsep $ concat [ pwords "Ignoring invalid display form for" , [ prettyTCM x ]@@ -648,11 +761,19 @@ ] ] + ShouldBeEtaRecordPattern -> fwords+ "Irrefutable matching on non-eta record constructor"+ TooManyArgumentsToSort q args -> fsep $ concat [ pwords "Too many arguments given to sort" , [ prettyTCM q ] ] + DefinitionBeforeDeclaration x -> fsep $ concat+ [ [ prettyTCM x ]+ , pwords "defined before its declaration"+ ]+ RewritesNothing -> fsep $ pwords "`rewrite' did not apply" WithClauseProjectionFixityMismatch p0 o' q o -> fsep $ concat@@ -670,6 +791,12 @@ prettyProjOrigin ProjPostfix = "a postfix projection" prettyProjOrigin ProjSystem = __IMPOSSIBLE__ + RecursiveRecordNeedsInductivity q -> fsep $ concat+ [ pwords "Recursive record"+ , [ prettyTCM q ]+ , pwords "needs to be declared as either inductive or coinductive"+ ]+ FaceConstraintCannotBeHidden ai -> fsep $ pwords "Face constraint patterns cannot be" ++ [ pretty (getHiding ai), "arguments"] @@ -691,7 +818,15 @@ IsData{} -> "data" IsRecord{} -> "record" +instance PrettyTCM RewriteSource where+ prettyTCM s = prettyTCM (defName <$> s) +instance PrettyTCM SerialisableRewriteSource where+ prettyTCM = \case+ LocalRewrite g n t ->+ maybe "_" prettyTCM n <+> ":" <+> addContext g (prettyTCM t)+ GlobalRewrite q -> prettyTCM q+ {-# SPECIALIZE prettyRecordFieldWarning :: RecordFieldWarning -> TCM Doc #-} prettyRecordFieldWarning :: MonadPretty m => RecordFieldWarning -> m Doc prettyRecordFieldWarning = \case@@ -699,28 +834,32 @@ W.TooManyFields q ys xrs -> prettyTooManyFields q ys $ fmap fst xrs prettyDuplicateFields :: MonadPretty m => List1 C.Name -> m Doc-prettyDuplicateFields xs = fsep $ concat+prettyDuplicateFields xs =+ (fsep . concat) [ [ "Duplicate", pluralS xs "field" ]- , punctuate comma (fmap pretty xs)- , pwords "in record"+ , pwords "in record:" ]+ <?> fsep (fmap pretty xs) {-# SPECIALIZE prettyTooManyFields :: QName -> [C.Name] -> List1 C.Name -> TCM Doc #-} prettyTooManyFields :: MonadPretty m => QName -> [C.Name] -> List1 C.Name -> m Doc-prettyTooManyFields r missing xs = fsep $ concat+prettyTooManyFields r missing xs =+ (fsep . concat) [ pwords "The record type" , [prettyTCM r] , pwords "does not have the" , fields xs- , punctuate comma (fmap pretty xs)- , if null missing then [] else concat+ ]+ <?> fsep (fmap pretty xs)+ $$+ if null missing then empty else+ (fsep . concat) [ pwords "but it would have the" , fields missing- , punctuate comma (map pretty missing) ]- ]+ <?> fsep (map pretty missing) where- fields ys = [ pluralS ys "field" ]+ fields ys = [ pluralS ys "field" <> colon ] {-# SPECIALIZE prettyNotInScopeNames :: (Pretty a, HasRange a) => Bool -> (a -> TCM Doc) -> [a] -> TCM Doc #-} -- | Report a number of names that are not in scope.@@ -738,10 +877,10 @@ , suggestion x ] -{-# SPECIALIZE didYouMean :: (Pretty a, Pretty b) => [C.QName] -> (a -> b) -> a -> Maybe (TCM Doc) #-}+{-# SPECIALIZE didYouMean :: (Pretty b) => [C.QName] -> (a -> b) -> a -> Maybe (TCM Doc) #-} -- | Suggest some corrections to a misspelled name. didYouMean- :: (MonadPretty m, Pretty a, Pretty b)+ :: (MonadPretty m, Pretty b) => [C.QName] -- ^ Names in scope. -> (a -> b) -- ^ Canonization function for similarity search. -> a -- ^ A name which is not in scope.@@ -784,10 +923,15 @@ -- | Turns warnings, if any, into errors.-tcWarningsToError :: [TCWarning] -> TCM ()-tcWarningsToError mws = case (unsolvedHoles, otherWarnings) of+tcWarningsToError ::+ TopLevelModuleNameWithSourceFile+ -- ^ The module we have checked (which produced the warnings).+ -> [TCWarning]+ -- ^ The warnings to turn into errors.+ -> TCM ()+tcWarningsToError x mws = case (unsolvedHoles, otherWarnings) of ([], []) -> return ()- (_unsolvedHoles@(_:_), []) -> typeError SolvedButOpenHoles+ (_unsolvedHoles@(_:_), []) -> typeError $ SolvedButOpenHoles x (_ , w : ws) -> typeError $ NonFatalErrors $ Set1.fromList (w :| ws) where -- filter out unsolved interaction points for imported module so@@ -836,7 +980,7 @@ g (a, _, _, _) = getRange a {-# SPECIALIZE getAllUnsolvedWarnings :: TCM [TCWarning] #-}-getAllUnsolvedWarnings :: (ReadTCState m, MonadWarning m, MonadTCM m) => m [TCWarning]+getAllUnsolvedWarnings :: (MonadWarning m, MonadTCM m) => m [TCWarning] getAllUnsolvedWarnings = do unsolvedInteractions <- getUnsolvedInteractionMetas @@ -856,12 +1000,12 @@ -- | Collect all warnings that have accumulated in the state. {-# SPECIALIZE getAllWarnings :: WhichWarnings -> TCM (Set TCWarning) #-}-getAllWarnings :: (ReadTCState m, MonadWarning m, MonadTCM m) => WhichWarnings -> m (Set TCWarning)+getAllWarnings :: (MonadWarning m, MonadTCM m) => WhichWarnings -> m (Set TCWarning) getAllWarnings = getAllWarningsPreserving Set.empty {-# SPECIALIZE getAllWarningsPreserving :: Set WarningName -> WhichWarnings -> TCM (Set TCWarning) #-} getAllWarningsPreserving ::- (ReadTCState m, MonadWarning m, MonadTCM m) => Set WarningName -> WhichWarnings -> m (Set TCWarning)+ (MonadWarning m, MonadTCM m) => Set WarningName -> WhichWarnings -> m (Set TCWarning) getAllWarningsPreserving keptWarnings ww = do unsolved <- Set.fromList <$> getAllUnsolvedWarnings collectedTCWarnings <- useTC stTCWarnings
src/full/Agda/TypeChecking/Primitive.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-} {-# OPTIONS_GHC -Wunused-imports #-} {-| Primitive functions, such as addition on builtin integers.@@ -47,6 +48,7 @@ import Agda.Syntax.Common.Pretty import Agda.Utils.Singleton import Agda.Utils.Size+import qualified Agda.Utils.SmallSet as SmallSet import Agda.Utils.Impossible @@ -266,6 +268,7 @@ toTerm = do sigKit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit let con = Con (sigmaCon sigKit) ConOSystem []+ fromA <- toTerm fromB <- toTerm pure $ \ (a, b) -> apply2 con <$> fromA a <*> fromB b@@ -630,7 +633,7 @@ _ -> False Var{} -> return False MetaV{} -> __IMPOSSIBLE__- Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s+ Dummy s _ -> __IMPOSSIBLE_VERBOSE__ (show s) ifM (isWHNF u) (redReturn $ ret (unArg f) (ignoreBlocking u)) (return $ NoReduction $ map notReduced [a, b, s, t] ++ [reduced u, notReduced f])@@ -683,6 +686,37 @@ let t = sort $ Type $ levelSuc $ Max 0 [] return $ PrimImpl t $ primFun __IMPOSSIBLE__ 0 $ \_ -> redReturn $ Sort LockUniv +primRewriteNoMatch :: TCM PrimitiveImpl+primRewriteNoMatch = do+ t <- hPi "a" (el primLevel) $+ hPi "A" (pure $ sort $ varSort 0) $+ (el (pure $ var 0) --> el (pure $ var 0))++ return $ PrimImpl t $ primFun __IMPOSSIBLE__ 3 $ \ ~[l, a, x] -> do+ allowed <- viewTC eAllowedReductions++ if RewriteNoMatchReductions `SmallSet.member` allowed+ then redReturn $ unArg x+ else return $ NoReduction $ notReduced <$> [l, a, x]++primQrec :: TCM PrimFun+primQrec = do+ box <- primQuotientConstructor+ box <- case box of+ Def box [] -> return box+ _ -> __IMPOSSIBLE__+ return $ primFun __IMPOSSIBLE__ 10 $ \args -> do+ case args of+ [a, r, p, a', r', p', f, r'', s, x] -> do+ x <- reduceB' x+ case unArg <$> x of+ NotBlocked _ (Def d [_ , _ , _ , _ , Apply x]) | d == box ->+ redReturn (apply (unArg f) [x])+ _ ->+ return $ NoReduction $+ map notReduced [a, r, p, a', r', p', f, r'', s] ++ [reduced x]+ _ -> return (NoReduction (map notReduced args))+ mkPrimFun1TCM :: (FromTerm a, ToTerm b) => TCM Type -> (a -> ReduceM b) -> TCM PrimitiveImpl mkPrimFun1TCM mt f = do@@ -819,7 +853,11 @@ type Rel a = a -> a -> Bool type Pred a = a -> Bool -primitiveFunctions :: Map PrimitiveId (TCM PrimitiveImpl)+-- | If the type is 'Nothing', then the type of the given primitive is+-- \"trusted\", i.e. taken from the primitive declaration in the Agda+-- file.++primitiveFunctions :: Map PrimitiveId (TCM (Maybe Type, PrimFun)) primitiveFunctions = localTCStateSavingWarnings <$> Map.fromListWith __IMPOSSIBLE__ -- Issue #4375 ^^^^^^^^^^^^^^^^^^^^^^^^^^ -- Without this the next fresh checkpoint id gets changed building the primitive functions. This@@ -949,6 +987,7 @@ -- Other stuff , PrimEraseEquality |-> primEraseEquality+ , PrimRewriteNoMatch |-> primRewriteNoMatch -- This needs to be force : A → ((x : A) → B x) → B x rather than seq because of call-by-name. , PrimForce |-> primForce , PrimForceLemma |-> primForceLemma@@ -956,7 +995,7 @@ , PrimQNameLess |-> mkPrimFun2 ((<) :: Rel QName) , PrimShowQName |-> mkPrimFun1 (T.pack . prettyShow :: QName -> Text) , PrimQNameFixity |-> mkPrimFun1 (nameFixity . qnameName)- , PrimQNameToWord64s |-> mkPrimFun1 ((\ (NameId x (ModuleNameHash y)) -> (x, y)) . nameId . qnameName+ , PrimQNameToWord64s |-> mkPrimFun1 ((\ (NameId x (ModuleNameHash y)) -> (x, y)) . nameId :: QName -> (Word64, Word64)) , PrimQNameToWord64sInjective |-> primQNameToWord64sInjective , PrimMetaEquality |-> mkPrimFun2 ((==) :: Rel MetaId)@@ -982,6 +1021,9 @@ , Prim_glueU |-> prim_glueU' , Prim_unglueU |-> prim_unglueU' , PrimLockUniv |-> primLockUniv'++ , PrimQrec |->> primQrec ] where- (|->) = (,)+ (|->>) = \p f -> (p, do f <- f; return (Nothing, f))+ (|->) = \p f -> (p, do PrimImpl t f <- f; return (Just t, f))
src/full/Agda/TypeChecking/Primitive.hs-boot view
@@ -5,5 +5,6 @@ import Data.Map (Map) import Agda.TypeChecking.Monad.Base import Agda.Syntax.Builtin (PrimitiveId)+import Agda.Syntax.Internal (Type) -primitiveFunctions :: Map PrimitiveId (TCM PrimitiveImpl)+primitiveFunctions :: Map PrimitiveId (TCM (Maybe Type, PrimFun))
src/full/Agda/TypeChecking/Primitive/Base.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ApplicativeDo #-}+{-# OPTIONS_GHC -Wunused-imports #-} module Agda.TypeChecking.Primitive.Base where @@ -21,7 +22,6 @@ import Agda.TypeChecking.Monad.Signature import Agda.TypeChecking.Substitute -import Agda.Utils.Functor import Agda.Utils.Impossible import Agda.Utils.Maybe import Agda.Syntax.Common.Pretty ( prettyShow )@@ -32,16 +32,17 @@ infixr 4 .--> infixr 4 ..--> -(-->), (.-->), (..-->) :: Applicative m => m Type -> m Type -> m Type+(-->), (.-->), (..-->) :: HasOptions m => m Type -> m Type -> m Type a --> b = garr id a b a .--> b = garr (const irrelevant) a b a ..--> b = garr (const shapeIrrelevant) a b -garr :: Applicative m => (Relevance -> Relevance) -> m Type -> m Type -> m Type+garr :: HasOptions m => (Relevance -> Relevance) -> m Type -> m Type -> m Type garr f a b = do a' <- a b' <- b- pure $ El (funSort (getSort a') (getSort b')) $+ s <- funSortM (getSort a') (getSort b')+ pure $ El s $ Pi (mapRelevance f $ defaultDom a') (NoAbs "_" b') gpi :: (MonadAddContext m, MonadDebug m)@@ -77,7 +78,7 @@ -- function. toFinitePi :: Type -> Type toFinitePi (El s (Pi d b)) = El s $ Pi- (setRelevance irrelevant d{ domIsFinite = True })+ (setRelevance irrelevant $ set dIsFinite True d) b toFinitePi _ = __IMPOSSIBLE__ @@ -174,21 +175,35 @@ -- * Accessing the primitive functions --------------------------------------------------------------------------- -lookupPrimitiveFunction :: PrimitiveId -> TCM PrimitiveImpl-lookupPrimitiveFunction x =+-- | 'Nothing' is returned for trusted primitives (those for which the+-- type is taken from the declaration).++lookupPossiblyTrustedPrimitiveFunction ::+ PrimitiveId -> TCM (Maybe Type, PrimFun)+lookupPossiblyTrustedPrimitiveFunction x = fromMaybe (do reportSDoc "tc.prim" 20 $ "Lookup of primitive function" <+> pretty x <+> "failed" typeError $ NoSuchPrimitiveFunction (getBuiltinId x)) (Map.lookup x primitiveFunctions) -lookupPrimitiveFunctionQ :: QName -> TCM (PrimitiveId, PrimitiveImpl)+-- | An error is raised for trusted primitives.++lookupPrimitiveFunction :: PrimitiveId -> TCM PrimitiveImpl+lookupPrimitiveFunction x = do+ (t, f) <- lookupPossiblyTrustedPrimitiveFunction x+ case t of+ Just t -> return (PrimImpl t f)+ Nothing -> __IMPOSSIBLE__++lookupPrimitiveFunctionQ ::+ QName -> TCM (PrimitiveId, Maybe Type, PrimFun) lookupPrimitiveFunctionQ q = do let s = prettyShow (nameCanonical $ qnameName q) case primitiveById s of Nothing -> typeError $ NoSuchPrimitiveFunction s Just s -> do- PrimImpl t pf <- lookupPrimitiveFunction s- return (s, PrimImpl t $ pf { primFunName = q })+ (t, pf) <- lookupPossiblyTrustedPrimitiveFunction s+ return (s, t , pf { primFunName = q }) getBuiltinName :: (HasBuiltins m, MonadReduce m) => BuiltinId -> m (Maybe QName) getBuiltinName b = runMaybeT $ getQNameFromTerm =<< MaybeT (getBuiltin' b)
src/full/Agda/TypeChecking/Primitive/Cubical.hs view
@@ -38,6 +38,7 @@ import Agda.TypeChecking.Reduce import Agda.TypeChecking.Telescope +import Agda.Utils.Boolean ( toBool ) import Agda.Utils.Either import Agda.Utils.Function import Agda.Utils.Functor@@ -56,7 +57,7 @@ primPOr :: TCM PrimitiveImpl primPOr = do- requireCubical CErased+ requireCubical CWithoutGlue t <- runNamesT [] $ hPi' "a" (els (pure LevelUniv) (cl primLevel)) $ \ a -> nPi' "i" primIntervalType $ \ i ->@@ -86,7 +87,7 @@ primPartial' :: TCM PrimitiveImpl primPartial' = do- requireCubical CErased+ requireCubical CWithoutGlue t <- runNamesT [] $ hPi' "a" (els (pure LevelUniv) (cl primLevel)) (\ a -> nPi' "φ" primIntervalType $ \ _ ->@@ -102,7 +103,7 @@ primPartialP' :: TCM PrimitiveImpl primPartialP' = do- requireCubical CErased+ requireCubical CWithoutGlue t <- runNamesT [] $ hPi' "a" (els (pure LevelUniv) (cl primLevel)) (\ a -> nPi' "φ" primIntervalType $ \ phi ->@@ -117,7 +118,7 @@ primSubOut' :: TCM PrimitiveImpl primSubOut' = do- requireCubical CErased+ requireCubical CWithoutGlue t <- runNamesT [] $ hPi' "a" (els (pure LevelUniv) (cl primLevel)) $ \ a -> hPi' "A" (el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->@@ -141,7 +142,7 @@ primTrans' :: TCM PrimitiveImpl primTrans' = do- requireCubical CErased+ requireCubical CWithoutGlue t <- runNamesT [] $ hPi' "a" (primIntervalType --> els (pure LevelUniv) (cl primLevel)) $ \ a -> nPi' "A" (nPi' "i" primIntervalType $ \ i -> (sort . tmSort <$> (a <@> i))) $ \ bA ->@@ -152,7 +153,7 @@ primHComp' :: TCM PrimitiveImpl primHComp' = do- requireCubical CErased+ requireCubical CWithoutGlue t <- runNamesT [] $ hPi' "a" (els (pure LevelUniv) (cl primLevel)) $ \ a -> hPi' "A" (sort . tmSort <$> a) $ \ bA ->@@ -570,11 +571,12 @@ -- 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+ Datatype{dataPars = pars, dataIxs = ixs, dataHIT = hit, dataTransp = mtrD}+ | and [ hit == NotHIT && ixs == 0 | DoHComp <- [cmd] ]+ , Just as <- allApplyElims es ->+ compData mtrD (hit == YesHIT || ixs > 0) (pars + ixs) cmd l (as <$ t) sbA sphi u u0 - -- Is this an axiom with constrant transport? Then. Well. Transport is constant.+ -- Is this an axiom with constant transport? Then. Well. Transport is constant. Axiom constTransp | constTransp, [] <- es, DoTransp <- cmd -> redReturn $ unArg u0 _ -> fallback@@ -609,10 +611,7 @@ 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)+ constrForm <- constructorFormer su <- reduceB' u sa0 <- reduceB' a0 view <- intervalView'@@ -689,10 +688,7 @@ getTermLocal = getTerm $ getBuiltinId 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)+ constrForm <- constructorFormer sa0 <- reduceB' a0 let f = unArg . ignoreBlocking phi = f sphi@@ -746,7 +742,7 @@ -- The definition of it comes from 'mkComp'. primComp :: TCM PrimitiveImpl primComp = do- requireCubical CErased+ requireCubical CWithoutGlue t <- runNamesT [] $ hPi' "a" (primIntervalType --> els (pure LevelUniv) (cl primLevel)) $ \ a -> nPi' "A" (nPi' "i" primIntervalType $ \ i -> (sort . tmSort <$> (a <@> i))) $ \ bA ->@@ -781,7 +777,7 @@ -- TODO Andrea: keep reductions that happen under foralls? primFaceForall' :: TCM PrimitiveImpl primFaceForall' = do- requireCubical CErased+ requireCubical CWithoutGlue t <- (primIntervalType --> primIntervalType) --> primIntervalType return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \case [phi] -> do@@ -892,8 +888,8 @@ -- [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'+ let sys' = (phi , a) : map (second (`bapp` i)) us+ sys = map (second $ 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@@ -1045,29 +1041,6 @@ --- 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- runExceptT (pathTelescope' tel lhs rhs) >>= \case- 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 : Δ@@ -1298,7 +1271,7 @@ 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)+hcomp :: (HasBuiltins m, MonadError TCErr m, MonadReduce m) => NamesT m Type -> [(NamesT m Term, NamesT m Term)] -> NamesT m Term
src/full/Agda/TypeChecking/Primitive/Cubical/Base.hs view
@@ -56,7 +56,7 @@ -- | Checks that the correct variant of Cubical Agda is activated.--- Note that @--erased-cubical@ \"counts as\" @--cubical@ in erased+-- Note that @--cubical=erased@ \"counts as\" @--cubical@ in erased -- contexts. requireCubical :: Cubical -- ^ Which variant of Cubical Agda is required?@@ -70,10 +70,11 @@ -> TCM () requireCubical' wanted reason = do cubical <- cubicalOption- inErasedContext <- hasQuantity0 <$> viewTC eQuantity+ inErasedContext <- hasQuantity0 <$> viewTC eQuantityZeroHardCompile case cubical of Just CFull -> return ()- Just CErased | wanted == CErased || inErasedContext -> return ()+ Just CErased | wanted /= CFull || inErasedContext -> return ()+ Just CWithoutGlue | wanted == CWithoutGlue -> return () _ -> typeError $ NeedOptionCubical wanted reason -- | Our good friend the interval type.@@ -84,7 +85,7 @@ -- their implementation is handled here. primINeg' :: TCM PrimitiveImpl primINeg' = do- requireCubical CErased+ requireCubical CWithoutGlue t <- primIntervalType --> primIntervalType return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \case [x] -> do@@ -118,7 +119,7 @@ -- parameterised by their unit and absorbing elements. primIBin :: IntervalView -> IntervalView -> TCM PrimitiveImpl primIBin unit absorber = do- requireCubical CErased+ requireCubical CWithoutGlue t <- primIntervalType --> primIntervalType --> primIntervalType return $ PrimImpl t $ primFun __IMPOSSIBLE__ 2 $ \case [x,y] -> do@@ -150,14 +151,14 @@ -- cofibration classifier. primIMin' :: TCM PrimitiveImpl primIMin' = do- requireCubical CErased+ requireCubical CWithoutGlue primIBin IOne IZero -- | Implements both the @max@ connection /and/ disjunction on the -- cofibration classifier. primIMax' :: TCM PrimitiveImpl primIMax' = do- requireCubical CErased+ requireCubical CWithoutGlue primIBin IZero IOne -- | A helper for evaluating @max@ on the interval in TCM&co.@@ -321,7 +322,7 @@ -- | Helper function for constructing the filler of a given composition -- problem. hfill- :: (HasBuiltins m, HasConstInfo m)+ :: (HasBuiltins m) => NamesT m Term -- @la : Level@ -> NamesT m Term -- @A : Type la@ -> NamesT m Term -- @φ : I@. Cofibration
src/full/Agda/TypeChecking/Primitive/Cubical/Glue.hs view
@@ -36,7 +36,6 @@ , SigmaKit(..), getSigmaKit ) -import Agda.Utils.Functor import Agda.Utils.Maybe import Agda.Utils.Monad @@ -260,7 +259,7 @@ 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))+ [ (phi <@> pure io, ilam "o" $ \o -> alpha o <@@> (w (pure io) o <@> t1' o, a1, ineg j)) , (psi, ilam "o" $ \o -> a1) ]) <@> a1
src/full/Agda/TypeChecking/Primitive/Cubical/HCompU.hs view
@@ -34,7 +34,6 @@ import Agda.TypeChecking.Substitute ( absBody, apply, sort, applyE ) -import Agda.Utils.Functor import Agda.Utils.Maybe import Agda.Utils.Monad @@ -191,7 +190,7 @@ 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))+ [ (phi <@> pure io, ilam "o" $ \o -> alpha o <@@> (w (pure io) o <@> t1' o, a1, ineg j)) , (psi, ilam "o" $ \o -> a1) ]) <@> a1@@ -208,7 +207,7 @@ prim_glueU' = do -- TODO (Amy, 2022-08-17): Same thing about duplicated code with Glue -- applies here.- requireCubical CErased+ requireCubical CWithoutGlue t <- runNamesT [] $ hPi' "la" (el $ cl primLevel) (\ la -> hPi' "φ" primIntervalType $ \ φ ->@@ -235,7 +234,7 @@ prim_unglueU' = do -- TODO (Amy, 2022-08-17): Same thing about duplicated code with Glue -- applies here.- requireCubical CErased+ requireCubical CWithoutGlue t <- runNamesT [] $ hPi' "la" (el $ cl primLevel) (\ la -> hPi' "φ" primIntervalType $ \ φ ->
src/full/Agda/TypeChecking/ProjectionLike.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -Wunused-imports #-}+-- {-# OPTIONS_GHC -Wunused-imports #-} -- | Dropping initial arguments (``parameters'') from a function which can be -- easily reconstructed from its principal argument.@@ -59,7 +59,7 @@ module Agda.TypeChecking.ProjectionLike where import qualified Data.Map as Map-import Data.Monoid (Any(..), getAny)+-- import Data.Monoid (Any(..), getAny) import Agda.Interaction.Options @@ -69,17 +69,18 @@ import Agda.Syntax.Internal.Pattern import Agda.TypeChecking.Monad-import Agda.TypeChecking.Free (runFree, IgnoreSorts(..))+import Agda.TypeChecking.Free (anyFreeVar) import Agda.TypeChecking.Substitute import Agda.TypeChecking.Positivity+import Agda.TypeChecking.Positivity.OccurrenceAnalysis qualified as Occ import Agda.TypeChecking.Pretty import Agda.TypeChecking.Records-import Agda.TypeChecking.Reduce (reduce, abortIfBlocked)+import Agda.TypeChecking.Reduce (reduce, abortIfBlocked, reduceDefCopies) import Agda.TypeChecking.Telescope import Agda.TypeChecking.DropArgs -import Agda.Utils.Lens+import Agda.Utils.CallStack (HasCallStack) import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Monad@@ -107,8 +108,7 @@ -- | Semantics of 'ProjectionView'. unProjView :: ProjectionView -> Term-unProjView pv =- case pv of+unProjView = \case ProjectionView f a es -> Def f (Apply a : es) LoneProjectionLike f ai -> Def f [] NoProjection v -> v@@ -140,49 +140,51 @@ reduceProjectionLike v = do -- Andreas, 2013-11-01 make sure we do not reduce a constructor -- because that could be folded back into a literal by reduce.- pv <- projView v- case pv of+ projView v >>= \case ProjectionView{} -> onlyReduceProjections $ reduce v -- ordinary reduce, only different for Def's _ -> return v -data ProjEliminator = EvenLone | ButLone | NoPostfix+-- | How to treat lone projection-like functions+-- (i.e. those that miss their principal argument) in 'elimView'.+data LoneProjectionLikeToLambda+ = LoneProjectionLikeToLambda+ -- ^ Turn lone projection-like functions into lambdas.+ | KeepLoneProjectionLike+ -- ^ Leave lone projection-like functions as they are. deriving Eq -{-# SPECIALIZE elimView :: ProjEliminator -> Term -> TCM Term #-}+{-# SPECIALIZE elimView :: LoneProjectionLikeToLambda -> Term -> TCM Term #-} -- | Turn prefix projection-like function application into postfix ones. -- This does just one layer, such that the top spine contains -- the projection-like functions as projections. -- Used in 'compareElims' in @TypeChecking.Conversion@ -- and in "Agda.TypeChecking.CheckInternal". ----- If the 'Bool' is 'True', a lone projection like function will be+-- With 'LoneProjectionLikeToLambda', a lone projection like function will be -- turned into a lambda-abstraction, expecting the principal argument.--- If the 'Bool' is 'False', it will be returned unaltered.+-- If the 'KeepLoneProjectionLike', it will be returned unaltered. -- -- No precondition. -- Preserves constructorForm, since it really does only something -- on (applications of) projection-like functions.-elimView :: PureTCM m => ProjEliminator -> Term -> m Term-elimView pe v = do+elimView :: PureTCM m => LoneProjectionLikeToLambda -> Term -> m Term+elimView loneProjectionLikeToLambda v = do reportSDoc "tc.conv.elim" 60 $ "elimView of " <+> prettyTCM v v <- reduceProjectionLike v reportSDoc "tc.conv.elim" 65 $ "elimView (projections reduced) of " <+> prettyTCM v- case pe of- NoPostfix -> return v- _ -> do- pv <- projView v- case pv of- NoProjection{} -> return v- LoneProjectionLike f ai- | pe == EvenLone -> return $ Lam ai $ Abs "r" $ Var 0 [Proj ProjPrefix f]- | otherwise -> return v- ProjectionView f a es -> (`applyE` (Proj ProjPrefix f : es)) <$> elimView pe (unArg a)+ projView v >>= \case+ LoneProjectionLike f ai -> case loneProjectionLikeToLambda of+ LoneProjectionLikeToLambda -> return $ Lam ai $ Abs "r" $ Var 0 [Proj ProjPrefix f]+ KeepLoneProjectionLike -> return v+ ProjectionView f a es -> (`applyE` (Proj ProjPrefix f : es)) <$> elimView loneProjectionLikeToLambda (unArg a)+ NoProjection{} -> return v {-# SPECIALIZE eligibleForProjectionLike :: QName -> TCM Bool #-}--- | Which @Def@types are eligible for the principle argument+-- | Which @Def@ heads are eligible for the principle argument -- of a projection-like function?+-- They need to be injective, which is the case for data, record, and axiom. eligibleForProjectionLike :: (HasConstInfo m) => QName -> m Bool eligibleForProjectionLike d = eligible . theDef <$> getConstInfo d where@@ -211,6 +213,8 @@ -- a name (@Def@) which is 'eligibleForProjectionLike': -- @data@ / @record@ / @postulate@. --+-- None of the parameters may be irrelevant (issue #8686).+-- -- 2. The application of f should only get stuck if the principal argument -- is inferable (neutral). Thus: --@@ -271,7 +275,7 @@ funSplitTree = st0, funCompiled = cc0, funInv = NotInjective, funMutual = Just [], -- Andreas, 2012-09-28: only consider non-mutual funs funOpaque = TransparentDef} | not (def ^. funAbstract) -> do- ps0 <- filterM validProj $ candidateArgs [] t+ ps0 <- candidateArgs [] t reportSLn "tc.proj.like" 30 $ if null ps0 then " no candidates found" else " candidates: " ++ prettyShow ps0 unless (null ps0) $ do@@ -356,20 +360,12 @@ isRecordExpression = \case Con _ ConORec _ -> True _ -> False- -- @validProj (d,n)@ checks whether the head @d@ of the type of the- -- @n@th argument is injective in all args (i.d. being name of data/record/axiom).- validProj :: (Arg QName, Int) -> TCM Bool- validProj (_, 0) = return False- validProj (d, _) = eligibleForProjectionLike (unArg d) - -- NOTE: If the following definition turns out to be slow, then- -- one could perhaps reuse information computed by the termination- -- and/or positivity checkers.- recursive = do- occs <- computeOccurrences x- case Map.lookup (ADef x) occs of- Just n | n >= 1 -> return True -- recursive occurrence- _ -> return False+ recursive = getMutual x >>= \case+ Just [] -> pure False+ Just (_:[]) -> pure True+ Just _ -> __IMPOSSIBLE__ -- makeProjection only gets called on singleton mutual blocks+ _ -> pure False checkOccurs cls n = all (nonOccur n) cls @@ -403,55 +399,85 @@ noMatch IApplyP{} = True -- Make sure non of the parameters occurs in the body of the function.- checkBody m n b = not . getAny $ runFree badVar IgnoreNot b- where badVar x = Any $ m - n <= x && x < m+ checkBody m n b = not $ anyFreeVar badVar b+ where badVar x = m - n <= x && x < m -- @candidateArgs [var 0,...,var(n-1)] t@ adds @(n,d)@ to the output,- -- if @t@ is a function-type with domain @t 0 .. (n-1)@+ -- if @t@ is a function-type with domain @d 0 .. (n-1)@ -- (the domain of @t@ is the type of the arg @n@).+ -- Andreas, 2026-08-06, issue #8686:+ -- The applications @d 0 .. (n-1)@ must be relevant. -- -- This means that from the type of arg @n@ all previous arguments- -- can be computed by a simple matching.- -- (Provided the @d@ is data/record/postulate, checked in @validProj@).+ -- can be computed by a simple matching,+ -- provided the @d@ is a data/record/postulate. -- -- E.g. f : {x : _}(y : _){z : _} -> D x y z -> ... -- will return (D,3) as a candidate (amongst maybe others). --- candidateArgs :: [Term] -> Type -> [(Arg QName, Int)]+ -- Precondition: t is in telescope normal form, i.e., all leading @Pi@s are exposed.+ candidateArgs :: [Term] -> Type -> TCM [(Arg QName, Int)] candidateArgs vs t = case unEl t of- Pi a b- | Def d es <- unEl $ unDom a,- Just us <- allApplyElims es,- vs == map unArg us -> (d <$ argFromDom a, length vs) : candidateRec b- | otherwise -> candidateRec b- _ -> []+ -- Andreas, 2026-08-26, issue #8686 (2)+ -- We need to reduce the domain @a@ here otherwise its form (e.g. @D x y z@)+ -- might not be preserved, violating the promise of projection-likeness that+ -- the "parameters" can be reconstructed from the type of the principal argument.+ -- However, full reduction is too expensive, busting test/Succeed/InstanceExpensiveContext.+ -- Since projection-likeness is just an optimization, and thus need not be complete,+ -- we have our choice of reduction, as long as we reduce enough to guarantee soundness+ -- of projection likeness.+ -- Luckily, reducing copy indirections from module applications should be sufficient,+ -- because this is the only way heads that are @eligibleForProjectionLike@ can reduce.+ -- Reducing copy indirections should be cheap.+ Pi a b -> if null vs then continue else reduceDefCopies (unEl (unDom a)) >>= \case+ Def d es -> ifNotM (eligibleForProjectionLike d) continue {-else-}+ if | Just us <- allApplyElims es+ , all (not . isIrrelevant) us+ , vs == map unArg us+ -> ((d <$ argFromDom a, length vs) :) <$> continue+ | otherwise -> continue+ _ -> continue+ where continue = candidateRec b+ _ -> return [] where- candidateRec NoAbs{} = []+ candidateRec NoAbs{} = return [] candidateRec (Abs x t) = candidateArgs (var (size vs) : vs) t {-# SPECIALIZE inferNeutral :: Term -> TCM Type #-} -- | Infer type of a neutral term. -- See also @infer@ in @Agda.TypeChecking.CheckInternal@, which has a very similar -- logic but also type checks all arguments.+--+-- Precondition: the term is not a projection-like function in prefix ('Def') form. inferNeutral :: (PureTCM m, MonadBlock m) => Term -> m Type inferNeutral u = do reportSDoc "tc.infer" 20 $ "inferNeutral" <+> prettyTCM u+ reportSDoc "tc.infer" 40 $ "inferNeutral (rawer)" <+> pretty u+ reportSDoc "tc.infer" 40 $ "in Context" <+> (prettyTCM =<< getContextTelescope) case u of Var i es -> do a <- typeOfBV i loop a (Var i) es Def f es -> do- whenJustM (isRelevantProjection f) $ \_ -> nonInferable+ -- f is not a lone projection-like function, see precondition.+ whenJustM (isRelevantProjection f) $ \_ -> impossible a <- defType <$> getConstInfo f loop a (Def f) es MetaV x es -> do -- we assume meta instantiations to be well-typed a <- metaType x loop a (MetaV x) es- _ -> nonInferable+ Con{} -> impossible+ Lit{} -> impossible+ Lam{} -> impossible+ Pi{} -> impossible+ Sort{} -> impossible+ Level{} -> impossible+ Dummy{} -> impossible+ DontCare{} -> impossible where- nonInferable :: MonadDebug m => m a- nonInferable = __IMPOSSIBLE_VERBOSE__ $ unlines+ impossible :: (HasCallStack, MonadDebug m) => m a+ impossible = __IMPOSSIBLE_VERBOSE__ $ unlines [ "inferNeutral: non-inferable term:" , " " ++ prettyShow u ]@@ -460,9 +486,11 @@ loop t hd (e:es) = do t' <- case e of Apply (Arg ai v) ->- ifPiType t (\_ b -> return $ b `absApp` v) __IMPOSSIBLE__+ ifPiTypeB t (\_ b -> return $ b `absApp` v)+ (patternViolation . getBlocker) -- Andreas, 2025-12-06, issue #8263 not __IMPOSSIBLE__ IApply x y r ->- ifPath t (\_ b -> return $ b `absApp` r) __IMPOSSIBLE__+ ifPathB t (\_ b -> return $ b `absApp` r)+ (patternViolation . getBlocker) -- Andreas, 2025-12-06, issue #8263 this might not be __IMPOSSIBLE__ either, play it safe! Proj o f -> do -- @projectTyped@ expects the type to be reduced. t <- reduce t@@ -488,7 +516,7 @@ -- Jesper, 2023-02-06: infer crashes on non-inferable terms, -- e.g. applications of projection-like functions. Hence we bring them -- into postfix form.- targ <- inferNeutral =<< elimView EvenLone (unArg arg)+ targ <- inferNeutral =<< elimView LoneProjectionLikeToLambda (unArg arg) reportSDoc "tc.infer" 30 $ "inferred type: " <+> prettyTCM targ -- getDefType wants the argument type reduced.
src/full/Agda/TypeChecking/Quote.hs view
@@ -5,9 +5,9 @@ import Control.Monad import Data.Maybe (fromMaybe)-import qualified Data.Text as T+import Data.Text qualified as T -import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Abstract qualified as A import Agda.Syntax.Common import Agda.Syntax.Internal as I import Agda.Syntax.Internal.Pattern ( hasDefP )@@ -23,12 +23,9 @@ import Agda.TypeChecking.Substitute import Agda.Utils.Impossible-import Agda.Utils.Functor import Agda.Utils.List-import Agda.Utils.List1 ( pattern (:|) )-import Agda.Utils.List2 ( pattern List2 ) import Agda.Utils.Size-import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.Maybe.Strict qualified as Strict -- | Parse @quote@. quotedName :: (MonadTCError m, MonadAbsToCon m) => A.Expr -> m QName@@ -42,9 +39,9 @@ A.ScopedExpr _ e -> quotedName e e -> typeError $ CannotQuote $ CannotQuoteExpression e where- unambiguous (AmbQ (x :| xs)) = case xs of- [] -> return x- y:ys -> typeError $ CannotQuote $ CannotQuoteAmbiguous $ List2 x y ys+ unambiguous ambX = case getUnambiguous ambX of+ Just x -> return x+ Nothing -> typeError $ CannotQuote $ CannotQuoteAmbiguous ambX data QuotingKit = QuotingKit@@ -226,8 +223,8 @@ quoteTelescope tel = quoteList quoteTelEntry $ telToList tel quoteTelEntry :: Dom (ArgName, Type) -> ReduceM Term- quoteTelEntry dom@Dom{ unDom = (x , t) } = do- SigmaKit{..} <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit+ quoteTelEntry dom@(unDom -> (x , t)) = do+ SigmaKit{ sigmaCon } <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit Con sigmaCon ConOSystem [] !@! quoteString x @@ quoteDom quoteType (fmap snd dom) list :: [ReduceM Term] -> ReduceM Term@@ -237,7 +234,7 @@ quoteList q xs = list (map q xs) quoteDom :: (a -> ReduceM Term) -> Dom a -> ReduceM Term- quoteDom q Dom{domInfo = info, unDom = t} = arg !@ quoteArgInfo info @@ q t+ quoteDom q d@(unDom -> t) = arg !@ quoteArgInfo (d ^. dInfo) @@ q t quoteAbs :: Subst a => (a -> ReduceM Term) -> Abs a -> ReduceM Term quoteAbs q (Abs s t) = abs !@! quoteString s @@ q t@@ -309,7 +306,7 @@ @@ quoteArgs vs where vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es DontCare u -> quoteTerm u- Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s+ Dummy s _ -> __IMPOSSIBLE_VERBOSE__ (show s) defParameters :: Definition -> Bool -> [ReduceM Term] defParameters def True = []
src/full/Agda/TypeChecking/ReconstructParameters.hs view
@@ -25,7 +25,6 @@ import Agda.Utils.Either import Agda.Utils.Function (applyWhen)-import Agda.Utils.Lens import Agda.Utils.Size import Agda.Utils.Impossible@@ -33,7 +32,7 @@ reconstructParametersInType :: Type -> TCM Type reconstructParametersInType = reconstructParametersInType' defaultAction -reconstructParametersInType' :: Action TCM -> Type -> TCM Type+reconstructParametersInType' :: Action -> Type -> TCM Type reconstructParametersInType' act a = traverse (reconstructParameters' act (sort $ getSort a)) a @@ -55,7 +54,7 @@ reconstructParameters :: Type -> Term -> TCM Term reconstructParameters = reconstructParameters' defaultAction -reconstructParameters' :: Action TCM -> Type -> Term -> TCM Term+reconstructParameters' :: Action -> Type -> Term -> TCM Term reconstructParameters' act a v = do reportSDoc "tc.reconstruct" 30 $ sep [ "reconstructing parameters in"@@ -66,10 +65,10 @@ nest 2 $ "-->" <+> prettyTCM v return v -reconstructAction :: Action TCM+reconstructAction :: Action reconstructAction = reconstructAction' defaultAction -reconstructAction' :: Action TCM -> Action TCM+reconstructAction' :: Action -> Action reconstructAction' act = act{ postAction = \ty tm -> postAction act ty tm >>= reconstruct ty } reconstruct :: Type -> Term -> TCM Term@@ -134,7 +133,15 @@ let fTm = f [] fe <- dropParameters fTm loop (absApp b fe) (Def p . (map Apply pars ++) . (Apply (defaultArg fTm) :)) es- loop ty _ (IApply {}:vs) = __IMPOSSIBLE__+ -- Issue #8853: path application.+ loop ty f (e@(IApply _ _ r) : es) = do+ reportSDoc "tc.reconstruct" 50 $ "The type before path app is:" <+> pretty ty+ reportSDoc "tc.reconstruct" 50 $ "The term before path app is:" <+> prettyTCM (f [])+ pathViewAsPi ty >>= \case+ Left (_, b) -> do+ r' <- dropParameters r+ loop (absApp b r') (f . (e :)) es+ Right _ -> __IMPOSSIBLE__ -- Extract the parameters from the type of a constructor -- application or the type of the principal argument of a
src/full/Agda/TypeChecking/RecordPatterns.hs view
@@ -9,7 +9,6 @@ , recordRHSToCopatterns ) where -import Control.Arrow ( first, second ) import Control.Monad.IO.Class ( MonadIO(..) ) import Control.Monad.Reader ( MonadReader(..), ReaderT(..), runReaderT ) import Control.Monad.State ( MonadState(..), StateT(..), runStateT )@@ -35,6 +34,7 @@ import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Warnings (warning) import Agda.Interaction.Options @@ -54,34 +54,49 @@ -- * Record pattern translation for let bindings --------------------------------------------------------------------------- --- | Take a record pattern @p@ and yield a list of projections+-- | Take a record pattern and yield a list of projections -- corresponding to the pattern variables, from left to right. -- -- E.g. for @(x , (y , z))@ we return @[ fst, fst . snd, snd . snd ]@. ----- If it is not a record pattern, error 'ShouldBeRecordPattern' is raised.+-- Precondition: it must be a record pattern.+-- If the record does not have eta, warning 'ShouldBeEtaRecordPattern' is raised. recordPatternToProjections :: DeBruijnPattern -> TCM [Term -> Term] recordPatternToProjections p = case p of VarP{} -> return [ id ]- LitP{} -> typeError $ ShouldBeRecordPattern p- DotP{} -> typeError $ ShouldBeRecordPattern p+ LitP{} -> impossible "LitP"++ DotP{} -> impossible "DotP"+ IApplyP{} -> impossible "IApplyP"+ DefP{} -> impossible "DefP"+ ProjP{} -> impossible "ProjP"+ ConP c ci ps -> do- unless (conPRecord ci) $- typeError $ ShouldBeRecordPattern p- let t = unArg $ fromMaybe __IMPOSSIBLE__ $ conPType ci+ -- Invariant: this function is only invoked on record patterns.+ -- We do not check it here, since it is checked below by inspecting the conPType.+ -- unless (conPRecord ci) $+ -- __IMPOSSIBLE__+ -- typeError ShouldBeRecordPattern+ t <- reduce $ unArg $ fromMaybe __IMPOSSIBLE__ $ conPType ci reportSDoc "tc.rec" 45 $ vcat [ "recordPatternToProjections: " , nest 2 $ "constructor pattern " <+> prettyTCM p <+> " has type " <+> prettyTCM t ] reportSLn "tc.rec" 70 $ " type raw: " ++ show t- fields <- getRecordTypeFields t- concat <$> zipWithM comb (map proj fields) (map namedArg ps)- ProjP{} -> __IMPOSSIBLE__ -- copattern cannot appear here- IApplyP{} -> typeError $ ShouldBeRecordPattern p- DefP{} -> typeError $ ShouldBeRecordPattern p+ case unEl t of+ Def r _ -> getConstInfo r <&> theDef >>= \case+ rt@Record { recFields = fields } -> do+ unless (YesEta == recEtaEquality rt) do+ warning ShouldBeEtaRecordPattern+ concat <$> zipWithM comb (map proj fields) (map namedArg ps)+ _ -> __IMPOSSIBLE_VERBOSE__ "recordPatternToProjections: ConP can only belong to a record type."+ _ -> __IMPOSSIBLE_VERBOSE__ "recordPatternToProjections: ConP can only belong to a record or data type." where proj p = (`applyE` [Proj ProjSystem $ unDom p])++ impossible pat = __IMPOSSIBLE_VERBOSE__ $ "recordPatternToProjections: " ++ pat ++ " is ruled out by checkValidLetPattern"+ comb :: (Term -> Term) -> DeBruijnPattern -> TCM [Term -> Term] comb prj p = map (\ f -> f . prj) <$> recordPatternToProjections p @@ -193,7 +208,7 @@ [(c, b)] | not comatch -> -- possible eta-match getConstructorInfo' c >>= \ case Just (RecordCon pm YesEta _ar fs) -> yesEtaCase b $- ConHead c (IsRecord pm) Inductive (map argFromDom fs)+ ConHead c (IsRecord pm) Inductive NotHIT (map argFromDom fs) _ -> noEtaCase _ -> noEtaCase return $ Case i cs{ conBranches = conMap@@ -238,11 +253,11 @@ recordRHSToCopatterns cl0 = do reportSLn "tc.inline.con" 40 $ "enter recordRHSToCopatterns" - etaExpandClause cl0 >>= \case+ (snd <$> etaExpandClause cl0) >>= \case -- RHS must be fully applied coinductive constructor/record expression. cl@Clause{ namedClausePats = ps- , clauseBody = Just v0@(Con con@(ConHead c _ _ind fs) _ci es)+ , clauseBody = Just v0@(Con con@(ConHead c _ _ind _hit fs) _ci es) , clauseType = mt } | not (null fs) -- at least one field@@ -310,7 +325,7 @@ recordExpressionsToCopatterns = \case Case i bs -> Case i <$> traverse recordExpressionsToCopatterns bs cc@Fail{} -> return cc- cc@(Done xs (Con c ConORec es)) -> do -- don't translate if using the record /constructor/+ cc@(Done no clrec xs (Con c ConORec es)) -> do -- don't translate if using the record /constructor/ let vs = map unArg $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es irrProj <- optIrrelevantProjections <$> pragmaOptions getConstructorInfo (conName c) >>= \ case@@ -324,7 +339,7 @@ traverse recordExpressionsToCopatterns $ Branches { projPatterns = True , conBranches = Map.fromListWith __IMPOSSIBLE__ $- zipWith (\ f v -> (unDom f, WithArity 0 $ Done xs v)) fs vs+ zipWith (\ f v -> (unDom f, WithArity 0 $ Done no clrec xs v)) fs vs , etaBranch = Nothing , litBranches = Map.empty , catchallBranch = Nothing
src/full/Agda/TypeChecking/Records.hs view
@@ -37,6 +37,7 @@ import {-# SOURCE #-} Agda.TypeChecking.Primitive.Cubical.Base (isCubicalSubtype) import {-# SOURCE #-} Agda.TypeChecking.ProjectionLike (eligibleForProjectionLike) +import Agda.Utils.CallStack ( HasCallStack ) import Agda.Utils.Empty import Agda.Utils.Function (applyWhen) import Agda.Utils.Functor (for, ($>), (<&>))@@ -56,7 +57,7 @@ -- * Tools to build record values mkCon :: ConHead -> ConInfo -> Args -> Term-mkCon h info args = Con h info (map Apply args)+mkCon h info args = Con h info $! map' Apply args -- | Order the fields of a record construction. orderFields@@ -69,16 +70,16 @@ orderFields r fill axs fs = do -- reportSDoc "tc.record" 30 $ vcat -- [ "orderFields"- -- , " official fields: " <+> sep (map pretty xs)- -- , " provided fields: " <+> sep (map pretty ys)+ -- , " official fields: " <+> sep (map' pretty xs)+ -- , " provided fields: " <+> sep (map' pretty ys) -- ] List1.unlessNull alien $ warn $ W.TooManyFields r missing List1.unlessNull duplicate $ warn $ W.DuplicateFields return $ for axs $ \ ax -> fromMaybe (fill ax) $ lookup (unArg ax) uniq where (uniq, duplicate) = nubAndDuplicatesOn fst fs -- separating duplicate fields- xs = map unArg axs -- official fields (accord. record type)- missing = filter (not . hasElem (map fst fs)) xs -- missing fields+ xs = map' unArg axs -- official fields (accord. record type)+ missing = filter (not . hasElem (map' fst fs)) xs -- missing fields alien = filter (not . hasElem xs . fst) fs -- spurious fields warn w = tell . singleton . w . fmap (second getRange) @@ -187,9 +188,8 @@ -- | Check if a name refers to a record. -- If yes, return record definition.-{-# SPECIALIZE isRecord :: QName -> TCM (Maybe RecordData) #-}-{-# SPECIALIZE isRecord :: QName -> ReduceM (Maybe RecordData) #-}-isRecord :: HasConstInfo m => QName -> m (Maybe RecordData)+{-# INLINE isRecord #-}+isRecord :: (HasCallStack, HasConstInfo m) => QName -> m (Maybe RecordData) isRecord r = do getConstInfo r <&> theDef <&> \case RecordDefn rd -> Just rd@@ -197,7 +197,7 @@ -- | Get the definition for a record. Throws an exception if the name -- does not refer to a record or the record is abstract.-getRecordDef :: (HasConstInfo m, ReadTCState m, MonadError TCErr m) => QName -> m RecordData+getRecordDef :: (HasCallStack, HasConstInfo m, ReadTCState m, MonadError TCErr m) => QName -> m RecordData getRecordDef r = fromMaybeM err $ isRecord r where err = typeError $ ShouldBeRecordType (El __DUMMY_SORT__ $ Def r []) @@ -208,13 +208,13 @@ return $ unArg r <$ proper -- if proper then Just (unArg r) else Nothing -- | Get the field names of a record.-getRecordFieldNames :: (HasConstInfo m, ReadTCState m, MonadError TCErr m)+getRecordFieldNames :: (HasCallStack, HasConstInfo m, ReadTCState m, MonadError TCErr m) => QName -> m [Dom C.Name] getRecordFieldNames r = recordFieldNames <$> getRecordDef r recordFieldNames :: RecordData -> [Dom C.Name]-recordFieldNames = map (fmap (nameConcrete . qnameName)) . _recFields+recordFieldNames = map' (fmap (nameConcrete . qnameName)) . _recFields -- | Find all records with at least the given fields. findPossibleRecords :: [C.Name] -> TCM [QName]@@ -230,13 +230,13 @@ -- in the fields of record @def@ (if it is a record). case theDef def of Record{ recFields = fs } -> Set.isSubsetOf given $- Set.fromList $ map (nameConcrete . qnameName . unDom) fs+ Set.fromList $ map' (nameConcrete . qnameName . unDom) fs _ -> False given = Set.fromList fields -- | Get the field names belonging to a record type.-getRecordTypeFields- :: Type -- ^ Record type. Need not be reduced.+getRecordTypeFields :: HasCallStack+ => Type -- ^ Record type. Need not be reduced. -> TCM [Dom QName] getRecordTypeFields t = do t <- reduce t -- Andreas, 2018-03-03, fix for #2989.@@ -250,31 +250,31 @@ -- | Returns the given record type's constructor name (with an empty -- range).-getRecordConstructor :: (HasConstInfo m, ReadTCState m, MonadError TCErr m) => QName -> m ConHead+getRecordConstructor :: (HasCallStack, HasConstInfo m, ReadTCState m, MonadError TCErr m) => QName -> m ConHead getRecordConstructor r = killRange . _recConHead <$> getRecordDef r -- | Reduce a type and check whether it is a record type. -- Succeeds only if type is not blocked by a meta var. -- If yes, return its name, parameters, and definition.-isRecordType :: PureTCM m => Type -> m (Maybe (QName, Args, RecordData))+isRecordType :: (HasCallStack, PureTCM m) => Type -> m (Maybe (QName, Args, RecordData)) isRecordType t = either (const Nothing) Just <$> tryRecordType t -- | Reduce a type and check whether it is a record type. -- Succeeds only if type is not blocked by a meta var. -- If yes, return its name, parameters, and definition. -- If no, return the reduced type (unless it is blocked).-tryRecordType :: PureTCM m => Type -> m (Either (Blocked Type) (QName, Args, RecordData))+tryRecordType :: (HasCallStack, PureTCM m) => Type -> m (Either (Blocked Type) (QName, Args, RecordData)) tryRecordType t = ifBlocked t (\ m a -> return $ Left $ Blocked m a) $ \ nb t -> do let no = return $ Left $ NotBlocked nb t case unEl t of Def r es -> do- let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ let vs = mustAllApplyElims es caseMaybeM (isRecord r) no $ \ def -> return $ Right (r,vs,def) _ -> no -- | Get the original projection info for name.-{-# SPECIALIZE origProjection :: QName -> TCM (QName, Definition, Maybe Projection) #-}-origProjection :: HasConstInfo m => QName -> m (QName, Definition, Maybe Projection)+{-# SPECIALIZE origProjection :: HasCallStack => QName -> TCM (QName, Definition, Maybe Projection) #-}+origProjection :: (HasCallStack, HasConstInfo m) => QName -> m (QName, Definition, Maybe Projection) origProjection f = do def <- getConstInfo f let proj = isProjection_ $ theDef def@@ -317,7 +317,8 @@ let npars | n == 0 = __IMPOSSIBLE__ | otherwise = n - 1 reportSLn "tc.deftype" 20 $ "projIndex = " ++ show n- -- we get the parameters from type @t@+ -- Andreas, 2026-09-05: note that @t@ is reduced by precondition,+ -- but its violation caused issue #8532. case unEl t of Def d es -> do -- Andreas, 2013-10-22@@ -327,10 +328,10 @@ -- we will produce garbage parameters. ifNotM (eligibleForProjectionLike d) failNotElig $ {- else -} do -- now we know it is reduced, we can safely take the parameters- let pars = fromMaybe __IMPOSSIBLE__ $ allApplyElims $ take npars es+ let pars = mustAllApplyElims $ take npars es reportSDoc "tc.deftype" 20 $ vcat [ text $ "head d = " ++ prettyShow d- , "parameters =" <+> sep (map prettyTCM pars)+ , "parameters =" <+> sep (map' prettyTCM pars) ] reportSDoc "tc.deftype" 60 $ "parameters = " <+> pretty pars if length pars < npars then failure "does not supply enough parameters"@@ -379,7 +380,7 @@ projectTyped :: PureTCM m => Term -- ^ Head (record value).- -> Type -- ^ Its type.+ -> Type -- ^ Its type (reduced!). -> ProjOrigin -> QName -- ^ Projection. -> m (Maybe (Dom Type, Term, Type))@@ -442,26 +443,26 @@ -- -- 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+{-# SPECIALIZE isEtaRecord :: HasCallStack => QName -> TCM Bool #-}+{-# SPECIALIZE isEtaRecord :: HasCallStack => QName -> ReduceM Bool #-}+isEtaRecord :: (HasCallStack, HasConstInfo m) => QName -> m Bool isEtaRecord r = do isRecord r >>= \case Just r | isEtaRecordDef r -> do constructorQ <- getQuantity <$> getConstInfo (conName (_recConHead r))- currentQ <- viewTC eQuantity+ currentQ <- viewTC eQuantityZeroHardCompile return $ constructorQ `moreQuantity` currentQ _ -> return False isEtaRecordDef :: RecordData -> Bool isEtaRecordDef r = _recEtaEquality r == YesEta -{-# SPECIALIZE isEtaCon :: QName -> TCM Bool #-}-isEtaCon :: HasConstInfo m => QName -> m Bool+{-# INLINE isEtaCon #-}+isEtaCon :: (HasCallStack, HasConstInfo m) => QName -> m Bool isEtaCon c = isJust <$> isEtaRecordConstructor c -- | Going under one of these does not count as a decrease in size for the termination checker.-isEtaOrCoinductiveRecordConstructor :: HasConstInfo m => QName -> m Bool+isEtaOrCoinductiveRecordConstructor :: (HasCallStack, HasConstInfo m) => QName -> m Bool isEtaOrCoinductiveRecordConstructor c = caseMaybeM (isRecordConstructor c) (return False) $ \ (_, def) -> pure (isEtaRecordDef def) `or2M`@@ -469,65 +470,52 @@ -- If in doubt about coinductivity, then yes. -- | Check if a name refers to a record which is not coinductive. (Projections are then size-preserving)-isInductiveRecord :: HasConstInfo m => QName -> m Bool+isInductiveRecord :: (HasCallStack, HasConstInfo m) => QName -> m Bool isInductiveRecord r = maybe False ((Just CoInductive /=) . _recInduction) <$> isRecord r -- | Check if a type is an eta expandable record and return the record identifier and the parameters.-isEtaRecordType :: (HasConstInfo m)+isEtaRecordType :: (HasCallStack, HasConstInfo m) => Type -> m (Maybe (QName, Args)) isEtaRecordType a = case unEl a of Def d es -> do- let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ let vs = mustAllApplyElims es ifM (isEtaRecord d) (return $ Just (d, vs)) (return Nothing) _ -> return Nothing -- | Check if a name refers to a record constructor. -- If yes, return record definition. ---isRecordConstructor :: HasConstInfo m => QName -> m (Maybe (QName, RecordData))+isRecordConstructor :: (HasCallStack, HasConstInfo m) => QName -> m (Maybe (QName, RecordData)) isRecordConstructor c = getConstInfo' c >>= \case- Left (SigUnknown err) -> __IMPOSSIBLE__+ Left (SigUnknown err) -> __IMPOSSIBLE_VERBOSE__ err Left SigCubicalNotErasure -> __IMPOSSIBLE__ Left SigAbstract -> return Nothing Right def -> case theDef $ def of Constructor{ conData = r } -> fmap (r,) <$> isRecord r _ -> return Nothing -isEtaRecordConstructor :: HasConstInfo m => QName -> m (Maybe (QName, RecordData))-isEtaRecordConstructor c = isRecordConstructor c >>= \case- Nothing -> return Nothing- Just (d, def) -> if isEtaRecordDef def then return $ Just (d, def) else return Nothing---- | Turn off eta for unguarded recursive records.--- Projections do not preserve guardedness.-unguardedRecord :: QName -> PatternOrCopattern -> TCM ()-unguardedRecord q pat = modifyRecEta q \ eta -> setEtaEquality eta $ NoEta pat+isEtaRecordConstructor :: (HasCallStack, HasConstInfo m) => QName -> m (Maybe (QName, RecordData))+isEtaRecordConstructor c = isRecordConstructor c <&> \case+ Nothing -> Nothing+ Just (d, def) -> if isEtaRecordDef def then Just (d, def) else Nothing --- | Turn on eta for non-recursive and inductive guarded recursive records,--- unless user declared otherwise.+-- | Eta should be off for unguarded recursive records. -- 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+-- Eta can be forced with the @ETA_EQUALITY@ pragma.+unguardedRecord :: QName -> TCM ()+unguardedRecord q = getConstInfo q <&> theDef >>= \case+ Record{ recEtaEquality' = EtaEquality eta etaProvenance } -> do+ when (eta == YesEta) do+ case etaProvenance of+ -- Default eta: user might not be aware of the danger, so give a hard error.+ EtaFromOption -> setCurrentRange q $ typeError $ UnguardedEtaRecord q+ -- Declared eta: user has some awareness, so just give a warning.+ EtaFromDirective -> setCurrentRange q $ warning $ UnguardedEtaRecordW q+ -- User has turned off the warning with the @ETA_EQUALITY@ pragma.+ EtaFromPragma -> return () _ -> __IMPOSSIBLE__ - when switchEta $ modifyRecEta q $ const $ Inferred YesEta---- | Turn on eta for inductive guarded recursive records.--- Projections do not preserve guardedness.-recursiveRecord :: QName -> TCM ()-recursiveRecord = updateEtaForRecord---- | Turn on eta for non-recursive record, unless user declared otherwise.-nonRecursiveRecord :: QName -> TCM ()-nonRecursiveRecord = updateEtaForRecord- -- | Check whether record type is marked as recursive. -- -- Precondition: record type identifier exists in signature.@@ -565,7 +553,7 @@ l = size gamma - 1 - i -- Extract type of @i@th de Bruijn index. -- Γ = Γ₁, x:a, Γ₂- let (gamma1, dom@(Dom{domInfo = ai, unDom = (x, a)}) : gamma2) = splitAt l gamma -- TODO:: Defined but not used dom, ai+ let (gamma1, dom@(unDom -> (x, a)) : gamma2) = splitAt' l gamma -- TODO:: Defined but not used dom -- This must be a eta-expandable record type. let failure = do reportSDoc "tc.meta.assign.proj" 25 $@@ -580,9 +568,9 @@ -- TODO: compose argInfo ai with tel. let tel = _recTel def `apply` pars m = size tel- fs = map argFromDom $ _recFields def+ fs = map' argFromDom $ _recFields def -- Construct the record pattern @Γ₁, Γ' ⊢ u := c ys@.- ys = zipWith (\ f i -> f $> var i) fs $ downFrom m+ ys = zipWith' (\ f i -> f $> var i) fs $ downFrom m u = mkCon (_recConHead def) ConOSystem ys -- @Γ₁, Γ' ⊢ τ₀ : Γ₁, x:_@ tau0 = consS u $ raiseS m@@ -593,7 +581,7 @@ zs = for fs $ fmap $ \ f -> Var 0 [Proj ProjSystem f] -- We need to reverse the field sequence to build the substitution. -- @Γ₁, x:_ ⊢ σ₀ : Γ₁, Γ'@- sigma0 = reverse (map unArg zs) ++# raiseS 1+ sigma0 = reverse (map'' unArg zs) ++# raiseS 1 -- @Γ₁, x:_, Γ₂ ⊢ σ₀ : Γ₁, Γ', Γ₂@ sigma = liftS (size gamma2) sigma0 @@ -637,7 +625,9 @@ TelV gamma core <- telViewUpTo n t case unEl core of -- There should be at least one domain left- Pi (dom@Dom{domInfo = ai, unDom = a}) b -> do+ Pi dom b -> do+ let ai = dom ^. dInfo+ a = unDom dom -- Eta-expand @dom@ along @qs@ into a telescope @tel@, computing a substitution. -- For now, we only eta-expand once. -- This might trigger another call to @etaExpandProjectedVar@ later.@@ -648,19 +638,19 @@ -- TODO: compose argInfo ai with tel. let tel = _recTel def `apply` pars m = size tel- fs = map argFromDom $ _recFields def+ fs = map' argFromDom $ _recFields def ys = zipWith (\ f i -> f $> var i) fs $ downFrom m u = mkCon (killRange $ _recConHead def) ConOSystem ys b' = raise m b `absApp` u t' = gamma `telePi` (tel `telePi` b')- gammai = map domInfo $ telToList gamma- xs = reverse $ zipWith (\ ai i -> Arg ai $ var i) gammai [m..]+ gammai = map' domInfo $ telToList gamma+ xs = reverse $ zipWith (\ ai i -> Arg ai $! var i) gammai [m..] curry v = teleLam gamma $ teleLam tel $- raise (n + m) v `apply` (xs ++ [Arg ai u])+ raise (n + m) v `apply` (xs ++! [Arg ai u]) zs = for fs $ fmap $ \ f -> Var 0 [Proj ProjSystem f] atel = sgTel $ (,) (absName b) <$> dom uncurry v = teleLam gamma $ teleLam atel $- raise (n + 1) v `apply` (xs ++ zs)+ raise (n + 1) v `apply` (xs ++! zs) return (curry, uncurry, t') _ -> __IMPOSSIBLE__ @@ -678,55 +668,59 @@ where @tel@ is the record telescope instantiated at the parameters @pars@. -}-etaExpandRecord :: (HasConstInfo m, MonadDebug m, ReadTCState m)+etaExpandRecord :: (HasConstInfo m) => QName -- ^ Name of record type. -> Args -- ^ Parameters applied to record type. -> Term -- ^ Term to eta-expand.- -> m (Telescope, Args)+ -> m (Maybe (Telescope, Args)) -- ^ Field types instantiated to parameters, field values.+ -- 'Nothing' if the term is a constructor of a different record type. etaExpandRecord = etaExpandRecord' False -- | Eta expand a record regardless of whether it's an eta-record or not.-forceEtaExpandRecord :: (HasConstInfo m, MonadDebug m, ReadTCState m, MonadError TCErr m)+forceEtaExpandRecord :: (HasConstInfo m) => QName -- ^ Name of record type. -> Args -- ^ Parameters applied to record type. -> Term -- ^ Term to eta-expand.- -> m (Telescope, Args)+ -> m (Maybe (Telescope, Args)) -- ^ Field types instantiated to parameters, field values.+ -- 'Nothing' if the term is a constructor of a different record type. forceEtaExpandRecord = etaExpandRecord' True --- | Eta-expand a value at the given record type (must match).-etaExpandRecord' :: (HasConstInfo m, MonadDebug m, ReadTCState m)+-- | Eta-expand a value at the given record type.+etaExpandRecord' :: (HasConstInfo m) => Bool -- ^ Force expansion, overriding '_recEtaEquality'? -> QName -- ^ Name of record type. -> Args -- ^ Parameters applied to record type. -> Term -- ^ Term to eta-expand.- -> m (Telescope, Args)+ -> m (Maybe (Telescope, Args)) -- ^ Field types instantiated to parameters, field values.+ -- 'Nothing' if the term is a constructor of a different record type. etaExpandRecord' forceEta r pars u = do def <- fromMaybe __IMPOSSIBLE__ <$> isRecord r- (tel, _, _, args) <- etaExpandRecord'_ forceEta r pars def u- return (tel, args)+ fmap (\(tel, _, _, args) -> (tel, args)) <$> etaExpandRecord'_ forceEta r pars def u --- | Eta-expand a value at the given eta record type (must match).+-- | Eta-expand a value at the given eta record type. etaExpandRecord_ :: HasConstInfo m => QName -- ^ Name of record type. -> Args -- ^ Parameters applied to record type. -> RecordData -- ^ Definition of record type. -> Term -- ^ Term to eta-expand.- -> m (Telescope, ConHead, ConInfo, Args)+ -> m (Maybe (Telescope, ConHead, ConInfo, Args)) -- ^ Field types instantiated to parameters, disassembled constructor term.+ -- 'Nothing' if the term is a constructor of a different record type. etaExpandRecord_ = etaExpandRecord'_ False --- | Eta-expand a value at the given record type (must match).+-- | Eta-expand a value at the given record type. etaExpandRecord'_ :: HasConstInfo m => Bool -- ^ Force expansion, overriding '_recEtaEquality'? -> QName -- ^ Name of record type. -> Args -- ^ Parameters applied to record type. -> RecordData -- ^ Definition of record type. -> Term -- ^ Term to eta-expand.- -> m (Telescope, ConHead, ConInfo, Args)+ -> m (Maybe (Telescope, ConHead, ConInfo, Args)) -- ^ Field types instantiated to parameters, disassembled constructor term.+ -- 'Nothing' if the term is a constructor of a different record type. etaExpandRecord'_ forceEta r pars def@RecordData{ _recConHead = con, _recFields = xs, _recTel = tel } u = do@@ -737,23 +731,31 @@ -- Already expanded. Con con_ ci es -> do- let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ let args = mustAllApplyElims es -- Andreas, 2019-10-21, issue #4148 -- @con == con_@ might fail, but their normal forms should be equal.- whenNothingM (conName con `sameDef` conName con_) $ do- reportSDoc "impossible" 10 $ vcat- [ "etaExpandRecord_: the following two constructors should be identical"- , nest 2 $ text $ "con = " ++ prettyShow con- , nest 2 $ text $ "con_ = " ++ prettyShow con_- ]- __IMPOSSIBLE__- return (tel', con, ci, args)+ mc <- conName con `sameDef` conName con_+ case mc of+ Nothing -> do+ -- Jesper, 2026-08-05, issue #8636: The term is a constructor of a+ -- different record type. This can legitimately happen e.g. when a meta+ -- of one singleton record type is (tentatively) solved with the constructor+ -- of another (definitionally equal under unsolvable constraints) one.+ -- Rather than crashing, we report this and let the caller decide how to+ -- proceed (e.g. by falling back to atomic comparison).+ reportSDoc "tc.record.eta" 20 $ vcat+ [ "etaExpandRecord_: the term's constructor does not match the record type"+ , nest 2 $ text $ "con = " ++ prettyShow con+ , nest 2 $ text $ "con_ = " ++ prettyShow con_+ ]+ return Nothing+ Just _ -> return $ Just (tel', con, ci, args) -- Not yet expanded. _ -> do -- Andreas, < 2016-01-18: Note: recFields are always the original projections, -- thus, we can use them in Proj directly.- let xs' = for (map argFromDom xs) $ fmap $ \ x -> u `applyE` [Proj ProjSystem x]+ let xs' = for (map' argFromDom xs) $ fmap $ \ x -> u `applyE` [Proj ProjSystem x] reportSDoc "tc.record.eta" 20 $ vcat [ "eta expanding" <+> prettyTCM u <+> ":" <+> prettyTCM r , nest 2 $ vcat@@ -761,13 +763,7 @@ , "args =" <+> prettyTCM xs' ] ]- return (tel', con, ConOSystem, xs')--etaExpandAtRecordType :: Type -> Term -> TCM (Telescope, Term)-etaExpandAtRecordType t u = do- (r, pars, def) <- fromMaybe __IMPOSSIBLE__ <$> isRecordType t- (tel, con, ci, args) <- etaExpandRecord_ r pars def u- return (tel, mkCon con ci args)+ return $ Just (tel', con, ConOSystem, xs') -- | The fields should be eta contracted already. --@@ -801,18 +797,24 @@ ] case compare (length args) (length xs) of LT -> fallBack -- Not fully applied- GT -> __IMPOSSIBLE__ -- Too many arguments. Impossible.+ -- Andreas, 2026-08-22, issue #7564:+ -- Too many arguments. This can only happen for ill-typed terms, which we+ -- may encounter while there are still unsolved (and unsolvable) constraints+ -- around, e.g. when a solution to a meta makes a definition non-confluent.+ -- Rather than crashing, we leave the term alone; the+ -- offending constraint will report a proper type error later.+ GT -> fallBack EQ -> do- case zipWithM check args xs of- Just as -> case catMaybes as of- (a:as) ->+ case zipWithM check args xs of -- András 2026-03-17: TODO optimize+ Just as -> case catMaybe' as of+ a:as -> if all (a ==) as then return a else fallBack _ -> fallBack -- just irrelevant terms _ -> fallBack -- a Nothing where- fallBack = return (mkCon c ci args)+ fallBack = return $! mkCon c ci args check :: Arg Term -> Dom QName -> Maybe (Maybe Term) check a ax = do -- @a@ is the constructor argument, @ax@ the corr. record field name@@ -823,8 +825,8 @@ -- then it passes the check (_, Just (_, [])) -> Nothing -- not a projection (_, Just (h, e0:es0))- | (es, Proj _o f) <- initLast1 e0 es0- , unDom ax == f -> Just $ Just $ h es+ | (es, Proj _o f) <- initLast1' e0 es0+ , unDom ax == f -> Just $! Just $! h es _ -> Nothing {-# SPECIALIZE isSingletonRecord :: QName -> Args -> TCM Bool #-}@@ -859,8 +861,8 @@ -> 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)+ [ "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,@@ -906,7 +908,7 @@ -- | 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 mempty+isSingletonTypeModuloRelevance t = isJust <$!> isSingletonType' True t mempty isSingletonType' :: forall m. (PureTCM m, MonadBlock m)@@ -940,16 +942,16 @@ -- If phi = i1, then inS (elt 1=1) is the only inhabitant. IOne -> do let- argH = Arg $ setHiding Hidden defaultArgInfo+ 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 ""+ _ -> mzero - (<|>) <$> record <*> subtype+ (<|>) <$!> record <*!> subtype {-# SPECIALIZE isEtaVar :: Term -> Type -> TCM (Maybe Int) #-} -- | Checks whether the given term (of the given type) is beta-eta-equivalent@@ -962,13 +964,13 @@ -- `Var i es`, and returns i if it is. If the argument mi is `Just i'`, -- then i and i' are also required to be equal (else Nothing is returned). isEtaVarG :: Term -> Type -> Maybe Int -> [Elim' Int] -> MaybeT m Int- isEtaVarG u a mi es = do+ isEtaVarG u a !mi es = do (u, a) <- reduce (u, a) reportSDoc "tc.lhs" 80 $ "isEtaVarG" <+> nest 2 (vcat [ "u = " <+> prettyTCM u , "a = " <+> prettyTCM a , "mi = " <+> text (show mi)- , "es = " <+> prettyList_ (map (prettyTCM . fmap var) es)+ , "es = " <+> prettyList_ (map' (prettyTCM . fmap var) es) ]) case (u, unEl a) of (Var i' es', _) -> do@@ -978,11 +980,11 @@ return i' (_, Def d pars) -> do guard =<< do isEtaRecord d- fs <- map unDom . recFields . theDef <$> getConstInfo d+ fs <- map'' unDom . recFields . theDef <$> getConstInfo d is <- forM fs $ \f -> do let o = ProjSystem (_, _, fa) <- MaybeT $ projectTyped u a o f- isEtaVarG (u `applyE` [Proj o f]) fa mi (es ++ [Proj o f])+ isEtaVarG (u `applyE` [Proj o f]) fa mi (es ++! [Proj o f]) case (mi, is) of (Just i, _) -> return i (Nothing, []) -> mzero@@ -990,9 +992,9 @@ (_, Pi dom cod) -> addContext dom $ do let u' = raise 1 u `apply` [argFromDom dom $> var 0] a' = absBody cod- mi' = fmap (+ 1) mi- es' = (fmap . fmap) (+ 1) es ++ [Apply $ argFromDom dom $> 0]- (-1 +) <$> isEtaVarG u' a' mi' es'+ mi' = (+ 1) <$!> mi+ es' = (map' . fmap) (+ 1) es ++! [Apply $! argFromDom dom $> 0]+ (-1 +) <$!> isEtaVarG u' a' mi' es' _ -> mzero -- `areEtaVarElims u a es es'` checks whether the given elims es (as applied@@ -1034,6 +1036,9 @@ ps <- normaliseProjP $ namedClausePats cl return $ cl { namedClausePats = ps } +instance NormaliseProjP a => NormaliseProjP (x, a) where+ normaliseProjP = traverse normaliseProjP+ instance NormaliseProjP a => NormaliseProjP [a] where normaliseProjP = traverse normaliseProjP @@ -1047,7 +1052,7 @@ normaliseProjP p@VarP{} = return p normaliseProjP p@DotP{} = return p normaliseProjP (ConP c cpi ps) = ConP c cpi <$> normaliseProjP ps- normaliseProjP (DefP o q ps) = DefP o q <$> normaliseProjP ps+ normaliseProjP (DefP o q ps) = DefP o q <$> normaliseProjP ps normaliseProjP p@LitP{} = return p normaliseProjP (ProjP o d0) = ProjP o <$> getOriginalProjection d0 normaliseProjP p@IApplyP{} = return p
src/full/Agda/TypeChecking/Records.hs-boot view
@@ -4,12 +4,16 @@ import Agda.Syntax.Internal import qualified Agda.Syntax.Concrete.Name as C-import Agda.TypeChecking.Monad+import Agda.TypeChecking.Monad ( RecordData, HasConstInfo, PureTCM ) +import Agda.Utils.CallStack ( HasCallStack )+import Agda.Syntax.Common+ etaContractRecord :: HasConstInfo m => QName -> ConHead -> ConInfo -> Args -> m Term -isRecord :: HasConstInfo m => QName -> m (Maybe RecordData)-isEtaRecord :: HasConstInfo m => QName -> m Bool-isRecordConstructor :: HasConstInfo m => QName -> m (Maybe (QName, RecordData))+isRecord :: (HasCallStack, HasConstInfo m) => QName -> m (Maybe RecordData)+isEtaRecord :: (HasCallStack, HasConstInfo m) => QName -> m Bool+isRecordConstructor :: (HasCallStack, HasConstInfo m) => QName -> m (Maybe (QName, RecordData)) recordFieldNames :: RecordData -> [Dom C.Name]+projectTyped :: PureTCM m => Term -> Type -> ProjOrigin -> QName -> m (Maybe (Dom Type, Term, Type))
src/full/Agda/TypeChecking/Reduce.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE NondecreasingIndentation #-}+-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-all -dno-suppress-type-signatures -ddump-to-file -dno-typeable-binds #-} module Agda.TypeChecking.Reduce -- Meta instantiation@@ -9,13 +10,13 @@ , IsMeta, isMeta -- Reduction and blocking , Reduce, reduce', reduceB', reduce, reduceB, reduceWithBlocker, reduceIApply'- , reduceDefCopy, reduceDefCopyTCM+ , reduceDefCopy, reduceDefCopyTCM, reduceDefCopies , reduceHead , slowReduceTerm , unfoldCorecursion, unfoldCorecursionE , unfoldDefinitionE, unfoldDefinitionStep , unfoldInlined- , appDef', appDefE'+ , appDefE_, appDefE0, appDef', appDefE' , abortIfBlocked, ifBlocked, isBlocked, fromBlocked, blockOnError -- Simplification , Simplify, simplify, simplifyBlocked'@@ -46,13 +47,14 @@ import Agda.Syntax.Literal import {-# SOURCE #-} Agda.TypeChecking.Irrelevance (isPropM)-import Agda.TypeChecking.Monad hiding ( enterClosure, constructorForm )+import Agda.TypeChecking.Free (Free)+import Agda.TypeChecking.Free.Base+import {-# SOURCE #-} Agda.TypeChecking.Free.Reduce (forceNonDepSort, IsFree (..))+import Agda.TypeChecking.Monad import Agda.TypeChecking.Substitute import Agda.TypeChecking.CompiledClause import Agda.TypeChecking.EtaContract -import Agda.TypeChecking.Reduce.Monad- import {-# SOURCE #-} Agda.TypeChecking.CompiledClause.Match import {-# SOURCE #-} Agda.TypeChecking.Patterns.Match import {-# SOURCE #-} Agda.TypeChecking.Pretty@@ -63,14 +65,18 @@ import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List-import Agda.Utils.List1 (List1)+import Agda.Utils.List1 (List1, pattern (:|)) import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Monad import Agda.Utils.Size import Agda.Utils.Tuple+import Agda.Utils.ExpandCase import qualified Agda.Utils.SmallSet as SmallSet+import Agda.Utils.ExpandCase import Agda.Utils.Impossible+import Agda.Utils.Unsafe (unsafeComparePointers)+import Agda.Utils.Applicative (forA) instantiate :: (Instantiate a, MonadReduce m) => a -> m a instantiate = liftReduce . instantiate'@@ -145,17 +151,21 @@ blocker NotBlocked{} = [] blocker (Blocked b _) = [b] -{-# SPECIALIZE blockOnError :: Blocker -> TCM a -> TCM a #-}+{-# NOINLINE blockOnError' #-}+blockOnError' :: Blocker -> TCErr -> TCM a+blockOnError' blocker = \case+ TypeError{} -> throwError $ PatternErr blocker+ PatternErr blocker' -> throwError $ PatternErr $ unblockOnEither blocker blocker'+ GenericException{} -> __IMPOSSIBLE__+ err@IOException{} -> throwError err+ ParserError{} -> __IMPOSSIBLE__++{-# INLINE blockOnError #-} -- | Run the given computation but turn any errors into blocked computations with the given blocker-blockOnError :: MonadError TCErr m => Blocker -> m a -> m a-blockOnError blocker f- | blocker == neverUnblock = f- | otherwise = f `catchError` \case- TypeError{} -> throwError $ PatternErr blocker- PatternErr blocker' -> throwError $ PatternErr $ unblockOnEither blocker blocker'- GenericException{} -> __IMPOSSIBLE__- err@IOException{} -> throwError err- ParserError{} -> __IMPOSSIBLE__+blockOnError :: Blocker -> TCM a -> TCM a+blockOnError !blocker !f = expand \ret ->+ if blocker == neverUnblock then ret f+ else ret $ f `catchError` blockOnError' blocker -- | Instantiate something. -- Results in an open meta variable or a non meta.@@ -224,29 +234,25 @@ PostponedTypeCheckingProblem _ -> return t Nothing -> __IMPOSSIBLE_VERBOSE__- ("Meta-variable not found: " ++ prettyShow x)+ ("Meta-variable not found: " ++! prettyShow x) where- cont i = instantiate' inst+ cont i = instantiate' $ go (raiseS arity) tel es 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+ !tel = instTel i+ !arity = length tel + go :: Substitution -> [Arg ArgName] -> Elims -> Term+ go !rho args es = case (args, es) of+ (arg:args, (mustApplyElim -> Arg _ e):es) -> go (consS e rho) args es+ (args, es) -> applySubst rho (foldr' mkLam (instBody i) args) `applyE` es+ instantiate' (Level l) = levelTm <$> instantiate' l- instantiate' (Sort s) = Sort <$> instantiate' s- instantiate' t = return t+ instantiate' (Sort s) = Sort <$> instantiate' s+ instantiate' t = return t instance Instantiate t => Instantiate (Type' t) where instantiate' (El s t) = El <$> instantiate' s <*> instantiate' t@@ -281,14 +287,17 @@ _ -> __IMPOSSIBLE__ s -> return s -instance (Instantiate t, Instantiate e) => Instantiate (Dom' t e) where- instantiate' (Dom i n b tac x) = Dom i n b <$> instantiate' tac <*> instantiate' x+instance Instantiate e => Instantiate (Dom e) where+ instantiate' (Dom i n b tac rew x) = Dom i n b <$> instantiate' tac <*> instantiate' rew <*> instantiate' x instance Instantiate a => Instantiate (Closure a) where instantiate' cl = do x <- enterClosure cl instantiate' return $ cl { clValue = x } +instance Instantiate ProblemConstraint where+ instantiate' (PConstr p u c) = PConstr p u <$> instantiate' c+ instance Instantiate Constraint where instantiate' (ValueCmp cmp t u v) = do (t,u,v) <- instantiate' (t,u,v)@@ -302,7 +311,7 @@ instantiate' (SortCmp cmp a b) = uncurry (SortCmp cmp) <$> instantiate' (a,b) instantiate' (UnBlock m) = return $ UnBlock m instantiate' (FindInstance r m cs) = FindInstance r m <$> mapM instantiate' cs- instantiate' (ResolveInstanceHead q) = return $ ResolveInstanceHead q+ instantiate' (ResolveInstanceHead kwr q) = return $ ResolveInstanceHead kwr q instantiate' (IsEmpty r t) = IsEmpty r <$> instantiate' t instantiate' (CheckSizeLtSat t) = CheckSizeLtSat <$> instantiate' t instantiate' c@CheckFunDef{} = return c@@ -315,6 +324,7 @@ instantiate' c@CheckMetaInst{} = return c instantiate' (CheckType t) = CheckType <$> instantiate' t instantiate' (UsableAtModality cc ms mod t) = flip (UsableAtModality cc) mod <$> instantiate' ms <*> instantiate' t+ instantiate' (RewConstraint e) = RewConstraint <$> instantiate' e instance Instantiate CompareAs where instantiate' (AsTermsOf a) = AsTermsOf <$> instantiate' a@@ -337,6 +347,29 @@ <*> instantiate' a <*> instantiate' b +instance Instantiate LocalEquation where+ instantiate' (LocalEquation a b c d) =+ LocalEquation+ <$> instantiate' a+ <*> instantiate' b+ <*> instantiate' c+ <*> instantiate' d++instance Instantiate RewriteRule where+ instantiate' (RewriteRule a b c d e) =+ RewriteRule+ <$> instantiate' a+ <*> pure b+ <*> pure c+ <*> instantiate' d+ <*> instantiate' e++instance Instantiate RewDom where+ instantiate' (RewDom a b) =+ RewDom+ <$> instantiate' a+ <*> instantiate' b+ --------------------------------------------------------------------------- -- * Reduction to weak head normal form. ---------------------------------------------------------------------------@@ -351,7 +384,7 @@ isMeta (MetaV m _) = Just m isMeta _ = Nothing -instance IsMeta a => IsMeta (Sort' a) where+instance IsMeta (Sort' a) where isMeta (MetaS m _) = Just m isMeta _ = Nothing @@ -379,6 +412,7 @@ isMeta AsSizes = Nothing isMeta AsTypes = Nothing +{-# INLINE ifBlocked #-} -- | Case on whether a term is blocked on a meta (or is a meta). -- That means it can change its shape when the meta is instantiated. ifBlocked@@ -427,23 +461,49 @@ let done | MetaS x _ <- s = return $ blocked x s | otherwise = return $ notBlocked s case s of- 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+ PiSort c a s1 s2Abs -> reduceB' (c, s1 , s2Abs) >>= \case+ -- If either the domain or codomain sort is blocked, there is no point+ -- in doing the free variable check since even if we manage to reduce+ -- to a FunSort, it would still be blocked. And normalizing anyway in+ -- this case leads to exponential behavior (see #8423).+ Blocked b (c, s1 , s2Abs) -> return $!+ blockedOn b $ PiSort c a s1 s2Abs+ NotBlocked _ (c, s1 , s2Abs) -> do+ let dom = El s1 <$> a+ -- In theory we should just call piSortB' here. However, we also+ -- want to reduce the codomain sort to make it non-dependent when+ -- possible. So we use forceNonDep and in case we are dealing with a+ -- proper Abs we call piSortB'' directly+ codomainSortOldM dom (unAbs s2Abs) c forceNonDepSort >>= \case+ -- If the codomain sort is non-dependent, we reduce to a FunSort+ (NotFree, s2Old) -> do+ -- We need to obtain a strengthened version of the codomain sort+ s2 <- case c of+ CodomainSortSame -> pure s2Old+ CodomainSortOld{} ->+ addContext dom (forceNonDepSort $! unAbs s2Abs) >>= \case+ (NotFree, s2) -> pure s2+ -- If 's2Old' is non dependent, then 's2' must also be+ -- non-dependent+ (MaybeFree _, _) -> __IMPOSSIBLE__+ let s2' = strengthen __IMPOSSIBLE__ s2+ reduceB' $ FunSort s1 s2'+ -- For a (possibly) properly dependent PiSort, we call piSortB''.+ (MaybeFree flexRig, _) -> do+ let blockOcc = flexRigToBlocker flexRig+ case piSortB'' a s1 s2Abs flexRig CodomainNormalised of+ -- We already know the sorts themselves are not blocked,+ -- so the only possible blocker comes from the free variable check+ Left _ -> return $! blockedOn blockOcc $+ PiSort c a s1 s2Abs+ -- The only sort that piSortB'' can reduce is Inf,+ -- so there is no need to try reducing it further.+ Right s -> return $! notBlocked s FunSort s1 s2 -> reduceB' (s1 , s2) >>= \case Blocked b (s1',s2') -> return $ Blocked b $ FunSort s1' s2'- NotBlocked _ (s1',s2') -> do- case funSort' s1' s2' of- Left b -> return $ Blocked b $ FunSort s1' s2'- Right s -> reduceB' s+ NotBlocked _ (s1',s2') -> funSortM' s1' s2' >>= \case+ 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@@ -453,16 +513,17 @@ Inf _ _ -> done SizeUniv -> done LockUniv -> done- LevelUniv -> do- levelUniverseEnabled <- isLevelUniverseEnabled- if levelUniverseEnabled- then done- else return $ notBlocked (mkType 0)+ LevelUniv -> ifM isLevelUniverseEnabled done $+ return $ notBlocked (mkType 0) IntervalUniv -> done MetaS x es -> done DefS d es -> done -- postulated sorts do not reduce DummyS{} -> done +instance (Reduce a, Free a) => Reduce (BlockedDepCheck a) where+ reduce' c = forA c \s -> inLargeEnoughContext s $ reduce' s+ reduceB' c = sequenceA <$> forA c \s -> inLargeEnoughContext s $ reduceB' s+ instance Reduce Elim where reduce' (Apply v) = Apply <$> reduce' v reduce' (Proj o f)= pure $ Proj o f@@ -518,12 +579,14 @@ xyz = (ignoreBlocking x , ignoreBlocking y , ignoreBlocking z) return $ blk $> xyz +{-# INLINE reduceIApply #-} reduceIApply :: ReduceM (Blocked Term) -> [Elim] -> ReduceM (Blocked Term) reduceIApply = reduceIApply' reduceB' +{-# INLINE reduceIApply' #-} reduceIApply' :: (Term -> ReduceM (Blocked Term)) -> ReduceM (Blocked Term) -> [Elim] -> ReduceM (Blocked Term) reduceIApply' red d (IApply x y r : es) = do- view <- intervalView'+ view <- intervalView' -- András: TODO opt r <- reduceB' r -- We need to propagate the blocking information so that e.g. -- we postpone "someNeutralPath ?0 = a" rather than fail.@@ -546,31 +609,38 @@ maybeFastReduceTerm :: Term -> ReduceM (Blocked Term) maybeFastReduceTerm v = do- let tryFast = case v of- Def{} -> True- Con{} -> True- MetaV{} -> True- _ -> False- if not tryFast then slowReduceTerm v- else- case v of- MetaV x _ -> ifM (isOpen x) (return $ blocked x v) (maybeFast v)- _ -> maybeFast v- where- isOpen x = isOpenMeta <$> lookupMetaInstantiation x- maybeFast v = ifM shouldTryFastReduce (fastReduce v) (slowReduceTerm v)+ let maybeFast v = ifM shouldTryFastReduce (fastReduce v) (slowReduceTerm v)+ case v of+ v@Def{} -> maybeFast v+ v@Con{} -> maybeFast v+ v@(MetaV x _) -> ifM (isOpenMeta <$> lookupMetaInstantiation x)+ (return $! blocked x v)+ (maybeFast v)+ v -> slowReduceTerm v + -- let tryFast = case v of+ -- Def{} -> True+ -- Con{} -> True+ -- MetaV{} -> True+ -- _ -> False+ -- if not tryFast then slowReduceTerm v+ -- else+ -- case v of+ -- MetaV x _ -> ifM (isOpen x) (return $ blocked x v) (maybeFast v)+ -- _ -> maybeFast v+ -- where+ -- isOpen x = isOpenMeta <$> lookupMetaInstantiation x+ -- maybeFast v = ifM shouldTryFastReduce (fastReduce v) (slowReduceTerm v)+ slowReduceTerm :: Term -> ReduceM (Blocked Term) slowReduceTerm v = do v <- instantiate' v- let done | MetaV x _ <- v = return $ blocked x v- | otherwise = return $ notBlocked v- iapp = reduceIApply done+ let done = return $ notBlocked v case v of -- Andreas, 2012-11-05 not reducing meta args does not destroy anything -- and seems to save 2% sec on the standard library -- MetaV x args -> notBlocked . MetaV x <$> reduce' args- MetaV x es -> iapp es+ MetaV x es -> reduceIApply (return $! blocked x v) es Def f es -> flip reduceIApply es $ unfoldDefinitionE reduceB' (Def f []) f es Con c ci es -> do -- Constructors can reduce' when they come from an@@ -580,13 +650,15 @@ $ unfoldDefinitionE reduceB' (Con c ci []) (conName c) es traverse reduceNat v Sort s -> done- Level l -> ifM (SmallSet.member LevelReductions <$> asksTC envAllowedReductions)+ Level l -> ifM (SmallSet.member LevelReductions <$> viewTC eAllowedReductions) {- then -} (fmap levelTm <$> reduceB' l) {- else -} done- Pi _ _ -> done- Lit _ -> done- Var _ es -> iapp es- Lam _ _ -> done+ Pi _ _ -> done+ Lit _ -> done+ Var x es -> localRewritingOption >>= \case+ True -> reduceIApply (rewriteVarApp x es) es+ False -> reduceIApply done es+ Lam _ _ -> done DontCare _ -> done Dummy{} -> done where@@ -599,15 +671,31 @@ reduceNat v@(Con c ci [Apply a]) | visible a && isRelevant a = do ms <- getBuiltin' builtinSuc case v of- _ | Just (Con c ci []) == ms -> inc <$> reduce' (unArg a)- _ -> return v+ _ | Just (Con c ci []) == ms -> inc <$!> reduce' (unArg a)+ _ -> return v where inc = \case Lit (LitNat n) -> Lit $ LitNat $ n + 1- w -> Con c ci [Apply $ defaultArg w]+ w -> let !arg = Apply $! defaultArg w in Con c ci [arg] reduceNat v = return v --- Andreas, 2013-03-20 recursive invokations of unfoldCorecursion+rewriteVarApp :: Nat -> Elims -> ReduceM (Blocked Term)+rewriteVarApp x es = do+ r <- rewriteVarAppStep x es+ case r of+ NoReduction v -> return v+ YesReduction _ v -> reduceB' v++rewriteVarAppStep :: Nat -> Elims -> ReduceM (Reduced (Blocked Term) Term)+rewriteVarAppStep x es = do+ rewr <- getAllRewriteRulesForVarHead x+ when (not $ null rewr) $+ reportSDoc "rewriting" 30 $+ "Trying to rewrite variable application" <+> prettyTCM (Var x es)+ rewrite (NotBlocked ReallyNotBlocked ())+ (Var x) rewr es++-- Andreas, 2013-03-20 recursive invocations of unfoldCorecursion -- need also to instantiate metas, see Issue 826. unfoldCorecursionE :: Elim -> ReduceM (Blocked Elim) unfoldCorecursionE (Proj o p) = notBlocked . Proj o <$> getOriginalProjection p@@ -632,6 +720,7 @@ unfoldDefinition keepGoing v f args = unfoldDefinitionE keepGoing v f (map Apply args) +{-# INLINE unfoldDefinitionE #-} unfoldDefinitionE :: (Term -> ReduceM (Blocked Term)) -> Term -> QName -> Elims -> ReduceM (Blocked Term)@@ -654,25 +743,27 @@ unfoldDefinitionStep v0 f es = {-# SCC "reduceDef" #-} do traceSDoc "tc.reduce" 90 ("unfoldDefinitionStep v0" <+> pretty v0) $ do- info <- getConstInfo f- rewr <- instantiateRewriteRules =<< getRewriteRulesFor f- allowed <- asksTC envAllowedReductions- prp <- runBlocked $ isPropM $ defType info- defOk <- shouldReduceDef f+ info <- getConstInfo f+ rewr <- getAllRewriteRulesForDefHead f+ allowed <- viewTC eAllowedReductions+ prp <- runBlocked $ isPropM $ defType info+ defOk <- shouldReduceDef f let def = theDef info v = v0 `applyE` es -- Non-terminating functions -- (i.e., those that failed the termination check) -- and delayed definitions -- are not unfolded unless explicitly permitted.- dontUnfold = or- [ defNonterminating info && SmallSet.notMember NonTerminatingReductions allowed- , defTerminationUnconfirmed info && SmallSet.notMember UnconfirmedReductions allowed- , prp == Right True- , isIrrelevant info- , not defOk- ]- copatterns = defCopatternLHS info++ dontUnfold =+ (defNonterminating info && SmallSet.notMember NonTerminatingReductions allowed)+ -- defTerminationUnconfirmed info && SmallSet.notMember UnconfirmedReductions allowed+ || (prp == Right True)+ || (isIrrelevant info)+ || (not defOk)++ copatterns <- defCopatternLHS f info+ case def of Constructor{conSrcCon = c} -> do let hd = Con (c `withRangeOf` f) ConOSystem@@ -686,21 +777,19 @@ PrimitiveSort{ primSortSort = s } -> yesReduction NoSimplification $ Sort s `applyE` es _ -> do- if or- [ RecursiveReductions `SmallSet.member` allowed- , isJust (isProjection_ def) && ProjectionReductions `SmallSet.member` allowed+ if+ (RecursiveReductions `SmallSet.member` allowed)+ || (isJust (isProjection_ def) && ProjectionReductions `SmallSet.member` allowed) -- Includes projection-like and irrelevant projections. -- Note: irrelevant projections lead to @dontUnfold@ and -- so are not actually unfolded.- , isInlineFun def && InlineReductions `SmallSet.member` allowed- , definitelyNonRecursive_ def && or- [ copatterns && CopatternReductions `SmallSet.member` allowed- , FunctionReductions `SmallSet.member` allowed- ]- ]+ || (isInlineFun def && InlineReductions `SmallSet.member` allowed)+ || (definitelyNonRecursive_ def && or+ [ copatterns && CopatternReductions `SmallSet.member` allowed+ , FunctionReductions `SmallSet.member` allowed+ ]) then- reduceNormalE v0 f (map notReduced es) dontUnfold- (defClauses info) (defCompiled info) rewr+ reduceNormalE v0 f (map' notReduced es) dontUnfold (defCopyOrClauses info) rewr else noReduction $ notBlocked v -- Andrea(s), 2014-12-05 OK? where@@ -710,49 +799,61 @@ | length es < ar = noReduction $ NotBlocked Underapplied $ v0 `applyE` es -- not fully applied | otherwise = {-# SCC "reducePrimitive" #-} do- let (es1,es2) = splitAt ar es+ let (es1,es2) = splitAt' ar es args1 = fromMaybe __IMPOSSIBLE__ $ mapM isApplyElim es1 r <- primFunImplementation pf args1 (length es2) case r of NoReduction args1' -> do- let es1' = map (fmap Apply) args1'+ let es1' = map' (fmap Apply) args1' if null cls && null rewr then do noReduction $ applyE (Def f []) <$> do- blockAll $ map mredToBlocked es1' ++ map notBlocked es2+ blockAll $ map' mredToBlocked es1' ++! map' notBlocked es2 else- reduceNormalE v0 f (es1' ++ map notReduced es2) dontUnfold cls mcc rewr+ -- Note: a primitive is never a data/record type copy.+ reduceNormalE v0 f (es1' ++! map' notReduced es2) dontUnfold (Right (cls, mcc)) rewr YesReduction simpl v -> yesReduction simpl $ v `applyE` es2 where ar = primFunArity pf - mredToBlocked :: IsMeta t => MaybeReduced t -> Blocked t+ mredToBlocked :: MaybeReduced t -> Blocked t mredToBlocked (MaybeRed NotReduced e) = notBlocked e mredToBlocked (MaybeRed (Reduced b) e) = e <$ b - reduceNormalE :: Term -> QName -> [MaybeReduced Elim] -> Bool -> [Clause] -> Maybe CompiledClauses -> RewriteRules -> ReduceM (Reduced (Blocked Term) Term)- reduceNormalE v0 f es dontUnfold def mcc rewr = {-# SCC "reduceNormal" #-} do+ reduceNormalE ::+ Term -> QName -> [MaybeReduced Elim] -> Bool+ -> Either Term ([Clause], Maybe CompiledClauses) -> RewriteRules+ -> ReduceM (Reduced (Blocked Term) Term)+ reduceNormalE v0 f es dontUnfold def rewr = {-# SCC "reduceNormal" #-} do traceSDoc "tc.reduce" 90 ("reduceNormalE v0 =" <+> pretty v0) $ do- case (def,rewr) of- _ | dontUnfold -> traceSLn "tc.reduce" 90 "reduceNormalE: don't unfold (non-terminating or delayed)" $- defaultResult -- non-terminating or delayed- ([],[]) -> traceSLn "tc.reduce" 90 "reduceNormalE: no clauses or rewrite rules" $ do- -- no definition for head- (defBlocked <$> getConstInfo f) >>= \case- Blocked{} -> noReduction $ Blocked (UnblockOnDef f) vfull- NotBlocked{} -> defaultResult- (cls,rewr) -> do- ev <- appDefE_ f v0 cls mcc rewr es- debugReduce ev- return ev+ if dontUnfold then+ traceSLn "tc.reduce" 90 "reduceNormalE: don't unfold (non-terminating or delayed)" $+ defaultResult -- non-terminating or delayed+ else case def of+ -- Andreas, 2026-09-23, issue #8545:+ -- A data or record type copy is defined by a term rather than by clauses.+ -- Applying a term never gets stuck, so unlike clause matching this also+ -- unfolds underapplied occurrences of the copy.+ Left w -> traceSLn "tc.reduce" 90 "reduceNormalE: unfolding copy" $+ return $ YesReduction NoSimplification $ w `applyE` map' ignoreReduced es+ Right (cls, mcc) -> case (cls, rewr) of+ ([], []) -> traceSLn "tc.reduce" 90 "reduceNormalE: no clauses or rewrite rules" $ do+ -- no definition for head+ (defBlocked <$> getConstInfo f) >>= \case+ Blocked{} -> noReduction $ Blocked (UnblockOnDef f) vfull+ NotBlocked{} -> defaultResult+ _ -> do+ ev <- appDefE_ f v0 cls mcc rewr es+ debugReduce ev+ return ev where defaultResult = noReduction $ NotBlocked ReallyNotBlocked vfull- vfull = v0 `applyE` map ignoreReduced es+ vfull = v0 `applyE` map' ignoreReduced es debugReduce ev = verboseS "tc.reduce" 90 $ do case ev of NoReduction v -> do reportSDoc "tc.reduce" 90 $ vcat [ "*** tried to reduce " <+> pretty f- , " es = " <+> sep (map (pretty . ignoreReduced) es)+ , " es = " <+> sep (map' (pretty . ignoreReduced) es) -- , "*** tried to reduce " <+> pretty vfull , " stuck on" <+> pretty (ignoreBlocking v) ]@@ -774,6 +875,12 @@ _ -> reduceDef_ info f es where reduceDef_ :: Definition -> QName -> Elims -> m (Reduced () Term)+ -- A data or record type copy is defined by a term, which applies to any+ -- number of arguments, so there is nothing to eta-expand here (issue #8545).+ reduceDef_ info f es | Just w <- defCopyClause info =+ if defNonterminating info+ then return $ NoReduction ()+ else return $ YesReduction NoSimplification $ w `applyE` es reduceDef_ info f es = case defClauses info of [cl] -> do -- proper copies always have a single clause let v0 = Def f [] -- TODO: could be Con@@ -791,17 +898,29 @@ etaArgs (_ : ps) (_ : es) = etaArgs ps es xs = etaArgs ps es n = length xs- newes = raise n es ++ [ Apply $ var i <$ x | (i, x) <- zip (downFrom n) xs ]+ newes = raise n es ++! [ Apply $ var i <$ x | (i, x) <- zip (downFrom n) xs ] if defNonterminating info then return $ NoReduction () else do- ev <- liftReduce $ appDefE_ f v0 [cl] Nothing mempty $ map notReduced es'+ ev <- liftReduce $ appDefE_ f v0 [cl] Nothing mempty $ map' notReduced es' case ev of YesReduction simpl t -> return $ YesReduction simpl (lam t) NoReduction{} -> return $ NoReduction () [] -> return $ NoReduction () -- copies of generalizable variables have no clauses (and don't need unfolding) _:_:_ -> __IMPOSSIBLE__ +-- | Recursively apply 'reduceDefCopy' so remove all copy-indirections+-- but otherwise do not reduce the term.+reduceDefCopies :: Term -> TCM Term+reduceDefCopies v = do+ r <- case v of+ Def f es -> reduceDefCopy f es+ Con c _info es -> reduceDefCopy (conName c) es+ _ -> pure $ NoReduction __IMPOSSIBLE__+ case r of+ NoReduction{} -> return v+ YesReduction _ v' -> reduceDefCopies v'+ -- | Reduce simple (single clause) definitions. reduceHead :: PureTCM m => Term -> m (Blocked Term) reduceHead v = do -- ignoreAbstractMode $ do@@ -813,12 +932,11 @@ traceSDoc "tc.inj.reduce" 30 (ignoreAbstractMode $ "reduceHead" <+> prettyTCM v) $ do case v of Def f es -> do-- abstractMode <- envAbstractMode <$> askTC+ abstractMode <- viewTC eAbstractMode isAbstract <- not <$> hasAccessibleDef f traceSLn "tc.inj.reduce" 50 (- "reduceHead: we are in " ++ show abstractMode ++ "; " ++ prettyShow f ++- " is treated " ++ if isAbstract then "abstractly" else "concretely"+ "reduceHead: we are in " ++! show abstractMode ++! "; " ++! prettyShow f ++!+ " is treated " ++! if isAbstract then "abstractly" else "concretely" ) $ do let v0 = Def f [] red = liftReduce $ unfoldDefinitionE reduceHead v0 f es@@ -830,11 +948,11 @@ -- type checker loop here on non-terminating functions. -- see test/fail/TerminationInfiniteRecord Function{ funClauses = [ _ ], funTerminates = Just True } -> do- traceSLn "tc.inj.reduce" 50 ("reduceHead: head " ++ prettyShow f ++ " is Function") $ do+ traceSLn "tc.inj.reduce" 50 ("reduceHead: head " ++! prettyShow f ++! " is Function") $ do red Datatype{ dataClause = Just _ } -> red Record{ recClause = Just _ } -> red- _ -> return $ notBlocked v+ _ -> return $ notBlocked v _ -> return $ notBlocked v -- | Unfold as many copies as possible, and then potentially a single@@ -858,17 +976,17 @@ Function{} -> reportSLn "tc.inline" 90 $ intercalate "\n"- [ "considering to inline " ++ prettyShow f- , "irr = " ++ prettyShow irr- , "funInline = " ++ prettyShow (def ^. funInline)- , "funCompiled = " ++ prettyShow (funCompiled def)+ [ "considering to inline " ++! prettyShow f+ , "irr = " ++! prettyShow irr+ , "funInline = " ++! prettyShow (def ^. funInline)+ , "funCompiled = " ++! prettyShow (funCompiled def) ] _ -> pure () case def of -- Only for simple definitions with no pattern matching (TODO: maybe copatterns?) Function{ funCompiled = Just Done{} } | (defCopy info || def ^. funInline), not irr -> do- reportSLn "tc.inline" 70 $ "asking to inline " ++ prettyShow f+ reportSLn "tc.inline" 70 $ "asking to inline " ++! prettyShow f liftReduce $ ignoreBlocking <$> unfoldDefinitionE continue (Def f []) f es _ -> return v@@ -876,22 +994,37 @@ -- | Apply a definition using the compiled clauses, or fall back to -- ordinary clauses if no compiled clauses exist.-appDef_ :: QName -> Term -> [Clause] -> Maybe CompiledClauses -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)-appDef_ f v0 cls mcc rewr args = appDefE_ f v0 cls mcc rewr $ map (fmap Apply) args+appDef_ :: QName -> Term -> [Clause] -> Maybe CompiledClauses+ -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)+appDef_ f v0 cls mcc rewr args = appDefE_ f v0 cls mcc rewr $ map' (fmap Apply) args -appDefE_ :: QName -> Term -> [Clause] -> Maybe CompiledClauses -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)+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 }) $+ localTC (set eAppDef (Just f)) $ maybe (appDefE'' v0 cls rewr args) (\cc -> appDefE v0 cc rewr args) mcc +-- | Like 'appDefE_', but takes the whole 'Definition' and thus also handles+-- data and record type copies, which are defined by a term rather than by+-- clauses (see 'defCopyClause'). Applying that term never gets stuck, so this+-- also unfolds underapplied occurrences of the copy (issue #8545).+appDefE0 ::+ QName -> Definition -> Term -> RewriteRules+ -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)+appDefE0 f def v0 rewr args = case defCopyOrClauses def of+ Left w -> return $ YesReduction NoSimplification $ w `applyE` map' ignoreReduced args+ Right (cls, mcc) -> appDefE_ f v0 cls mcc rewr args -- | Apply a defined function to it's arguments, using the compiled clauses. -- The original term is the first argument applied to the third. appDef :: Term -> CompiledClauses -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)-appDef v cc rewr args = appDefE v cc rewr $ map (fmap Apply) args+appDef v cc rewr args = appDefE v cc rewr $ map' (fmap Apply) args -appDefE :: Term -> CompiledClauses -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)+appDefE ::+ Term -> CompiledClauses -> RewriteRules -> MaybeReducedElims+ -> ReduceM (Reduced (Blocked Term) Term) appDefE v cc rewr es = do traceSDoc "tc.reduce" 90 ("appDefE v = " <+> pretty v) $ do r <- matchCompiledE cc es@@ -901,20 +1034,25 @@ -- | Apply a defined function to it's arguments, using the original clauses. 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+appDef' f v cls rewr args = appDefE' f v cls rewr $ map' (fmap Apply) args -appDefE' :: QName -> Term -> [Clause] -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)+appDefE' ::+ QName -> Term -> [Clause] -> RewriteRules -> MaybeReducedElims+ -> ReduceM (Reduced (Blocked Term) Term) appDefE' f v cls rewr es =- localTC (\ e -> e { envAppDef = Just f }) $+ localTC (set eAppDef (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'' ::+ 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+ goCls cls $ map' ignoreReduced es where goCls :: [Clause] -> [Elim] -> ReduceM (Reduced (Blocked Term) Term) goCls cl es = do+ let done b es = rewrite (NotBlocked b ()) (applyE v) rewr es case cl of -- Andreas, 2013-10-26 In case of an incomplete match, -- we just do not reduce. This allows adding single function@@ -923,39 +1061,35 @@ -- Andrea(s), 2014-12-05: We return 'MissingClauses' here, since this -- is the most conservative reason. [] -> do- f <- fromMaybe __IMPOSSIBLE__ <$> asksTC envAppDef- rewrite (NotBlocked (MissingClauses f) ()) (applyE v) rewr es+ f <- fromMaybe __IMPOSSIBLE__ <$> viewTC eAppDef+ done (MissingClauses f) es cl : cls -> do let pats = namedClausePats cl body = clauseBody cl npats = length pats nvars = size $ clauseTel cl- -- if clause is underapplied, skip to next clause- if length es < npats then goCls cls es else do- termCheck <- asksTC envTermCheckReducing- let (es0, es1) = splitAt npats es- (m, es0) <- matchCopatterns pats es0- let es = es0 ++ es1- case m of- No -> goCls cls es- -- Szumi, 2024-03-29, issue #7181:- -- If a lazy match is stuck and all non-lazy matches are conclusive,- -- then reduction should not be stuck on the current clause and it- -- should be fine to continue matching on the next clause.- -- This assumes it's impossible for a lazy match to be stuck if- -- all non-lazy matches succeed.- DontKnow OnlyLazy _ -> goCls cls es- DontKnow NonLazy b -> rewrite b (applyE v) rewr es- Yes simpl vs -- vs is the subst. for the variables bound in body- | termCheck && fromMaybe True (clauseRecursive cl) ->- return $ NoReduction __IMPOSSIBLE__- | Just w <- body -> do -- clause has body?- -- TODO: let matchPatterns also return the reduced forms- -- of the original arguments!- -- Andreas, 2013-05-19 isn't this done now?- let sigma = buildSubstitution impossible nvars vs- return $ YesReduction simpl $ applySubst sigma w `applyE` es1- | otherwise -> rewrite (NotBlocked AbsurdMatch ()) (applyE v) rewr es+ allowedReductions <- viewTC eAllowedReductions+ let (es0, es1) = splitAt' npats es+ -- If ps1 /= [] then the function is underapplied+ (ps0, ps1) = splitAt' (length es) pats+ (m, es0) <- matchCopatterns ps0 es0+ let es = es0 ++! es1+ case m of+ No _ -> goCls cls es+ DontKnow _ _ b -> rewrite b (applyE v) rewr es+ Yes simpl vs -- vs is the subst. for the variables bound in body+ -- Jesper, issue #8703: underapplied functions are stuck+ | not (null ps1) -> done Underapplied es+ | couldBeRecursive (clauseRecursive cl)+ , RecursiveReductions `SmallSet.notMember` allowedReductions ->+ return $ NoReduction __IMPOSSIBLE__+ | Just w <- body -> do -- clause has body?+ -- TODO: let matchPatterns also return the reduced forms+ -- of the original arguments!+ -- Andreas, 2013-05-19 isn't this done now?+ let sigma = buildSubstitution impossible nvars vs+ return $ YesReduction simpl $ applySubst sigma w `applyE` es1+ | otherwise -> done AbsurdMatch es instance Reduce a => Reduce (Closure a) where reduce' cl = do@@ -967,6 +1101,15 @@ reduce' EmptyTel = return EmptyTel reduce' (ExtendTel a tel) = ExtendTel <$> reduce' a <*> reduce' tel +instance Reduce ProblemConstraint where+ reduce' (PConstr p u c) = PConstr p u <$> reduce' c++instance Reduce LocalEquation where+ reduce' (LocalEquation g t u a) = do+ g' <- reduce' g+ (t', u', a') <- addContext g' $ reduce' (t, u, a)+ return $ LocalEquation g' t' u' a'+ instance Reduce Constraint where reduce' (ValueCmp cmp t u v) = do (t,u,v) <- reduce' (t,u,v)@@ -980,7 +1123,7 @@ reduce' (SortCmp cmp a b) = uncurry (SortCmp cmp) <$> reduce' (a,b) reduce' (UnBlock m) = return $ UnBlock m reduce' (FindInstance r m cs) = FindInstance r m <$> mapM reduce' cs- reduce' (ResolveInstanceHead q) = return $ ResolveInstanceHead q+ reduce' (ResolveInstanceHead kwr q) = return $ ResolveInstanceHead kwr q reduce' (IsEmpty r t) = IsEmpty r <$> reduce' t reduce' (CheckSizeLtSat t) = CheckSizeLtSat <$> reduce' t reduce' c@CheckFunDef{} = return c@@ -993,6 +1136,7 @@ reduce' c@CheckMetaInst{} = return c reduce' (CheckType t) = CheckType <$> reduce' t reduce' (UsableAtModality cc ms mod t) = flip (UsableAtModality cc) mod <$> reduce' ms <*> reduce' t+ reduce' (RewConstraint e) = RewConstraint <$> reduce' e instance Reduce CompareAs where reduce' (AsTermsOf a) = AsTermsOf <$> reduce' a@@ -1056,6 +1200,12 @@ do (x,(y,z)) <- simplify' (x,(y,z)) return (x,y,z) +instance (Simplify a, Simplify b, Simplify c, Simplify d)+ => Simplify (a,b,c,d) where+ simplify' (x,y,z,w) = do+ (x,(y,z,w)) <- simplify' (x,(y,z,w))+ return (x,y,z,w)+ instance Simplify Bool where simplify' = return @@ -1071,7 +1221,7 @@ (simpl, v) <- unfoldDefinition' keepGoing (Def f []) f vs when (simpl == YesSimplification) $ reportSDoc "tc.simplify'" 90 $- pretty f <+> text ("simplify': unfolding definition returns " ++ show simpl) <+> pretty (ignoreBlocking v)+ 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@@ -1096,8 +1246,8 @@ instance Simplify Sort where simplify' s = do case s of- PiSort a s1 s2 -> piSort <$> simplify' a <*> simplify' s1 <*> simplify' s2- FunSort s1 s2 -> funSort <$> simplify' s1 <*> simplify' s2+ PiSort c a s1 s2 -> uncurry4 piSortM' =<< simplify' (c, a, s1, s2)+ FunSort s1 s2 -> uncurry funSortM =<< simplify' (s1, s2) UnivSort s -> univSort <$> simplify' s Univ u s -> Univ u <$> simplify' s Inf _ _ -> return s@@ -1109,6 +1259,9 @@ DefS d es -> DefS d <$> simplify' es DummyS{} -> return s +instance (Free a, Simplify a) => Simplify (BlockedDepCheck a) where+ simplify' c = forA c \s -> inLargeEnoughContext s $ simplify' s+ instance Simplify Level where simplify' (Max m as) = levelMax m <$> simplify' as @@ -1134,6 +1287,12 @@ instance Simplify ProblemConstraint where simplify' (PConstr pid unblock c) = PConstr pid unblock <$> simplify' c +instance Simplify LocalEquation where+ simplify' (LocalEquation g t u a) = do+ g' <- simplify' g+ (t', u', a') <- addContext g' $ simplify (t, u, a)+ return $ LocalEquation g' t' u' a'+ instance Simplify Constraint where simplify' (ValueCmp cmp t u v) = do (t,u,v) <- simplify' (t,u,v)@@ -1147,7 +1306,7 @@ simplify' (SortCmp cmp a b) = uncurry (SortCmp cmp) <$> simplify' (a,b) simplify' (UnBlock m) = return $ UnBlock m simplify' (FindInstance r m cs) = FindInstance r m <$> mapM simplify' cs- simplify' (ResolveInstanceHead q) = return $ ResolveInstanceHead q+ simplify' (ResolveInstanceHead kwr q) = return $ ResolveInstanceHead kwr q simplify' (IsEmpty r t) = IsEmpty r <$> simplify' t simplify' (CheckSizeLtSat t) = CheckSizeLtSat <$> simplify' t simplify' c@CheckFunDef{} = return c@@ -1160,6 +1319,7 @@ simplify' c@CheckMetaInst{} = return c simplify' (CheckType t) = CheckType <$> simplify' t simplify' (UsableAtModality cc ms mod t) = flip (UsableAtModality cc) mod <$> simplify' ms <*> simplify' t+ simplify' (RewConstraint e) = RewConstraint <$> simplify' e instance Simplify CompareAs where simplify' (AsTermsOf a) = AsTermsOf <$> simplify' a@@ -1233,6 +1393,12 @@ do (x,(y,z)) <- normalise' (x,(y,z)) return (x,y,z) +instance (Normalise a, Normalise b, Normalise c, Normalise d)+ => Normalise (a,b,c,d) where+ normalise' (x,y,z,w) =+ do (x,(y,z,w)) <- normalise' (x,(y,z,w))+ return (x,y,z,w)+ instance Normalise Bool where normalise' = return @@ -1251,8 +1417,8 @@ normalise' s = do s <- reduce' s case s of- PiSort a s1 s2 -> piSort <$> normalise' a <*> normalise' s1 <*> normalise' s2- FunSort s1 s2 -> funSort <$> normalise' s1 <*> normalise' s2+ PiSort c a s1 s2 -> uncurry4 piSortM' =<< normalise' (c, a, s1, s2)+ FunSort s1 s2 -> uncurry funSortM =<< normalise' (s1, s2) UnivSort s -> univSort <$> normalise' s Univ u s -> Univ u <$> normalise' s Inf _ _ -> return s@@ -1264,6 +1430,9 @@ DefS d es -> return s DummyS{} -> return s +instance (Free a, Normalise a) => Normalise (BlockedDepCheck a) where+ normalise' c = forA c \s -> inLargeEnoughContext s $ normalise' s+ instance Normalise t => Normalise (Type' t) where normalise' (El s t) = El <$> normalise' s <*> normalise' t @@ -1314,12 +1483,19 @@ return $ cl { clValue = x } instance (Subst a, Normalise a) => Normalise (Tele a) where- normalise' EmptyTel = return EmptyTel- normalise' (ExtendTel a b) = uncurry ExtendTel <$> normalise' (a, b)+ normalise' tel = expand \ret -> case tel of+ EmptyTel -> ret $ return EmptyTel+ ExtendTel a b -> ret $ uncurry ExtendTel <$> normalise' (a, b) instance Normalise ProblemConstraint where normalise' (PConstr pid unblock c) = PConstr pid unblock <$> normalise' c +instance Normalise LocalEquation where+ normalise' (LocalEquation g t u a) = do+ g' <- normalise g+ (t', u', a') <- addContext g' $ normalise (t, u, a)+ return $ LocalEquation g' t' u' a'+ instance Normalise Constraint where normalise' (ValueCmp cmp t u v) = do (t,u,v) <- normalise' (t,u,v)@@ -1333,7 +1509,7 @@ normalise' (SortCmp cmp a b) = uncurry (SortCmp cmp) <$> normalise' (a,b) normalise' (UnBlock m) = return $ UnBlock m normalise' (FindInstance r m cs) = FindInstance r m <$> mapM normalise' cs- normalise' (ResolveInstanceHead q) = return $ ResolveInstanceHead q+ normalise' (ResolveInstanceHead kwr q) = return $ ResolveInstanceHead kwr q normalise' (IsEmpty r t) = IsEmpty r <$> normalise' t normalise' (CheckSizeLtSat t) = CheckSizeLtSat <$> normalise' t normalise' c@CheckFunDef{} = return c@@ -1346,6 +1522,7 @@ normalise' c@CheckMetaInst{} = return c normalise' (CheckType t) = CheckType <$> normalise' t normalise' (UsableAtModality cc ms mod t) = flip (UsableAtModality cc) mod <$> normalise' ms <*> normalise' t+ normalise' (RewConstraint e) = RewConstraint <$> normalise' e instance Normalise CompareAs where normalise' (AsTermsOf a) = AsTermsOf <$> normalise' a@@ -1396,38 +1573,65 @@ default instantiateFull' :: (t ~ f a, Traversable f, InstantiateFull a) => t -> ReduceM t instantiateFull' = traverse instantiateFull' --- Traversables (doesn't include binders like Abs, Tele):+instance InstantiateFull a => InstantiateFull [a] where+ instantiateFull' = \case+ [] -> pure []+ a:as -> (:) <$!> instantiateFull' a <*!> instantiateFull' as -instance InstantiateFull t => InstantiateFull [t]-instance InstantiateFull t => InstantiateFull (List1 t)+instance InstantiateFull t => InstantiateFull (List1 t) where+ instantiateFull' (a :| as) =+ (:|) <$!> instantiateFull' a <*!> instantiateFull' as++-- Traversables (doesn't include binders like Abs, Tele): instance InstantiateFull t => InstantiateFull (HashMap k t) instance InstantiateFull t => InstantiateFull (Map k t)-instance InstantiateFull t => InstantiateFull (Maybe t)-instance InstantiateFull t => InstantiateFull (Strict.Maybe t) -instance InstantiateFull t => InstantiateFull (Arg t)-instance InstantiateFull t => InstantiateFull (Elim' t)-instance InstantiateFull t => InstantiateFull (Named name t)+instance InstantiateFull t => InstantiateFull (Maybe t) where+ instantiateFull' = \case+ Nothing -> pure Nothing+ Just t -> Just <$!> instantiateFull' t++instance InstantiateFull t => InstantiateFull (Strict.Maybe t) where+ instantiateFull' = \case+ Strict.Nothing -> pure Strict.Nothing+ Strict.Just t -> Strict.Just <$!> instantiateFull' t++instance InstantiateFull t => InstantiateFull (Arg t) where+ instantiateFull' (Arg x y) = Arg x <$!> instantiateFull' y++instance InstantiateFull t => InstantiateFull (Elim' t) where+ instantiateFull' = \case+ Apply a -> Apply <$!> instantiateFull' a+ Proj o x -> pure (Proj o x)+ IApply l r t -> IApply <$!> instantiateFull' l+ <*!> instantiateFull' r+ <*!> instantiateFull' t++instance InstantiateFull t => InstantiateFull (Named name t) where+ instantiateFull' (Named x y) = Named x <$!> instantiateFull' y+ instance InstantiateFull t => InstantiateFull (WithArity t) instance InstantiateFull t => InstantiateFull (IPBoundary' t) -- Tuples:- instance (InstantiateFull a, InstantiateFull b) => InstantiateFull (a,b) where- instantiateFull' (x,y) = (,) <$> instantiateFull' x <*> instantiateFull' y+ {-# INLINE instantiateFull' #-}+ instantiateFull' (x,y) = (,) <$!> instantiateFull' x <*!> instantiateFull' y instance (InstantiateFull a, InstantiateFull b, InstantiateFull c) => InstantiateFull (a,b,c) where+ {-# INLINE instantiateFull' #-} instantiateFull' (x,y,z) =- do (x,(y,z)) <- instantiateFull' (x,(y,z))- return (x,y,z)+ do (x,(y,z)) <- instantiateFull' (x,(y,z))+ return (x,y,z) -instance (InstantiateFull a, InstantiateFull b, InstantiateFull c, InstantiateFull d) => InstantiateFull (a,b,c,d) where+instance (InstantiateFull a, InstantiateFull b, InstantiateFull c, InstantiateFull d)+ => InstantiateFull (a,b,c,d) where+ {-# INLINE instantiateFull' #-} instantiateFull' (x,y,z,w) =- do (x,(y,z,w)) <- instantiateFull' (x,(y,z,w))- return (x,y,z,w)+ do (x,(y,z,w)) <- instantiateFull' (x,(y,z,w))+ return (x,y,z,w) -- Base types:- instance InstantiateFull Bool where instantiateFull' = return @@ -1459,27 +1663,30 @@ instantiateFull' = return -- Rest:- instance InstantiateFull Sort where- instantiateFull' s = do- s <- instantiate' s- case s of- Univ u n -> Univ u <$> instantiateFull' n- PiSort a s1 s2 -> piSort <$> instantiateFull' a <*> instantiateFull' s1 <*> instantiateFull' s2- FunSort s1 s2 -> funSort <$> instantiateFull' s1 <*> instantiateFull' s2- UnivSort s -> univSort <$> instantiateFull' s- Inf _ _ -> return s- SizeUniv -> return s- LockUniv -> return s- LevelUniv -> return s- IntervalUniv -> return s- MetaS x es -> MetaS x <$> instantiateFull' es- DefS d es -> DefS d <$> instantiateFull' es- DummyS{} -> return s+ instantiateFull' s = do+ s <- instantiate' s+ case s of+ Univ u n -> Univ u <$!> instantiateFull' n+ PiSort c a s1 s2 -> uncurry4 piSortM' =<< instantiateFull' (c, a, s1, s2)+ FunSort s1 s2 -> uncurry funSortM =<< instantiateFull' (s1, s2)+ UnivSort s -> univSort <$!> instantiateFull' s+ Inf _ _ -> return s+ SizeUniv -> return s+ LockUniv -> return s+ LevelUniv -> return s+ IntervalUniv -> return s+ MetaS x es -> MetaS x <$!> instantiateFull' es+ DefS d es -> DefS d <$!> instantiateFull' es+ DummyS{} -> return s +instance (Free a, InstantiateFull a)+ => InstantiateFull (BlockedDepCheck a) where+ instantiateFull' c = forA c \s -> inLargeEnoughContext s $ instantiateFull' s+ instance InstantiateFull t => InstantiateFull (Type' t) where instantiateFull' (El s t) =- El <$> instantiateFull' s <*> instantiateFull' t+ El <$!> instantiateFull' s <*!> instantiateFull' t instance InstantiateFull Term where instantiateFull' = instantiate' >=> recurse >=> etaOnce@@ -1487,82 +1694,87 @@ -- but removing etaOnce now breaks everything where recurse = \case- Var n vs -> Var n <$> instantiateFull' vs- Con c ci vs -> Con c ci <$> instantiateFull' vs- Def f vs -> Def f <$> instantiateFull' vs- MetaV x vs -> MetaV x <$> instantiateFull' vs+ Var n vs -> Var n <$!> instantiateFull' vs+ Con c ci vs -> Con c ci <$!> instantiateFull' vs+ Def f vs -> Def f <$!> instantiateFull' vs+ MetaV x vs -> MetaV x <$!> instantiateFull' vs v@Lit{} -> return v- Level l -> levelTm <$> instantiateFull' l- Lam h b -> Lam h <$> instantiateFull' b- Sort s -> Sort <$> instantiateFull' s- Pi a b -> uncurry Pi <$> instantiateFull' (a,b)- DontCare v -> dontCare <$> instantiateFull' v+ Level l -> levelTm <$!> instantiateFull' l+ Lam h b -> Lam h <$!> instantiateFull' b+ Sort s -> Sort <$!> instantiateFull' s+ Pi a b -> uncurry Pi <$!> instantiateFull' (a,b)+ DontCare v -> dontCare <$!> instantiateFull' v v@Dummy{} -> return v instance InstantiateFull Level where- instantiateFull' (Max m as) = levelMax m <$> instantiateFull' as+ instantiateFull' (Max m as) = levelMax m <$!> instantiateFull' as instance InstantiateFull PlusLevel where- instantiateFull' (Plus n l) = Plus n <$> instantiateFull' l+ instantiateFull' (Plus n l) = Plus n <$!> instantiateFull' l 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 n sigma -> Strengthen bot n <$> instantiateFull' sigma- t :# sigma -> consS <$> instantiateFull' t- <*> instantiateFull' sigma+ 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 } instance InstantiateFull a => InstantiateFull (Pattern' a) where- instantiateFull' (VarP o x) = VarP o <$> instantiateFull' x- instantiateFull' (DotP o t) = DotP o <$> instantiateFull' t- instantiateFull' (ConP n mt ps) = ConP n <$> instantiateFull' mt <*> instantiateFull' ps- instantiateFull' (DefP o q ps) = DefP o q <$> instantiateFull' ps+ instantiateFull' (VarP o x) = VarP o <$!> instantiateFull' x+ instantiateFull' (DotP o t) = DotP o <$!> instantiateFull' t+ instantiateFull' (ConP n mt ps) = ConP n <$!> instantiateFull' mt <*!> instantiateFull' ps+ instantiateFull' (DefP o q ps) = DefP o q <$!> instantiateFull' ps instantiateFull' l@LitP{} = return l instantiateFull' p@ProjP{} = return p- instantiateFull' (IApplyP o t u x) = IApplyP o <$> instantiateFull' t <*> instantiateFull' u <*> instantiateFull' x+ instantiateFull' (IApplyP o t u x) = IApplyP o <$!> instantiateFull' t <*!> instantiateFull' u <*!> instantiateFull' x instance (Subst a, InstantiateFull a) => InstantiateFull (Abs a) where- instantiateFull' a@(Abs x _) = Abs x <$> underAbstraction_ a instantiateFull'- instantiateFull' (NoAbs x a) = NoAbs x <$> instantiateFull' a+ instantiateFull' a@(Abs x _) = Abs x <$!> underAbstraction_ a instantiateFull'+ instantiateFull' (NoAbs x a) = NoAbs x <$!> instantiateFull' a -instance (InstantiateFull t, InstantiateFull e) => InstantiateFull (Dom' t e) where- instantiateFull' (Dom i n b tac x) = Dom i n b <$> instantiateFull' tac <*> instantiateFull' x +instance InstantiateFull e => InstantiateFull (Dom e) where+ instantiateFull' (Dom i n b tac rew x) =+ Dom i n b <$!> instantiateFull' tac <*!> instantiateFull' rew <*!> instantiateFull' x++instance InstantiateFull Context where+ instantiateFull' (Context es) = Context <$!> instantiateFull' es+ instance InstantiateFull ContextEntry where- instantiateFull' (CtxVar x a) = CtxVar x <$> instantiateFull' a+ instantiateFull' (CtxVar x a) = CtxVar x <$!> instantiateFull' a instance InstantiateFull LetBinding where- instantiateFull' (LetBinding o v t) = LetBinding o <$> instantiateFull' v <*> instantiateFull' t+ instantiateFull' (LetBinding isAxiom o v t) = LetBinding isAxiom o <$!> instantiateFull' v <*!> instantiateFull' t -- Andreas, 2021-09-13, issue #5544, need to traverse @checkpoints@ map instance InstantiateFull t => InstantiateFull (Open t) where instantiateFull' (OpenThing checkpoint checkpoints modl t) = OpenThing checkpoint- <$> (instantiateFull' =<< prune checkpoints)- <*> pure modl- <*> instantiateFull' t+ <$!> (instantiateFull' =<< prune checkpoints)+ <*!> pure modl+ <*!> instantiateFull' t where -- Ulf, 2021-11-17, #5544 -- Remove checkpoints that are no longer in scope, since they can -- mention functions that deadcode elimination will get rid of. prune cps = do inscope <- viewTC eCheckpoints- return $ cps `Map.intersection` inscope+ return $! cps `Map.intersection` inscope instance InstantiateFull a => InstantiateFull (Closure a) where instantiateFull' cl = do x <- enterClosure cl instantiateFull'- return $ cl { clValue = x }+ return $! cl { clValue = x } instance InstantiateFull ProblemConstraint where- instantiateFull' (PConstr p u c) = PConstr p u <$> instantiateFull' c+ instantiateFull' (PConstr p u c) = PConstr p u <$!> instantiateFull' c instance InstantiateFull Constraint where instantiateFull' = \case@@ -1573,114 +1785,141 @@ ((p,t),u,v) <- instantiateFull' ((p,t),u,v) return $ ValueCmpOnFace cmp p t u v ElimCmp cmp fs t v as bs ->- ElimCmp cmp fs <$> instantiateFull' t <*> instantiateFull' v <*> instantiateFull' as <*> instantiateFull' bs- LevelCmp cmp u v -> uncurry (LevelCmp cmp) <$> instantiateFull' (u,v)- SortCmp cmp a b -> uncurry (SortCmp cmp) <$> instantiateFull' (a,b)+ ElimCmp cmp fs <$!> instantiateFull' t <*!> instantiateFull' v <*!> instantiateFull' as <*!> instantiateFull' bs+ LevelCmp cmp u v -> uncurry (LevelCmp cmp) <$!> instantiateFull' (u,v)+ SortCmp cmp a b -> uncurry (SortCmp cmp) <$!> instantiateFull' (a,b) UnBlock m -> return $ UnBlock m- FindInstance r m cs -> FindInstance r m <$> mapM instantiateFull' cs- ResolveInstanceHead q -> return $ ResolveInstanceHead q- IsEmpty r t -> IsEmpty r <$> instantiateFull' t- CheckSizeLtSat t -> CheckSizeLtSat <$> instantiateFull' t+ FindInstance r m cs -> FindInstance r m <$!> mapM instantiateFull' cs+ ResolveInstanceHead kwr q -> return $ ResolveInstanceHead kwr q+ IsEmpty r t -> IsEmpty r <$!> instantiateFull' t+ CheckSizeLtSat t -> CheckSizeLtSat <$!> instantiateFull' t c@CheckFunDef{} -> return c- HasBiggerSort a -> HasBiggerSort <$> instantiateFull' a- HasPTSRule a b -> uncurry HasPTSRule <$> instantiateFull' (a,b)- UnquoteTactic t g h -> UnquoteTactic <$> instantiateFull' t <*> instantiateFull' g <*> instantiateFull' h+ HasBiggerSort a -> HasBiggerSort <$!> instantiateFull' a+ HasPTSRule a b -> uncurry HasPTSRule <$!> instantiateFull' (a,b)+ 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+ 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 cc ms mod t -> flip (UsableAtModality cc) mod <$> instantiateFull' ms <*> instantiateFull' t+ CheckType t -> CheckType <$!> instantiateFull' t+ UsableAtModality cc ms mod t -> flip (UsableAtModality cc) mod <$!> instantiateFull' ms <*!> instantiateFull' t+ RewConstraint e -> RewConstraint <$!> instantiateFull' e instance InstantiateFull CompareAs where- instantiateFull' (AsTermsOf a) = AsTermsOf <$> instantiateFull' a+ instantiateFull' (AsTermsOf a) = AsTermsOf <$!> instantiateFull' a instantiateFull' AsSizes = return AsSizes instantiateFull' AsTypes = return AsTypes instance InstantiateFull Signature where instantiateFull' (Sig a b c d) = Sig- <$> instantiateFull' a- <*> instantiateFull' b- <*> instantiateFull' c- <*> pure d -- The instance table only stores names+ <$!> instantiateFull' a+ <*!> instantiateFull' b+ <*!> instantiateFull' c+ <*!> pure d -- The instance table only stores names instance InstantiateFull Section where- instantiateFull' (Section tel) = Section <$> instantiateFull' tel+ instantiateFull' (Section tel) = Section <$!> instantiateFull' tel instance (Subst a, InstantiateFull a) => InstantiateFull (Tele a) where instantiateFull' EmptyTel = return EmptyTel- instantiateFull' (ExtendTel a b) = uncurry ExtendTel <$> instantiateFull' (a, b)+ instantiateFull' (ExtendTel a b) = uncurry ExtendTel <$!> instantiateFull' (a, b) instance InstantiateFull Definition where- instantiateFull' def@Defn{ defType = t ,defDisplay = df, theDef = d } = do+ instantiateFull' def@Defn{ defType = t ,defDisplay = df, theDef = d } =+ if defMightContainMetas def then do (t, df, d) <- instantiateFull' (t, df, d)- return $ def{ defType = t, defDisplay = df, theDef = d }+ return $! def{ defType = t, defDisplay = df, theDef = d }+ else do+ return def instance InstantiateFull NLPat where- instantiateFull' (PVar x y) = return $ PVar x y- instantiateFull' (PDef x y) = PDef <$> instantiateFull' x <*> instantiateFull' y- instantiateFull' (PLam x y) = PLam x <$> instantiateFull' y- instantiateFull' (PPi x y) = PPi <$> instantiateFull' x <*> instantiateFull' y- instantiateFull' (PSort x) = PSort <$> instantiateFull' x- instantiateFull' (PBoundVar x y) = PBoundVar x <$> instantiateFull' y- instantiateFull' (PTerm x) = PTerm <$> instantiateFull' x+ instantiateFull' (PVar s x y) = return $ PVar s x y+ instantiateFull' (PDef x y) = PDef <$!> instantiateFull' x <*!> instantiateFull' y+ instantiateFull' (PLam x y) = PLam x <$!> instantiateFull' y+ instantiateFull' (PPi x y) = PPi <$!> instantiateFull' x <*!> instantiateFull' y+ instantiateFull' (PSort x) = PSort <$!> instantiateFull' x+ instantiateFull' (PBoundVar x y) = PBoundVar x <$!> instantiateFull' y+ instantiateFull' (PTerm x) = PTerm <$!> instantiateFull' x instance InstantiateFull NLPType where instantiateFull' (NLPType s a) = NLPType- <$> instantiateFull' s- <*> instantiateFull' a+ <$!> instantiateFull' s+ <*!> instantiateFull' a instance InstantiateFull NLPSort where- instantiateFull' (PUniv u x) = PUniv u <$> instantiateFull' x+ instantiateFull' (PUniv u x) = PUniv u <$!> instantiateFull' x instantiateFull' (PInf f n) = return $ PInf f n instantiateFull' PSizeUniv = return PSizeUniv instantiateFull' PLockUniv = return PLockUniv instantiateFull' PLevelUniv = return PLevelUniv instantiateFull' PIntervalUniv = return PIntervalUniv +instance InstantiateFull GlobalRewriteRule where+ instantiateFull' (GlobalRewriteRule q gamma f ps rhs t c top) =+ GlobalRewriteRule q+ <$!> instantiateFull' gamma+ <*!> pure f+ <*!> instantiateFull' ps+ <*!> instantiateFull' rhs+ <*!> instantiateFull' t+ <*!> pure c+ <*!> pure top++instance InstantiateFull LocalEquation where+ instantiateFull' (LocalEquation a b c d) =+ LocalEquation+ <$!> instantiateFull' a+ <*!> instantiateFull' b+ <*!> instantiateFull' c+ <*!> instantiateFull' d+ instance InstantiateFull RewriteRule where- instantiateFull' (RewriteRule q gamma f ps rhs t c top) =- RewriteRule q- <$> instantiateFull' gamma- <*> pure f- <*> instantiateFull' ps- <*> instantiateFull' rhs- <*> instantiateFull' t- <*> pure c- <*> pure top+ instantiateFull' (RewriteRule a b c d e) =+ RewriteRule+ <$!> instantiateFull' a+ <*!> pure b+ <*!> instantiateFull' c+ <*!> instantiateFull' d+ <*!> instantiateFull' e +instance InstantiateFull RewDom where+ instantiateFull' (RewDom a b) =+ RewDom+ <$!> instantiateFull' a+ <*!> instantiateFull' b+ instance InstantiateFull DisplayForm where- instantiateFull' (Display n ps v) = uncurry (Display n) <$> instantiateFull' (ps, v)+ instantiateFull' (Display n ps v) = uncurry (Display n) <$!> instantiateFull' (ps, v) instance InstantiateFull DisplayTerm where- instantiateFull' (DTerm' v es) = DTerm' <$> instantiateFull' v <*> instantiateFull' es- instantiateFull' (DDot' v es) = DDot' <$> instantiateFull' v <*> instantiateFull' es- instantiateFull' (DCon c ci vs) = DCon c ci <$> instantiateFull' vs- instantiateFull' (DDef c es) = DDef c <$> instantiateFull' es- instantiateFull' (DWithApp v vs ws) = uncurry3 DWithApp <$> instantiateFull' (v, vs, ws)+ instantiateFull' (DTerm' v es) = DTerm' <$!> instantiateFull' v <*!> instantiateFull' es+ instantiateFull' (DDot' v es) = DDot' <$!> instantiateFull' v <*!> instantiateFull' es+ instantiateFull' (DCon c ci vs) = DCon c ci <$!> instantiateFull' vs+ instantiateFull' (DDef c es) = DDef c <$!> instantiateFull' es+ instantiateFull' (DWithApp v vs ws) = uncurry3 DWithApp <$!> instantiateFull' (v, vs, ws) instance InstantiateFull Defn where instantiateFull' d = case d of Axiom{} -> return d DataOrRecSig{} -> return d GeneralizableVar{} -> return d- AbstractDefn d -> AbstractDefn <$> instantiateFull' d+ AbstractDefn d -> AbstractDefn <$!> instantiateFull' d Function{ funClauses = cs, funCompiled = cc, funCovering = cov, funInv = inv, funExtLam = extLam } -> do (cs, cc, cov, inv) <- instantiateFull' (cs, cc, cov, inv) extLam <- instantiateFull' extLam- return $ d { funClauses = cs, funCompiled = cc, funCovering = cov, funInv = inv, funExtLam = extLam }- Datatype{ dataSort = s, dataClause = cl } -> do- s <- instantiateFull' s- cl <- instantiateFull' cl- return $ d { dataSort = s, dataClause = cl }- Record{ recClause = cl, recTel = tel } -> do- cl <- instantiateFull' cl+ return $! d { funClauses = cs, funCompiled = cc, funCovering = cov, funInv = inv, funExtLam = extLam }+ Datatype{ dataSort = s, dataClause = v } -> do+ s <- instantiateFull' s+ v <- instantiateFull' v+ return $! d { dataSort = s, dataClause = v }+ Record{ recClause = v, recTel = tel } -> do+ v <- instantiateFull' v tel <- instantiateFull' tel- return $ d { recClause = cl, recTel = tel }+ return $! d { recClause = v, recTel = tel } Constructor{} -> return d Primitive{ primClauses = cs } -> do cs <- instantiateFull' cs- return $ d { primClauses = cs }+ return $! d { primClauses = cs } PrimitiveSort{} -> return d instance InstantiateFull ExtLamInfo where@@ -1689,54 +1928,55 @@ return $ e { extLamSys = sys} instance InstantiateFull System where- instantiateFull' (System tel sys) = System <$> instantiateFull' tel <*> instantiateFull' sys+ instantiateFull' (System tel sys) = System <$!> instantiateFull' tel <*!> instantiateFull' sys instance InstantiateFull FunctionInverse where instantiateFull' NotInjective = return NotInjective- instantiateFull' (Inverse inv) = Inverse <$> instantiateFull' inv+ instantiateFull' (Inverse inv) = Inverse <$!> instantiateFull' inv instance InstantiateFull a => InstantiateFull (Case a) where instantiateFull' (Branches cop cs eta ls m b lz) = Branches cop- <$> instantiateFull' cs- <*> instantiateFull' eta- <*> instantiateFull' ls- <*> instantiateFull' m- <*> pure b- <*> pure lz+ <$!> instantiateFull' cs+ <*!> instantiateFull' eta+ <*!> instantiateFull' ls+ <*!> instantiateFull' m+ <*!> pure b+ <*!> pure lz instance InstantiateFull CompiledClauses where- instantiateFull' (Fail xs) = return $ Fail xs- instantiateFull' (Done m t) = Done m <$> instantiateFull' t- instantiateFull' (Case n bs) = Case n <$> instantiateFull' bs+ instantiateFull' = \case+ Fail xs -> return $ Fail xs+ Done no mr m t -> Done no mr m <$!> instantiateFull' t+ Case n bs -> Case n <$!> instantiateFull' bs instance InstantiateFull Clause where instantiateFull' (Clause rl rf tel ps b t catchall recursive unreachable ell wm) =- Clause rl rf <$> instantiateFull' tel- <*> instantiateFull' ps- <*> instantiateFull' b- <*> instantiateFull' t- <*> return catchall- <*> return recursive- <*> return unreachable- <*> return ell- <*> return wm+ Clause rl rf <$!> instantiateFull' tel+ <*!> instantiateFull' ps+ <*!> instantiateFull' b+ <*!> instantiateFull' t+ <*!> return catchall+ <*!> return recursive+ <*!> return unreachable+ <*!> return ell+ <*!> return wm instance InstantiateFull Instantiation where instantiateFull' (Instantiation a b) =- Instantiation a <$> instantiateFull' b+ Instantiation a <$!> instantiateFull' b instance InstantiateFull (Judgement MetaId) where instantiateFull' (HasType a b c) =- HasType a b <$> instantiateFull' c+ HasType a b <$!> instantiateFull' c instantiateFull' (IsSort a b) =- IsSort a <$> instantiateFull' b+ IsSort a <$!> instantiateFull' b instance InstantiateFull RemoteMetaVariable where instantiateFull' (RemoteMetaVariable a b c) = RemoteMetaVariable- <$> instantiateFull' a- <*> return b- <*> instantiateFull' c+ <$!> instantiateFull' a+ <*!> return b+ <*!> instantiateFull' c instance InstantiateFull Interface where instantiateFull'@@ -1762,23 +2002,23 @@ <*!> return onames instance InstantiateFull a => InstantiateFull (Builtin a) where- instantiateFull' (Builtin t) = Builtin <$> instantiateFull' t- instantiateFull' (Prim x) = Prim <$> instantiateFull' x+ 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) =- Candidate q <$> instantiateFull' u <*> instantiateFull' t <*> pure ov+ Candidate q <$!> instantiateFull' u <*!> instantiateFull' t <*!> pure ov instance InstantiateFull EqualityView where instantiateFull' (OtherType t) = OtherType- <$> instantiateFull' t+ <$!> instantiateFull' t instantiateFull' (IdiomType t) = IdiomType- <$> instantiateFull' t+ <$!> instantiateFull' t instantiateFull' (EqualityType r s eq l t a b) = EqualityType r- <$> instantiateFull' s- <*> return eq- <*> mapM instantiateFull' l- <*> instantiateFull' t- <*> instantiateFull' a- <*> instantiateFull' b+ <$!> instantiateFull' s+ <*!> return eq+ <*!> mapM instantiateFull' l+ <*!> instantiateFull' t+ <*!> instantiateFull' a+ <*!> instantiateFull' b
src/full/Agda/TypeChecking/Reduce.hs-boot view
@@ -2,7 +2,25 @@ module Agda.TypeChecking.Reduce where -import Agda.Syntax.Internal (Term, Elims, QName)-import Agda.TypeChecking.Monad.Base (TCM, Reduced)+import Agda.Syntax.Common (Arg)+import Agda.Syntax.Internal (Term, Type, Sort, Elims, QName, Abs)+import Agda.TypeChecking.Monad.Base (TCM, Reduced, MonadReduce)+import Agda.TypeChecking.Substitute.Class (Subst) reduceDefCopyTCM :: QName -> Elims -> TCM (Reduced () Term)++class Reduce t++instance Reduce Term+instance Reduce Type+instance Reduce Sort+instance Reduce a => Reduce (Arg a)+instance (Subst a, Reduce a) => Reduce (Abs a)++reduce :: (Reduce a, MonadReduce m) => a -> m a++class InstantiateFull t++instance InstantiateFull Term++instantiateFull :: (InstantiateFull a, MonadReduce m) => a -> m a
src/full/Agda/TypeChecking/Reduce/Fast.hs view
@@ -1,1473 +1,1630 @@-{-# LANGUAGE PatternGuards #-}--{-|--This module implements the Agda Abstract Machine used for compile-time reduction. It's a-call-by-need environment machine with an implicit heap maintained using 'STRef's. See the 'AM' type-below for a description of the machine.--Some other tricks that improves performance:--- Memoise getConstInfo.-- A big chunk of the time during reduction is spent looking up definitions in the signature. Any- long-running reduction will use only a handful definitions though, so memoising getConstInfo is a- big win.--- Optimised case trees.-- Since we memoise getConstInfo we can do some preprocessing of the definitions, returning a- 'CompactDef' instead of a 'Definition'. In particular we streamline the case trees used for- matching in a few ways:-- - Drop constructor arity information.- - Use NameId instead of QName as map keys.- - Special branch for natural number successor.-- None of these changes would make sense to incorporate into the actual case trees. The first two- loses information that we need in other places and the third would complicate a lot of code- working with case trees.-- 'CompactDef' also has a special representation for built-in/primitive- functions that can be implemented as pure functions from 'Literal's.---}-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.Map.Strict as MapS-import qualified Data.IntSet as IntSet-import qualified Data.List as List-import Data.Semigroup ((<>))-import Data.Text (Text)-import qualified Data.Text as T--import System.IO.Unsafe (unsafePerformIO)-import Data.IORef-import Data.STRef-import Data.Char--import Agda.Syntax.Common-import Agda.Syntax.Internal-import Agda.Syntax.Literal--import Agda.TypeChecking.CompiledClause-import Agda.TypeChecking.Monad hiding (Closure(..))-import Agda.TypeChecking.Reduce as R-import Agda.TypeChecking.Rewriting (rewrite)-import Agda.TypeChecking.Substitute--import Agda.Interaction.Options--import Agda.Utils.CallStack ( withCurrentCallStack )-import Agda.Utils.Char-import Agda.Utils.Float-import Agda.Utils.Lens-import Agda.Utils.List-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Null (empty)-import Agda.Utils.Functor-import Agda.Syntax.Common.Pretty-import Agda.Utils.Size-import Agda.Utils.Zipper-import qualified Agda.Utils.SmallSet as SmallSet--import Agda.Utils.Impossible--import Debug.Trace---- * Compact definitions---- This is what the memoised getConstInfo returns. We essentially pick out only the--- information needed for fast reduction from the definition.--data CompactDef =- CompactDef { cdefNonterminating :: Bool- , cdefUnconfirmed :: Bool- , cdefDef :: CompactDefn- , cdefRewriteRules :: RewriteRules- }--data CompactDefn- = CFun { cfunCompiled :: FastCompiledClauses, cfunProjection :: Maybe QName }- | CCon { cconSrcCon :: ConHead, cconArity :: Int }- | CForce -- ^ primForce- | CErase -- ^ primErase- | CTyCon -- ^ Datatype or record type. Need to know this for primForce.- | CAxiom -- ^ Axiom or abstract defn- | CPrimOp Int ([Literal] -> Term) (Maybe FastCompiledClauses)- -- ^ Literals in reverse argument order- | COther -- ^ In this case we fall back to slow reduction--data BuiltinEnv = BuiltinEnv- { bZero, bSuc, bTrue, bFalse, bRefl :: Maybe ConHead- , bPrimForce, bPrimErase :: Maybe QName }---- | Compute a 'CompactDef' from a regular definition.-compactDef :: BuiltinEnv -> Definition -> RewriteRules -> ReduceM CompactDef-compactDef bEnv def rewr = do-- -- WARNING: don't use isPropM here because it relies on reduction,- -- which causes an infinite loop.- let isPrp = isProp $ getSort $ defType def-- shouldReduce <- shouldReduceDef (defName def)- allowed <- asksTC envAllowedReductions-- let isConOrProj = case theDef def of- Constructor{} -> True- Function { funProjection = Right{} } -> True- _ -> False- let allowReduce = and- [ shouldReduce- , or- [ RecursiveReductions `SmallSet.member` allowed- , isConOrProj && ProjectionReductions `SmallSet.member` allowed- , isInlineFun (theDef def) && InlineReductions `SmallSet.member` allowed- , definitelyNonRecursive_ (theDef def) && or- [ defCopatternLHS def && CopatternReductions `SmallSet.member` allowed- , FunctionReductions `SmallSet.member` allowed- ]- ]- , not (defNonterminating def) || SmallSet.member NonTerminatingReductions allowed- , not (defTerminationUnconfirmed def) || SmallSet.member UnconfirmedReductions allowed- , not isPrp- , not (isIrrelevant def)- ]-- cdefn <-- case theDef def of- _ | not allowReduce -> pure CAxiom- _ | Just (defName def) == bPrimForce bEnv -> pure CForce- _ | Just (defName def) == bPrimErase bEnv ->- case telView' (defType def) of- TelV tel _ | natSize tel == 5 -> pure CErase- | otherwise -> pure COther- -- Non-standard equality. Fall back to slow reduce.- _ | defBlocked def /= notBlocked_ -> pure COther -- Blocked definition- 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 <$> either (const Nothing) Just proj }- Function{funClauses = []} -> pure CAxiom- Function{} -> pure COther -- Incomplete definition- Datatype{dataClause = Nothing} -> pure CTyCon- Record{recClause = Nothing} -> pure CTyCon- Datatype{} -> pure COther -- TODO- Record{} -> pure COther -- TODO- Axiom{} -> pure CAxiom- DataOrRecSig{} -> pure CAxiom- AbstractDefn{} -> pure CAxiom- GeneralizableVar{} -> __IMPOSSIBLE__- PrimitiveSort{} -> pure COther -- TODO- Primitive{}- | not (FunctionReductions `SmallSet.member` allowed)- -> pure CAxiom- Primitive{ primName = name, primCompiled = cc } ->- case name of- -- "primShowInteger" -- integers are not literals-- -- Natural numbers- PrimNatPlus -> mkPrim 2 $ natOp (+)- PrimNatMinus -> mkPrim 2 $ natOp (\ x y -> max 0 (x - y))- PrimNatTimes -> mkPrim 2 $ natOp (*)- PrimNatDivSucAux -> mkPrim 4 $ natOp4 divAux- PrimNatModSucAux -> mkPrim 4 $ natOp4 modAux- PrimNatLess -> mkPrim 2 $ natRel (<)- PrimNatEquality -> mkPrim 2 $ natRel (==)-- -- Word64- PrimWord64ToNat -> mkPrim 1 $ \ [LitWord64 a] -> nat (fromIntegral a)- PrimWord64FromNat -> mkPrim 1 $ \ [LitNat a] -> word (fromIntegral a)-- -- Levels- -- "primLevelZero" -- levels are not literals- -- "primLevelSuc" -- levels are not literals- -- "primLevelMax" -- levels are not literals-- -- Floats- PrimFloatInequality -> mkPrim 2 $ floatRel (<=)- PrimFloatEquality -> mkPrim 2 $ floatRel (==)- PrimFloatLess -> mkPrim 2 $ floatRel (<)- PrimFloatIsInfinite -> mkPrim 1 $ floatPred isInfinite- PrimFloatIsNaN -> mkPrim 1 $ floatPred isNaN- PrimFloatIsNegativeZero -> mkPrim 1 $ floatPred isNegativeZero- PrimFloatIsSafeInteger -> mkPrim 1 $ floatPred isSafeInteger- -- "primFloatToWord64" -- returns a maybe- -- "primFloatToWord64Injective" -- identities are not literals- PrimNatToFloat -> mkPrim 1 $ \ [LitNat a] -> float (fromIntegral a)- -- "primIntToFloat" -- integers are not literals- -- "primFloatRound" -- integers and maybe are not literals- -- "primFloatFloor" -- integers and maybe are not literals- -- "primFloatCeiling" -- integers and maybe are not literals- -- "primFloatToRatio" -- integers and sigma are not literals- -- "primRatioToFloat" -- integers are not literals- -- "primFloatDecode" -- integers and sigma are not literals- -- "primFloatEncode" -- integers are not literals- PrimFloatPlus -> mkPrim 2 $ floatOp (+)- PrimFloatMinus -> mkPrim 2 $ floatOp (-)- PrimFloatTimes -> mkPrim 2 $ floatOp (*)- PrimFloatNegate -> mkPrim 1 $ floatFun negate- PrimFloatDiv -> mkPrim 2 $ floatOp (/)- PrimFloatSqrt -> mkPrim 1 $ floatFun sqrt- PrimFloatExp -> mkPrim 1 $ floatFun exp- PrimFloatLog -> mkPrim 1 $ floatFun log- PrimFloatSin -> mkPrim 1 $ floatFun sin- PrimFloatCos -> mkPrim 1 $ floatFun cos- PrimFloatTan -> mkPrim 1 $ floatFun tan- PrimFloatASin -> mkPrim 1 $ floatFun asin- PrimFloatACos -> mkPrim 1 $ floatFun acos- PrimFloatATan -> mkPrim 1 $ floatFun atan- PrimFloatATan2 -> mkPrim 2 $ floatOp atan2- PrimFloatSinh -> mkPrim 1 $ floatFun sinh- PrimFloatCosh -> mkPrim 1 $ floatFun cosh- PrimFloatTanh -> mkPrim 1 $ floatFun tanh- PrimFloatASinh -> mkPrim 1 $ floatFun asinh- PrimFloatACosh -> mkPrim 1 $ floatFun acosh- PrimFloatATanh -> mkPrim 1 $ floatFun atanh- PrimFloatPow -> mkPrim 2 $ floatOp (**)- PrimShowFloat -> mkPrim 1 $ \ [LitFloat a] -> string (show a)-- -- Characters- PrimCharEquality -> mkPrim 2 $ charRel (==)- PrimIsLower -> mkPrim 1 $ charPred isLower- PrimIsDigit -> mkPrim 1 $ charPred isDigit- PrimIsAlpha -> mkPrim 1 $ charPred isAlpha- PrimIsSpace -> mkPrim 1 $ charPred isSpace- PrimIsAscii -> mkPrim 1 $ charPred isAscii- PrimIsLatin1 -> mkPrim 1 $ charPred isLatin1- PrimIsPrint -> mkPrim 1 $ charPred isPrint- PrimIsHexDigit -> mkPrim 1 $ charPred isHexDigit- PrimToUpper -> mkPrim 1 $ charFun toUpper- PrimToLower -> mkPrim 1 $ charFun toLower- PrimCharToNat -> mkPrim 1 $ \ [LitChar a] -> nat (fromIntegral (fromEnum a))- PrimNatToChar -> mkPrim 1 $ \ [LitNat a] -> char (integerToChar a)- PrimShowChar -> mkPrim 1 $ \ [a] -> string (prettyShow a)-- -- Strings- -- "primStringToList" -- lists are not literals (TODO)- -- "primStringFromList" -- lists are not literals (TODO)- PrimStringAppend -> mkPrim 2 $ \ [LitString a, LitString b] -> text (b <> a)- PrimStringEquality -> mkPrim 2 $ \ [LitString a, LitString b] -> bool (b == a)- PrimShowString -> mkPrim 1 $ \ [a] -> string (prettyShow a)-- -- "primErase"- -- "primForce"- -- "primForceLemma"- PrimQNameEquality -> mkPrim 2 $ \ [LitQName a, LitQName b] -> bool (b == a)- PrimQNameLess -> mkPrim 2 $ \ [LitQName a, LitQName b] -> bool (b < a)- PrimShowQName -> mkPrim 1 $ \ [LitQName a] -> string (prettyShow a)- -- "primQNameFixity" -- fixities are not literals (TODO)- PrimMetaEquality -> mkPrim 2 $ \ [LitMeta _ a, LitMeta _ b] -> bool (b == a)- PrimMetaLess -> mkPrim 2 $ \ [LitMeta _ a, LitMeta _ b] -> bool (b < a)- PrimShowMeta -> mkPrim 1 $ \ [LitMeta _ a] -> string (prettyShow a)-- _ -> pure COther- where- fcc = fastCompiledClauses bEnv <$> cc- mkPrim n op = pure $ CPrimOp n op fcc-- divAux k m n j = k + div (max 0 $ n + m - j) (m + 1)- modAux k m n j | n > j = mod (n - j - 1) (m + 1)- | otherwise = k + n-- ~(Just true) = bTrue bEnv <&> \ c -> Con c ConOSystem []- ~(Just false) = bFalse bEnv <&> \ c -> Con c ConOSystem []-- bool a = if a then true else false- nat a = Lit . LitNat $! a- word a = Lit . LitWord64 $! a- float a = Lit . LitFloat $! a- text a = Lit . LitString $! a- string a = text (T.pack a)- char a = Lit . LitChar $! a-- -- Remember reverse order!- natOp f [LitNat a, LitNat b] = nat (f b a)- natOp _ _ = __IMPOSSIBLE__-- natOp4 f [LitNat a, LitNat b, LitNat c, LitNat d] = nat (f d c b a)- natOp4 _ _ = __IMPOSSIBLE__-- natRel f [LitNat a, LitNat b] = bool (f b a)- natRel _ _ = __IMPOSSIBLE__-- floatFun f [LitFloat a] = float (f a)- floatFun _ _ = __IMPOSSIBLE__-- floatOp f [LitFloat a, LitFloat b] = float (f b a)- floatOp _ _ = __IMPOSSIBLE__-- floatPred f [LitFloat a] = bool (f a)- floatPred _ _ = __IMPOSSIBLE__-- floatRel f [LitFloat a, LitFloat b] = bool (f b a)- floatRel _ _ = __IMPOSSIBLE__-- charFun f [LitChar a] = char (f a)- charFun _ _ = __IMPOSSIBLE__-- charPred f [LitChar a] = bool (f a)- charPred _ _ = __IMPOSSIBLE__-- charRel f [LitChar a, LitChar b] = bool (f b a)- charRel _ _ = __IMPOSSIBLE__-- return $- CompactDef { cdefNonterminating = defNonterminating def- , cdefUnconfirmed = defTerminationUnconfirmed def- , cdefDef = cdefn- , cdefRewriteRules = if allowReduce then rewr else []- }---- Faster case trees --------------------------------------------------------data FastCase c = FBranches- { fprojPatterns :: Bool- -- ^ We are constructing a record here (copatterns).- -- 'conBranches' lists projections.- , fconBranches :: Map NameId c- -- ^ Map from constructor (or projection) names to their arity- -- and the case subtree. (Projections have arity 0.)- , fsucBranch :: Maybe c- , flitBranches :: Map Literal c- -- ^ Map from literal to case subtree.- , fcatchallBranch :: Maybe c- -- ^ (Possibly additional) catch-all clause.- , ffallThrough :: Bool- -- ^ (if True) In case of non-canonical argument use catchallBranch.- }----UNUSED Liang-Ting Chen 2019-07-16---noBranches :: FastCase a---noBranches = FBranches{ fprojPatterns = False--- , fconBranches = Map.empty--- , fsucBranch = Nothing--- , flitBranches = Map.empty--- , fcatchallBranch = Nothing--- , ffallThrough = False }---- | Case tree with bodies.--data FastCompiledClauses- = FCase Int (FastCase FastCompiledClauses)- -- ^ @Case n bs@ stands for a match on the @n@-th argument- -- (counting from zero) with @bs@ as the case branches.- -- If the @n@-th argument is a projection, we have only 'conBranches'- -- with arity 0.- | FEta Int [Arg QName] FastCompiledClauses (Maybe FastCompiledClauses)- -- ^ Match on record constructor. Can still have a catch-all though. Just- -- contains the fields, not the actual constructor.- | FDone [Arg ArgName] Term- -- ^ @Done xs b@ stands for the body @b@ where the @xs@ contains hiding- -- and name suggestions for the free variables. This is needed to build- -- lambdas on the right hand side for partial applications which can- -- still reduce.- | FFail- -- ^ Absurd case.--fastCompiledClauses :: BuiltinEnv -> CompiledClauses -> FastCompiledClauses-fastCompiledClauses bEnv cc =- case cc of- Fail{} -> FFail- Done xs b -> FDone xs b- Case (Arg _ n) Branches{ etaBranch = Just (c, cc), catchallBranch = ca } ->- FEta n (conFields c) (fastCompiledClauses bEnv $ content cc) (fastCompiledClauses bEnv <$> ca)- Case (Arg _ n) bs -> FCase n (fastCase bEnv bs)--fastCase :: BuiltinEnv -> Case CompiledClauses -> FastCase FastCompiledClauses-fastCase env (Branches proj con _ lit wild fT _) =- FBranches- { fprojPatterns = proj- , fconBranches = Map.mapKeysMonotonic (nameId . qnameName) $ fmap (fastCompiledClauses env . content) (stripSuc con)- , fsucBranch = fmap (fastCompiledClauses env . content) $ flip Map.lookup con . conName =<< bSuc env- , flitBranches = fmap (fastCompiledClauses env) lit- , ffallThrough = Just True == fT- , fcatchallBranch = fmap (fastCompiledClauses env) wild }- where- stripSuc | Just c <- bSuc env = Map.delete (conName c)- | otherwise = id---{-# INLINE lookupCon #-}-lookupCon :: QName -> FastCase c -> Maybe c-lookupCon c (FBranches _ cons _ _ _ _) = Map.lookup (nameId $ qnameName c) cons---- QName memo ---------------------------------------------------------------{-# NOINLINE memoQName #-}-memoQName :: (QName -> a) -> (QName -> a)-memoQName f = unsafePerformIO $ do- tbl <- newIORef Map.empty- return (unsafePerformIO . f' tbl)- where- f' tbl x = do- let i = nameId (qnameName x)- m <- readIORef tbl- case Map.lookup i m of- Just y -> return y- Nothing -> do- let y = f x- writeIORef tbl (Map.insert i y m)- return y---- * Fast reduction--data Normalisation = WHNF | NF- deriving (Eq)---- | The entry point to the reduction machine.-fastReduce :: Term -> ReduceM (Blocked Term)-fastReduce = fastReduce' WHNF--fastNormalise :: Term -> ReduceM Term-fastNormalise v = ignoreBlocking <$> fastReduce' NF v--fastReduce' :: Normalisation -> Term -> ReduceM (Blocked Term)-fastReduce' norm v = do- tcState <- getTCState- let name (Con c _ _) = c- name _ = __IMPOSSIBLE__-- -- Gather builtins using 'BuiltinAccess' rather than with the default- -- 'HasBuiltins ReduceM' instance. This increases laziness, allowing us to- -- avoid costly builtin lookups unless needed.- builtinName = fmap name . runBuiltinAccess tcState . getBuiltin'- primitiveName = fmap primFunName . runBuiltinAccess tcState . getPrimitive'-- zero = builtinName builtinZero- suc = builtinName builtinSuc- true = builtinName builtinTrue- false = builtinName builtinFalse- refl = builtinName builtinRefl-- force = primitiveName PrimForce- erase = primitiveName PrimErase-- bEnv = BuiltinEnv { bZero = zero, bSuc = suc, bTrue = true, bFalse = false, bRefl = refl,- bPrimForce = force, bPrimErase = erase }- allowedReductions <- asksTC envAllowedReductions- rwr <- optRewriting <$> pragmaOptions- constInfo <- unKleisli $ \f -> do- info <- getConstInfo f- rewr <- if rwr then instantiateRewriteRules =<< getRewriteRulesFor f- else return []- compactDef bEnv info rewr- ReduceM $ \ redEnv -> reduceTm redEnv bEnv (memoQName constInfo) norm v---- * Closures---- | The abstract machine represents terms as closures containing a 'Term', an environment, and a--- spine of eliminations. Note that the environment doesn't necessarily bind all variables in the--- term. The variables in the context in which the abstract machine is started are free in--- closures. The 'IsValue' argument tracks whether the closure is in weak-head normal form.-data Closure s = Closure IsValue Term (Env s) (Spine s)- -- ^ The environment applies to the 'Term' argument. The spine contains closures- -- with their own environments.---- | Used to track if a closure is @Unevaluated@ or a @Value@ (in weak-head normal form), and if so--- why it cannot reduce further.-data IsValue = Value Blocked_ | Unevaled---- | The spine is a list of eliminations. Application eliminations contain pointers.-type Spine s = [Elim' (Pointer s)]--isValue :: Closure s -> IsValue-isValue (Closure isV _ _ _) = isV--setIsValue :: IsValue -> Closure s -> Closure s-setIsValue isV (Closure _ t env spine) = Closure isV t env spine---- | Apply a closure to a spine of eliminations. Note that this does not preserve the 'IsValue'--- field.-clApply :: Closure s -> Spine s -> Closure s-clApply c [] = c-clApply (Closure _ t env es) es' = Closure Unevaled t env (es <> es')---- | Apply a closure to a spine, preserving the 'IsValue' field. Use with care, since usually--- eliminations do not preserve the value status.-clApply_ :: Closure s -> Spine s -> Closure s-clApply_ c [] = c-clApply_ (Closure b t env es) es' = Closure b t env (es <> es')---- * Pointers and thunks---- | Spines and environments contain pointers to closures to enable call-by-need evaluation.-data Pointer s = Pure (Closure s)- -- ^ Not a pointer. Used for closures that do not need to be shared to avoid- -- unnecessary updates.- | Pointer {-# UNPACK #-} !(STPointer s)- -- ^ An actual pointer is an 'STRef' to a 'Thunk'. The thunk is set to 'BlackHole'- -- during the evaluation of its contents to make debugging loops easier.--type STPointer s = STRef s (Thunk (Closure s))---- | A thunk is either a black hole or contains a value.-data Thunk a = BlackHole | Thunk a- deriving (Functor)--derefPointer :: Pointer s -> ST s (Thunk (Closure s))-derefPointer (Pure x) = return (Thunk x)-derefPointer (Pointer ptr) = readSTRef ptr---- | In most cases pointers that we dereference do not contain black holes.-derefPointer_ :: Pointer s -> ST s (Closure s)-derefPointer_ ptr =- derefPointer ptr <&> \case- Thunk cl -> cl- BlackHole -> __IMPOSSIBLE__----- | Only use for debug printing!-unsafeDerefPointer :: Pointer s -> Thunk (Closure s)-unsafeDerefPointer (Pure x) = Thunk x-unsafeDerefPointer (Pointer p) = unsafePerformIO (unsafeSTToIO (readSTRef p))--readPointer :: STPointer s -> ST s (Thunk (Closure s))-readPointer = readSTRef--storePointer :: STPointer s -> Closure s -> ST s ()-storePointer ptr !cl = writeSTRef ptr (Thunk cl)- -- Note the strict match. To prevent leaking memory in case of unnecessary updates.--blackHole :: STPointer s -> ST s ()-blackHole ptr = writeSTRef ptr BlackHole---- | Create a thunk. If the closure is a naked variable we can reuse the pointer from the--- environment to avoid creating long pointer chains.-createThunk :: Closure s -> ST s (Pointer s)-createThunk (Closure _ (Var x []) env spine)- | null spine, Just p <- lookupEnv x env = return p-createThunk cl = Pointer <$> newSTRef (Thunk cl)---- | Create a thunk that is not shared or updated.-pureThunk :: Closure s -> Pointer s-pureThunk = Pure---- * Environments---- | The environment of a closure binds pointers to deBruijn indicies.-newtype Env s = Env [Pointer s]--emptyEnv :: Env s-emptyEnv = Env []---UNUSED Liang-Ting Chen 2019-07-16---isEmptyEnv :: Env s -> Bool---isEmptyEnv (Env xs) = null xs--envSize :: Env s -> Int-envSize (Env xs) = length xs--envToList :: Env s -> [Pointer s]-envToList (Env xs) = xs--extendEnv :: Pointer s -> Env s -> Env s-extendEnv p (Env xs) = Env (p : xs)---- | Unsafe.-lookupEnv_ :: Int -> Env s -> Pointer s-lookupEnv_ i (Env e) = indexWithDefault __IMPOSSIBLE__ e i---- Andreas, 2018-11-12, which isn't this just Agda.Utils.List.!!! ?-lookupEnv :: Int -> Env s -> Maybe (Pointer s)-lookupEnv i e | i < n = Just (lookupEnv_ i e)- | otherwise = Nothing- where n = envSize e---- * The Agda Abstract Machine---- | The abstract machine state has two states 'Eval' and 'Match' that determine what the machine is--- currently working on: evaluating a closure in the Eval state and matching a spine against a--- case tree in the Match state. Both states contain a 'ControlStack' of continuations for what to--- do next. The heap is maintained implicitly using 'STRef's, hence the @s@ parameter.-data AM s = Eval (Closure s) !(ControlStack s)- -- ^ Evaluate the given closure (the focus) to weak-head normal form. If the 'IsValue'- -- field of the closure is 'Value' we look at the control stack for what to do. Being- -- strict in the control stack is important! We can spend a lot of steps with- -- unevaluated closures (where we update, but don't look at the control stack). For- -- instance, long chains of 'suc' constructors.- | Match QName FastCompiledClauses (Spine s) (MatchStack s) (ControlStack s)- -- ^ @Match f cc spine stack ctrl@ Match the arguments @spine@ against the case tree- -- @cc@. The match stack contains a (possibly empty) list of 'Catchall' frames and a- -- closure to return in case of a stuck match.---- | The control stack contains a list of continuations, i.e. what to do with--- the result of the current focus.-type ControlStack s = [ControlFrame s]---- | The control stack for matching. Contains a list of CatchallFrame's and the closure to return in--- case of a stuck match.-data MatchStack s = [CatchallFrame s] :> Closure s-infixr 2 :>, >:--(>:) :: CatchallFrame s -> MatchStack s -> MatchStack s-(>:) c (cs :> cl) = c : cs :> cl--- Previously written as:--- c >: cs :> cl = c : cs :> cl------ However, some versions/tools fail to parse infix data constructors properly.--- For example, stylish-haskell@0.9.2.1 fails with the following error:--- Language.Haskell.Stylish.Parse.parseModule: could not parse--- src/full/Agda/TypeChecking/Reduce/Fast.hs: ParseFailed (SrcLoc--- "<unknown>.hs" 625 1) "Parse error in pattern: "------ See https://ghc.haskell.org/trac/ghc/ticket/10018 which may be related.--data CatchallFrame s = Catchall FastCompiledClauses (Spine s)- -- ^ @Catchall cc spine@. Case trees are not fully expanded, that is,- -- inner matches can be partial and covered by a catch-all at a higher- -- level. This catch-all is represented on the match stack as a- -- @Catchall@. @cc@ is the case tree in the catch-all case and @spine@ is- -- the value of the pattern variables at the point of the catch-all.---- An Elim' with a hole.-data ElimZipper a = ApplyCxt ArgInfo- | IApplyType a a | IApplyFst a a | IApplySnd a a- deriving (Eq, Ord, Show, Functor, Foldable, Traversable)--instance Zipper (ElimZipper a) where- type Carrier (ElimZipper a) = Elim' a- type Element (ElimZipper a) = a-- firstHole (Apply arg) = Just (unArg arg, ApplyCxt (argInfo arg))- firstHole (IApply a x y) = Just (a, IApplyType x y)- firstHole Proj{} = Nothing-- plugHole x (ApplyCxt i) = Apply (Arg i x)- plugHole a (IApplyType x y) = IApply a x y- plugHole x (IApplyFst a y) = IApply a x y- plugHole y (IApplySnd a x) = IApply a x y-- nextHole a (IApplyType x y) = Right (x, IApplyFst a y)- nextHole x (IApplyFst a y) = Right (y, IApplySnd a x)- nextHole y (IApplySnd a x) = Left (IApply a x y)- nextHole x c@ApplyCxt{} = Left (plugHole x c)---- | A spine with a single hole for a pointer.-type SpineContext s = ComposeZipper (ListZipper (Elim' (Pointer s)))- (ElimZipper (Pointer s))---- | Control frames are continuations that act on value closures.-data ControlFrame s = CaseK QName ArgInfo (FastCase FastCompiledClauses) (Spine s) (Spine s) (MatchStack s)- -- ^ @CaseK f i bs spine0 spine1 stack@. Pattern match on the focus (with- -- arg info @i@) using the @bs@ case tree. @f@ is the name of the function- -- doing the matching, and @spine0@ and @spine1@ are the values bound to- -- the pattern variables to the left and right (respectively) of the- -- focus. The match stack contains catch-all cases we need to consider if- -- this match fails.- | ArgK (Closure s) (SpineContext s)- -- ^ @ArgK cl cxt@. Used when computing full normal forms. The closure is- -- the head and the context is the spine with the current focus removed.- | NormaliseK- -- ^ Indicates that the focus should be evaluated to full normal form.- | ForceK QName (Spine s) (Spine s)- -- ^ @ForceK f spine0 spine1@. Evaluating @primForce@ of the focus. @f@ is- -- the name of @primForce@ and is used to build the result if evaluation- -- gets stuck. @spine0@ are the level and type arguments and @spine1@- -- contains (if not empty) the continuation and any additional- -- eliminations.- | EraseK QName (Spine s) (Spine s) (Spine s) (Spine s)- -- ^ @EraseK f spine0 spine1 spine2 spine3@. Evaluating @primErase@. The- -- first contains the level and type arguments. @spine1@ and @spine2@- -- contain at most one argument between them. If in @spine1@ it's the- -- value closure of the first argument to be compared and if in @spine2@- -- it's the unevaluated closure of the second argument.- -- @spine3@ contains the proof of equality we are erasing. It is passed- -- around but never actually inspected.- | NatSucK Integer- -- ^ @NatSucK n@. Add @n@ to the focus. If the focus computes to a natural- -- number literal this returns a new literal, otherwise it constructs @n@- -- calls to @suc@.- | PrimOpK QName ([Literal] -> Term) [Literal] [Pointer s] (Maybe FastCompiledClauses)- -- ^ @PrimOpK f op lits es cc@. Evaluate the primitive function @f@ using- -- the Haskell function @op@. @op@ gets a list of literal values in- -- reverse order for the arguments of @f@ and computes the result as a- -- term. The already computed arguments (in reverse order) are @lits@ and- -- @es@ are the arguments that should be computed after the current focus.- -- In case of built-in functions with corresponding Agda implementations,- -- @cc@ contains the case tree.- | UpdateThunk [STPointer s]- -- ^ @UpdateThunk ps@. Update the pointers @ps@ with the value of the- -- current focus.- | ApplyK (Spine s)- -- ^ @ApplyK spine@. Apply the current focus to the eliminations in @spine@.- -- This is used when a thunk needs to be updated with a partial- -- application of a function.---- * Compilation and decoding---- | The initial abstract machine state. Wrap the term to be evaluated in an empty closure. Note--- that free variables of the term are treated as constants by the abstract machine. If computing--- full normal form we start off the control stack with a 'NormaliseK' continuation.-compile :: Normalisation -> Term -> AM s-compile nf t = Eval (Closure Unevaled t emptyEnv []) [NormaliseK | nf == NF]--decodePointer :: Pointer s -> ST s Term-decodePointer p = decodeClosure_ =<< derefPointer_ p---- | Note: it's important to be lazy in the spine and environment when decoding. Hence the--- 'unsafeInterleaveST' here and in 'decodeEnv', and the special version of 'parallelS' in--- 'decodeClosure'.-decodeSpine :: Spine s -> ST s Elims-decodeSpine spine = unsafeInterleaveST $ (traverse . traverse) decodePointer spine--decodeEnv :: Env s -> ST s [Term]-decodeEnv env = unsafeInterleaveST $ traverse decodePointer (envToList env)--decodeClosure_ :: Closure s -> ST s Term-decodeClosure_ = ignoreBlocking <.> decodeClosure---- | Turning an abstract machine closure back into a term. This happens in three cases:--- * when reduction is finished and we return the weak-head normal term to the outside world.--- * when the abstract machine encounters something it cannot handle and falls back to the slow--- reduction engine--- * when there are rewrite rules to apply-decodeClosure :: Closure s -> ST s (Blocked Term)-decodeClosure (Closure isV t env spine) = do- vs <- decodeEnv env- es <- decodeSpine spine- return $ applyE (applySubst (parS vs) t) es <$ b- where- parS = foldr (:#) IdS -- parallelS is too strict- b = case isV of- Value b -> b- Unevaled -> notBlocked () -- only when falling back to slow reduce in which case the- -- blocking tag is immediately discarded---- | Turn a list of internal syntax eliminations into a spine. This builds closures and allocates--- thunks for all the 'Apply' elims.-elimsToSpine :: Env s -> Elims -> ST s (Spine s)-elimsToSpine env es = do- spine <- mapM thunk es- forceSpine spine `seq` return spine- where- -- Need to be strict in mkClosure to avoid memory leak- forceSpine = foldl (\ () -> forceEl) ()- forceEl (Apply (Arg _ (Pure Closure{}))) = ()- forceEl (Apply (Arg _ (Pointer{}))) = ()- forceEl _ = ()-- -- We don't preserve free variables of closures (in the sense of their- -- decoding), since we freely add things to the spines.- unknownFVs = setFreeVariables unknownFreeVariables-- thunk (Apply (Arg i t)) = Apply . Arg (unknownFVs i) <$> createThunk (closure (getFreeVariables i) t)- thunk (Proj o f) = return (Proj o f)- thunk (IApply a x y) = IApply <$> mkThunk a <*> mkThunk x <*> mkThunk y- where mkThunk = createThunk . closure UnknownFVs-- -- Going straight for a value for literals is mostly to make debug traces- -- less verbose and doesn't really buy anything performance-wise.- closure _ t@Lit{} = Closure (Value $ notBlocked ()) t emptyEnv []- closure fv t = env' `seq` Closure Unevaled t env' []- where env' = trimEnvironment fv env---- | Trim unused entries from an environment. Currently only trims closed terms for performance--- reasons.-trimEnvironment :: FreeVariables -> Env s -> Env s-trimEnvironment UnknownFVs env = env-trimEnvironment (KnownFVs fvs) env- | IntSet.null fvs = emptyEnv- -- Environment trimming is too expensive (costs 50% on some benchmarks), and while it does make- -- some cases run in constant instead of linear space you need quite contrived examples to- -- notice the effect.- | otherwise = env -- Env $ trim 0 $ envToList env- where- -- Important: strict enough that the trimming actually happens- trim _ [] = []- trim i (p : ps)- | IntSet.member i fvs = (p :) $! trim (i + 1) ps- | otherwise = (unusedPointer :) $! trim (i + 1) ps---- | Build an environment for a body with some given free variables from a spine of arguments.--- Returns a triple containing--- * the left-over variable names (in case of partial application)--- * the environment--- * the remaining spine (in case of over-application)-buildEnv :: [Arg String] -> Spine s -> ([Arg String], Env s, Spine s)-buildEnv xs spine = go xs spine emptyEnv- where- go [] sp env = ([], env, sp)- go xs0@(x : xs) sp env =- case sp of- [] -> (xs0, env, sp)- Apply c : sp -> go xs sp (unArg c `extendEnv` env)- IApply x y r : sp -> go xs sp (r `extendEnv` env)- _ -> __IMPOSSIBLE__--unusedPointerString :: Text-unusedPointerString = T.pack (show (withCurrentCallStack Impossible))--unusedPointer :: Pointer s-unusedPointer = Pure (Closure (Value $ notBlocked ())- (Lit (LitString unusedPointerString)) emptyEnv [])---- * Running the abstract machine---- | Evaluating a term in the abstract machine. It gets the type checking state and environment in--- the 'ReduceEnv' argument, some precomputed built-in mappings in 'BuiltinEnv', the memoised--- 'getConstInfo' function, a couple of flags (allow non-terminating function unfolding, and--- whether rewriting is enabled), and a term to reduce. The result is the weak-head normal form of--- the term with an attached blocking tag.-reduceTm :: ReduceEnv -> BuiltinEnv -> (QName -> CompactDef) -> Normalisation -> Term -> Blocked Term-reduceTm rEnv bEnv !constInfo normalisation =- compileAndRun . traceDoc "-- fast reduce --"- where- -- Helpers to get information from the ReduceEnv.- 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- 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)- iview = runReduce intervalView'-- runReduce :: ReduceM a -> a- runReduce m = unReduceM m rEnv-- -- Debug output. Taking care that we only look at the verbosity level once.- hasVerb tag lvl = unReduceM (hasVerbosity tag lvl) rEnv- doDebug = hasVerb "tc.reduce.fast" 110- traceDoc :: Doc -> a -> a- traceDoc- | doDebug = trace . show- | otherwise = const id-- -- Checking for built-in zero and suc- BuiltinEnv{ bZero = zero, bSuc = suc, bRefl = refl0 } = bEnv- conNameId = nameId . qnameName . conName- isZero = case zero of- Nothing -> const False- Just z -> (conNameId z ==) . conNameId- isSuc = case suc of- Nothing -> const False- Just s -> (conNameId s ==) . conNameId-- -- If there's a non-standard equality (for instance doubly-indexed) we fall back to slow reduce- -- for primErase and "unbind" refl.- refl = refl0 >>= \ c -> if cconArity (cdefDef $ constInfo $ conName c) == 0- then Just c else Nothing-- -- The entry point of the machine.- compileAndRun :: Term -> Blocked Term- compileAndRun t = runST (runAM (compile normalisation t))-- -- Run the machine in a given state. Prints the state if the right verbosity level is active.- runAM :: AM s -> ST s (Blocked Term)- runAM = if doDebug then \ s -> trace (prettyShow s) (runAM' s)- else runAM'-- -- The main function. This is where the stuff happens!- runAM' :: AM s -> ST s (Blocked Term)-- -- Base case: The focus is a value closure and the control stack is empty. Decode and return.- runAM' (Eval cl@(Closure Value{} _ _ _) []) = decodeClosure cl-- -- Unevaluated closure: inspect the term and take the appropriate action. For instance,- -- - Change to the 'Match' state if a definition- -- - 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" #-}- case t of-- -- Case: definition. Enter 'Match' state if defined function or shift to evaluating an- -- argument and pushing the appropriate control frame for primitive functions. Fall back to- -- slow reduce for unsupported definitions.- Def f [] ->- evalIApplyAM spine ctrl $- let CompactDef{ cdefNonterminating = nonterm- , cdefUnconfirmed = unconf- , cdefDef = def } = constInfo f- in case def of- CFun{ cfunCompiled = cc } -> runAM (Match f cc spine ([] :> cl) ctrl)- CAxiom -> rewriteAM done- CTyCon -> rewriteAM done- CCon{} -> runAM done -- Only happens for builtinSharp (which is a Def when you bind it)- CForce | (spine0, Apply v : spine1) <- splitAt 4 spine ->- evalPointerAM (unArg v) [] (ForceK f spine0 spine1 : ctrl)- CForce -> runAM done -- partially applied- CErase | (spine0, Apply v : spine1 : spine2) <- splitAt 2 spine ->- evalPointerAM (unArg v) [] (EraseK f spine0 [] [spine1] spine2 : ctrl)- CErase -> runAM done -- partially applied- CPrimOp n op cc | length spine == n, -- PrimOps can't be over-applied. They don't- Just (v : vs) <- allApplyElims spine -> -- return functions or records.- evalPointerAM (unArg v) [] (PrimOpK f op [] (map unArg vs) cc : ctrl)- CPrimOp{} -> runAM done -- partially applied- COther -> fallbackAM s-- -- Case: zero. Return value closure with literal 0.- Con c i [] | isZero c ->- runAM (evalTrueValue (Lit (LitNat 0)) emptyEnv spine ctrl)-- -- Case: suc. Suc is strict in its argument to make sure we return a literal whenever- -- possible. Push a 'NatSucK' frame on the control stack and evaluate the argument.- Con c i [] | isSuc c, Apply v : _ <- spine ->- evalPointerAM (unArg v) [] (sucCtrl ctrl)-- -- Case: constructor. Perform beta reduction if projected from, otherwise return a value.- Con c i []- -- Constructors of types in Prop are not representex as- -- CCon, so this match might fail!- | CCon{cconSrcCon = c', cconArity = ar} <- cdefDef (constInfo (conName c)) ->- evalIApplyAM spine ctrl $- case splitAt ar spine of- (args, Proj _ p : spine')- -> evalPointerAM (unArg arg) spine' ctrl -- Andreas #2170: fit argToDontCare here?!- where- fields = map unArg $ conFields c- Just n = List.elemIndex p fields- Apply arg = args !! n- _ -> rewriteAM (evalTrueValue (Con c' i []) env spine ctrl)- | otherwise -> runAM done-- -- Case: variable. Look up the variable in the environment and evaluate the resulting- -- pointer. If the variable is not in the environment it's a free variable and we adjust the- -- deBruijn index appropriately.- Var x [] ->- evalIApplyAM spine ctrl $- case lookupEnv x env of- Nothing -> runAM (evalValue (notBlocked ()) (Var (x - envSize env) []) emptyEnv spine ctrl)- Just p -> evalPointerAM p spine ctrl-- -- Case: lambda. Perform the beta reduction if applied. Otherwise it's a value.- Lam h b ->- case spine of- [] -> runAM done- elim : spine' ->- case b of- Abs _ b -> runAM (evalClosure b (getArg elim `extendEnv` env) spine' ctrl)- NoAbs _ b -> runAM (evalClosure b env spine' ctrl)- where- getArg (Apply v) = unArg v- getArg (IApply _ _ v) = v- getArg Proj{} = __IMPOSSIBLE__-- -- Case: values. Literals and function types are already in weak-head normal form.- -- We throw away the environment for literals mostly to make debug printing less verbose.- -- And we know the spine is empty since literals cannot be applied or projected.- Lit{} -> runAM (evalTrueValue t emptyEnv [] ctrl)- Pi{} -> runAM done- DontCare{} -> runAM done-- -- Case: non-empty spine. If the focused term has a non-empty spine, we shift the- -- eliminations onto the spine.- Def f es -> shiftElims (Def f []) emptyEnv env es- Con c i es -> shiftElims (Con c i []) emptyEnv env es- Var x es -> shiftElims (Var x []) env env es-- -- Case: metavariable. If it's instantiated evaluate the value. Meta instantiations are open- -- terms with a specified list of free variables. buildEnv constructs the appropriate- -- environment for the closure. Avoiding shifting spines for open metas- -- save a bit of performance.- MetaV m es -> evalIApplyAM spine ctrl $- 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 (instTel i) (spine' <> spine)- runAM (evalClosure (lams zs (instBody i)) env spine'' ctrl)- Just OpenMeta{} -> __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.- Level{} -> fallbackAM s- Sort{} -> fallbackAM s- Dummy{} -> fallbackAM s-- where done = Eval (mkValue (notBlocked ()) cl) ctrl- shiftElims t env0 env es = do- spine' <- elimsToSpine env es- runAM (evalClosure t env0 (spine' <> spine) ctrl)-- -- If the current focus is a value closure, we look at the control stack.-- -- Case NormaliseK: The focus is a weak-head value that should be fully normalised.- runAM' s@(Eval cl@(Closure b t env spine) (NormaliseK : ctrl)) =- case t of- Def _ [] -> normaliseArgsAM (Closure b t emptyEnv []) spine ctrl- Con _ _ [] -> normaliseArgsAM (Closure b t emptyEnv []) spine ctrl- Var _ [] -> normaliseArgsAM (Closure b t emptyEnv []) spine ctrl- MetaV _ [] -> normaliseArgsAM (Closure b t emptyEnv []) spine ctrl-- Lit{} -> runAM done-- -- We might get these from fallbackAM- Def f es -> shiftElims (Def f []) emptyEnv env es- Con c i es -> shiftElims (Con c i []) emptyEnv env es- Var x es -> shiftElims (Var x []) env env es- MetaV m es -> shiftElims (MetaV m []) emptyEnv env es-- _ -> fallbackAM s -- fallbackAM knows about NormaliseK-- where done = Eval (mkValue (notBlocked ()) cl) ctrl- shiftElims t env0 env es = do- spine' <- elimsToSpine env es- runAM (Eval (Closure b t env0 (spine' <> spine)) (NormaliseK : ctrl))-- -- Case: ArgK: We successfully normalised an argument. Start on the next argument, or if there- -- isn't one we're done.- runAM' (Eval cl (ArgK cl0 cxt : ctrl)) =- case nextHole (pureThunk cl) cxt of- Left spine -> runAM (Eval (clApply_ cl0 spine) ctrl)- Right (p, cxt') -> evalPointerAM p [] (NormaliseK : ArgK cl0 cxt' : ctrl)-- -- Case: NatSucK m-- -- If literal add m to the literal,- runAM' (Eval cl@(Closure Value{} (Lit (LitNat n)) _ _) (NatSucK m : ctrl)) =- runAM (evalTrueValue (Lit $! LitNat $! m + n) emptyEnv [] ctrl)-- -- otherwise apply 'suc' m times.- runAM' (Eval cl (NatSucK m : ctrl)) =- runAM (Eval (mkValue (notBlocked ()) $ plus m cl) ctrl)- where- plus 0 cl = cl- plus n cl =- trueValue (Con (fromMaybe __IMPOSSIBLE__ suc) ConOSystem []) emptyEnv $- Apply (defaultArg arg) : []- where arg = pureThunk (plus (n - 1) cl)-- -- Case: PrimOpK-- -- If literal apply the primitive function if no more arguments, otherwise- -- store the literal in the continuation and evaluate the next argument.- runAM' (Eval (Closure _ (Lit a) _ _) (PrimOpK f op vs es cc : ctrl)) =- case es of- [] -> runAM (evalTrueValue (op (a : vs)) emptyEnv [] ctrl)- e : es' -> evalPointerAM e [] (PrimOpK f op (a : vs) es' cc : ctrl)-- -- If not a literal we use the case tree if there is one, otherwise we are stuck.- runAM' (Eval cl@(Closure (Value blk) _ _ _) (PrimOpK f _ vs es mcc : ctrl)) =- case mcc of- Nothing -> rewriteAM (Eval stuck ctrl)- Just cc -> runAM (Match f cc spine ([] :> notstuck) ctrl)- where- p = pureThunk cl- lits = map (pureThunk . litClos) (reverse vs)- spine = fmap (Apply . defaultArg) $ lits <> [p] <> es- stuck = Closure (Value blk) (Def f []) emptyEnv spine- notstuck = Closure Unevaled (Def f []) emptyEnv spine- litClos l = trueValue (Lit l) emptyEnv []-- -- Case: ForceK. Here we need to check if the argument is a canonical form (i.e. not a variable- -- or stuck function call) and if so apply the function argument to the value. If it's not- -- canonical we are stuck.- runAM' (Eval arg@(Closure (Value blk) t _ _) (ForceK pf spine0 spine1 : ctrl))- | isCanonical t =- case spine1 of- Apply k : spine' ->- evalPointerAM (unArg k) (elim : spine') ctrl- [] -> -- Partial application of primForce to canonical argument, return λ k → k arg.- runAM (evalTrueValue (lam (defaultArg "k") $ Var 0 [Apply $ defaultArg $ Var 1 []])- (argPtr `extendEnv` emptyEnv) [] ctrl)- _ -> __IMPOSSIBLE__- | otherwise = rewriteAM (Eval stuck ctrl)- where- argPtr = pureThunk arg- elim = Apply (defaultArg argPtr)- spine' = spine0 <> [elim] <> spine1- stuck = Closure (Value blk) (Def pf []) emptyEnv spine'-- isCanonical = \case- Lit{} -> True- Con{} -> True- Lam{} -> True- Pi{} -> True- Sort{} -> True- Level{} -> True- DontCare{} -> True- Dummy{} -> False- MetaV{} -> False- Var{} -> False- Def q _ -- Type constructors (data/record) are considered canonical for 'primForce'.- | CTyCon <- cdefDef (constInfo q) -> True- | otherwise -> False-- -- Case: EraseK. We evaluate both arguments to values, then do a simple check for the easy- -- cases and otherwise fall back to slow reduce.- runAM' (Eval cl2@(Closure Value{} arg2 _ _) (EraseK f spine0 [Apply p1] _ spine3 : ctrl)) = do- cl1@(Closure _ arg1 _ sp1) <- derefPointer_ (unArg p1)- case (arg1, arg2) of- (Lit l1, Lit l2) | l1 == l2, isJust refl ->- runAM (evalTrueValue (Con (fromJust refl) ConOSystem []) emptyEnv [] ctrl)- _ ->- let spine = spine0 ++ map (Apply . hide . defaultArg . pureThunk) [cl1, cl2] ++ spine3 in- fallbackAM (evalClosure (Def f []) emptyEnv spine ctrl)- runAM' (Eval cl1@(Closure Value{} _ _ _) (EraseK f spine0 [] [Apply p2] spine3 : ctrl)) =- evalPointerAM (unArg p2) [] (EraseK f spine0 [Apply $ hide $ defaultArg $ pureThunk cl1] [] spine3 : ctrl)- runAM' (Eval _ (EraseK{} : _)) =- __IMPOSSIBLE__-- -- Case: UpdateThunk. Write the value to the pointers in the UpdateThunk frame.- runAM' (Eval cl@(Closure Value{} _ _ _) (UpdateThunk ps : ctrl)) =- mapM_ (`storePointer` cl) ps >> runAM (Eval cl ctrl)-- -- Case: ApplyK. Application after thunk update. Add the spine from the control frame to the- -- closure.- runAM' (Eval cl@(Closure Value{} _ _ _) (ApplyK spine : ctrl)) =- runAM (Eval (clApply cl spine) ctrl)-- -- Case: CaseK. Pattern matching against a value. If it's a stuck value the pattern match is- -- stuck and we return the closure from the match stack (see stuckMatch). Otherwise we need to- -- find a matching branch switch to the Match state. If there is no matching branch we look for- -- a Catchall in the match stack, or fail if there isn't one (see failedMatch). If the current- -- branches contain a catch-all case we need to push a Catchall on the match stack if picking- -- one of the other branches.- runAM' (Eval cl@(Closure (Value blk) t env spine) ctrl0@(CaseK f i bs spine0 spine1 stack : ctrl)) =- {-# SCC "runAM.CaseK" #-}- case blk of- Blocked{} | null [()|Con{} <- [t]] -> stuck -- we might as well check the blocking tag first- _ -> case t of- -- Case: suc constructor- Con c ci [] | isSuc c -> matchSuc $ matchCatchall $ failedMatch f stack ctrl-- -- Case: constructor- Con c ci [] -> matchCon c ci (length spine) $ matchCatchall $ failedMatch f stack ctrl-- -- Case: non-empty elims. We can get here from a fallback (which builds a value without- -- shifting arguments onto spine)- Con c ci es -> do- spine' <- elimsToSpine env es- runAM (evalValue blk (Con c ci []) emptyEnv (spine' <> spine) ctrl0)- -- Case: natural number literals. Literal natural number patterns are translated to- -- suc-matches, so there is no need to try matchLit.- Lit (LitNat 0) -> matchLitZero $ matchCatchall $ failedMatch f stack ctrl- Lit (LitNat n) -> matchLitSuc n $ matchCatchall $ failedMatch f stack ctrl-- -- Case: literal- Lit l -> matchLit l $ matchCatchall $ failedMatch f stack ctrl-- -- Case: hcomp- Def q [] | isJust $ lookupCon q bs -> matchCon' q (length spine) $ matchCatchall $ failedMatch f stack ctrl- Def q es | isJust $ lookupCon q bs -> do- spine' <- elimsToSpine env es- runAM (evalValue blk (Def q []) emptyEnv (spine' <> spine) ctrl0)-- -- Case: not constructor or literal. In this case we are stuck.- _ -> stuck- where- -- If ffallThrough is set we take the catch-all (if any) rather than being stuck. I think- -- this happens for partial functions with --cubical (@saizan: is this true?).- stuck | ffallThrough bs = matchCatchall reallyStuck- | otherwise = reallyStuck-- reallyStuck = do- -- Compute new reason for being stuck. See Agda.Syntax.Internal.stuckOn for the logic.- blk' <- case blk of- Blocked{} -> return blk- NotBlocked r _ -> decodeClosure_ cl <&> \ v -> NotBlocked (stuckOn (Apply $ Arg i v) r) ()- stuckMatch blk' stack ctrl-- -- This the spine at this point in the matching. A catch-all match doesn't change the spine.- catchallSpine = spine0 <> [Apply $ Arg i p] <> spine1- where p = pureThunk cl -- cl is already a value so no need to thunk it.-- -- Push catch-all frame on the match stack if there is a catch-all (and we're not taking it- -- right now).- catchallStack = case fcatchallBranch bs of- Nothing -> stack- Just cc -> Catchall cc catchallSpine >: stack-- -- The matchX functions below all take an extra argument which is what to do if there is no- -- appropriate branch in the case tree. ifJust is maybe with a different argument order- -- letting you chain a bunch if maybe matches in if-then-elseif fashion.- (m `ifJust` f) z = maybe z f m-- -- Matching constructor: Switch to the Match state, inserting the constructor arguments in- -- the spine between spine0 and spine1.- matchCon c ci ar = matchCon' (conName c) ar- matchCon' q ar = lookupCon q bs `ifJust` \ cc ->- runAM (Match f cc (spine0 <> spine <> spine1) catchallStack ctrl)-- -- Catch-all: Don't add a Catchall to the match stack since this _is_ the catch-all.- matchCatchall = fcatchallBranch bs `ifJust` \ cc ->- runAM (Match f cc catchallSpine stack ctrl)-- -- Matching literal: Switch to the Match state. There are no arguments to add to the spine.- matchLit l = Map.lookup l (flitBranches bs) `ifJust` \ cc ->- runAM (Match f cc (spine0 <> spine1) catchallStack ctrl)-- -- Matching a 'suc' constructor: Insert the argument in the spine.- matchSuc = fsucBranch bs `ifJust` \ cc ->- runAM (Match f cc (spine0 <> spine <> spine1) catchallStack ctrl)-- -- Matching a non-zero natural number literal: Subtract one from the literal and- -- insert it in the spine for the Match state.- matchLitSuc n = fsucBranch bs `ifJust` \ cc ->- runAM (Match f cc (spine0 <> [Apply $ defaultArg arg] <> spine1) catchallStack ctrl)- where n' = n - 1- arg = pureThunk $ trueValue (Lit $ LitNat n') emptyEnv []-- -- Matching a literal 0. Simply calls matchCon with the zero constructor.- matchLitZero = matchCon (fromMaybe __IMPOSSIBLE__ zero) ConOSystem 0- -- If we have a nat literal we have builtin zero.-- -- Case: Match state. Here we look at the case tree and take the appropriate action:- -- - FFail: stuck- -- - FDone: evaluate body- -- - FEta: eta expand argument- -- - FCase on projection: pick corresponding branch and keep matching- -- - FCase on argument: push CaseK frame on control stack and evaluate argument- runAM' (Match f cc spine stack ctrl) = {-# SCC "runAM.Match" #-}- case cc of- -- Absurd match. You can get here for open terms.- FFail -> stuckMatch (NotBlocked AbsurdMatch ()) stack ctrl-- -- Matching complete. Compute the environment for the body and switch to the Eval state.- FDone xs body -> do- -- Don't ask me why, but not being strict in the spine causes a memory leak.- let (zs, env, !spine') = buildEnv xs spine- runAM (Eval (Closure Unevaled (lams zs body) env spine') ctrl)-- -- A record pattern match. This does not block evaluation (since that would violate eta- -- equality), so in this case we replace the argument with its projections in the spine and- -- keep matching.- FEta n fs cc ca ->- case splitAt n spine of -- Question: add lambda here? doesn't- (_, []) -> done Underapplied -- matter for equality, but might for- (spine0, Apply e : spine1) -> do -- rewriting or 'with'.- -- Replace e by its projections in the spine. And don't forget a- -- Catchall frame if there's a catch-all.- let projClosure (Arg ai f) = Closure Unevaled (Var 0 []) (extendEnv (unArg e) emptyEnv) [Proj ProjSystem f]- projs <- mapM (createThunk . projClosure) fs- let spine' = spine0 <> map (Apply . defaultArg) projs <> spine1- stack' = caseMaybe ca stack $ \ cc -> Catchall cc spine >: stack- runAM (Match f cc spine' stack' ctrl)- _ -> __IMPOSSIBLE__-- -- Split on nth elimination in the spine. Can be either a regular split or a copattern- -- split.- FCase n bs ->- case splitAt n spine of- -- If the nth elimination is not given, we're stuck.- (_, []) -> done Underapplied- -- Apply elim: push the current match on the control stack and evaluate the argument- (spine0, Apply e : spine1) ->- evalPointerAM (unArg e) [] $ CaseK f (argInfo e) bs spine0 spine1 stack : ctrl- -- Projection elim: in this case we must be in a copattern split and find the projection- -- in the case tree and keep going. If it's not there it might be because it's not the- -- original projection (issue #2265). If so look up the original projection instead.- -- That _really_ should be there since copattern splits cannot be partial. Except of- -- course, the user might still have written a partial function so we should check- -- partialDefs before throwing an impossible (#3012).- (spine0, Proj o p : spine1) ->- case lookupCon p bs <|> ((`lookupCon` bs) =<< op) of- Nothing- | 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)- (_, IApply{} : _) -> __IMPOSSIBLE__ -- Paths cannot be defined by pattern matching- where done why = stuckMatch (NotBlocked why ()) stack ctrl-- -- 'evalPointerAM p spine ctrl'. Evaluate the closure pointed to by 'p' applied to 'spine' with- -- the control stack 'ctrl'. If 'p' points to an unevaluated thunk, a 'BlackHole' is written to- -- the pointer and an 'UpdateThunk' frame is pushed to the control stack. In this case the- -- application to the spine has to be deferred until after the update through an 'ApplyK' frame.- evalPointerAM :: Pointer s -> Spine s -> ControlStack s -> ST s (Blocked Term)- evalPointerAM (Pure cl) spine ctrl = runAM (Eval (clApply cl spine) ctrl)- evalPointerAM (Pointer p) spine ctrl = readPointer p >>= \ case- BlackHole -> __IMPOSSIBLE__- Thunk cl@(Closure Unevaled _ _ _) | callByNeed -> do- blackHole p- runAM (Eval cl $ updateThunkCtrl p $ [ApplyK spine | not (null spine)] ++ ctrl)- Thunk cl -> runAM (Eval (clApply cl spine) ctrl)-- -- 'evalIApplyAM spine ctrl fallback' checks if any 'IApply x y r' has a canonical 'r' (i.e. 0 or 1),- -- in that case continues evaluating 'x' or 'y' with the rest of 'spine' and same 'ctrl'.- -- If no such 'IApply' is found we continue with 'fallback'.- evalIApplyAM :: Spine s -> ControlStack s -> ST s (Blocked Term) -> ST s (Blocked Term)- evalIApplyAM es ctrl fallback = go es- where- -- written as a worker/wrapper to possibly trigger some- -- specialization wrt fallback- go [] = fallback- go (IApply x y r : es) = do- br <- evalPointerAM r [] []- case iview $ ignoreBlocking br of- IZero -> evalPointerAM x es ctrl- IOne -> evalPointerAM y es ctrl- _ -> (<* br) <$> go es- go (e : es) = go es-- -- Normalise the spine and apply the closure to the result. The closure must be a value closure.- normaliseArgsAM :: Closure s -> Spine s -> ControlStack s -> ST s (Blocked Term)- normaliseArgsAM cl [] ctrl = runAM (Eval cl ctrl) -- nothing to do- normaliseArgsAM cl spine ctrl =- case firstHole spine of -- v Only projections, nothing to do. Note clApply_ and not clApply (or we'd loop)- Nothing -> runAM (Eval (clApply_ cl spine) ctrl)- Just (p, cxt) -> evalPointerAM p [] (NormaliseK : ArgK cl cxt : ctrl)-- -- Fall back to slow reduction. This happens if we encounter a definition that's not supported- -- by the machine (like a primitive function that does not work on literals), or a term that is- -- not supported (Level and Sort at the moment). In this case we decode the current- -- focus to a 'Term', call slow reduction and pack up the result in a value closure. If the top- -- of the control stack is a 'NormaliseK' and the focus is a value closure (i.e. already in- -- weak-head normal form) we call 'slowNormaliseArgs' and pop the 'NormaliseK' frame. Otherwise- -- we use 'slowReduceTerm' to compute a weak-head normal form.- fallbackAM :: AM s -> ST s (Blocked Term)- fallbackAM (Eval c ctrl) = do- v <- decodeClosure_ c- runAM (mkValue $ runReduce $ slow v)- where mkValue b = evalValue (() <$ b) (ignoreBlocking b) emptyEnv [] ctrl'- (slow, ctrl') = case ctrl of- NormaliseK : ctrl'- | Value{} <- isValue c -> (notBlocked <.> slowNormaliseArgs, ctrl')- _ -> (slowReduceTerm, ctrl)- fallbackAM _ = __IMPOSSIBLE__-- -- Applying rewrite rules to the current focus. This needs to decode the current focus, call- -- rewriting and pack the result back up in a closure. In case some rewrite rules actually fired- -- the next state is an unevaluated closure, otherwise it's a value closure.- rewriteAM :: AM s -> ST s (Blocked Term)- rewriteAM s@(Eval (Closure (Value blk) t env spine) ctrl)- | null rewr = runAM s- | otherwise = traceDoc ("R" <+> pretty s) $ do- v0 <- decodeClosure_ (Closure Unevaled t env [])- es <- decodeSpine spine- case runReduce (rewrite blk (applyE v0) rewr es) of- NoReduction b -> runAM (evalValue (() <$ b) (ignoreBlocking b) emptyEnv [] ctrl)- YesReduction _ v -> runAM (evalClosure v emptyEnv [] ctrl)- where rewr = case t of- Def f [] -> rewriteRules f- Con c _ [] -> rewriteRules (conName c)- _ -> __IMPOSSIBLE__- rewriteAM _ =- __IMPOSSIBLE__-- -- Add a NatSucK frame to the control stack. Pack consecutive suc's into a single frame.- sucCtrl :: ControlStack s -> ControlStack s- sucCtrl (NatSucK !n : ctrl) = NatSucK (n + 1) : ctrl- sucCtrl ctrl = NatSucK 1 : ctrl-- -- Add a UpdateThunk frame to the control stack. Pack consecutive updates into a single frame.- updateThunkCtrl :: STPointer s -> ControlStack s -> ControlStack s- updateThunkCtrl p (UpdateThunk ps : ctrl) = UpdateThunk (p : ps) : ctrl- updateThunkCtrl p ctrl = UpdateThunk [p] : ctrl-- -- When matching is stuck we return the closure from the 'MatchStack' with the appropriate- -- 'IsValue' set.- stuckMatch :: Blocked_ -> MatchStack s -> ControlStack s -> ST s (Blocked Term)- stuckMatch blk (_ :> cl) ctrl = rewriteAM (Eval (mkValue blk cl) ctrl)-- -- On a mismatch we find the next 'Catchall' on the control stack and- -- continue matching from there. If there isn't one we get an incomplete- -- matching error (or get stuck if the function is marked partial).- failedMatch :: QName -> MatchStack s -> ControlStack s -> ST s (Blocked Term)- 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 f) ()) cl) ctrl)- | f `elem` partialDefs = rewriteAM (Eval (mkValue (NotBlocked (MissingClauses f) ()) cl) ctrl)- | otherwise = rewriteAM (Eval (mkValue (NotBlocked ReallyNotBlocked ()) cl) ctrl) -- See #5396-- -- Some helper functions to build machine states and closures.- evalClosure t env spine = Eval (Closure Unevaled t env spine)- evalValue b t env spine = Eval (Closure (Value b) t env spine)- evalTrueValue = evalValue $ notBlocked ()- trueValue t env spine = Closure (Value $ notBlocked ()) t env spine- mkValue b = setIsValue (Value b)-- -- Building lambdas- lams :: [Arg String] -> Term -> Term- lams xs t = foldr lam t xs-- lam :: Arg String -> Term -> Term- lam x t = Lam (argInfo x) (Abs (unArg x) t)---- Pretty printing ----------------------------------------------------------instance Pretty a => Pretty (FastCase a) where- prettyPrec p (FBranches _cop cs suc ls m _) =- mparens (p > 0) $ vcat (prettyMap_ cs ++ prettyMap_ ls ++ prSuc suc ++ prC m)- where- prC Nothing = []- prC (Just x) = ["_ ->" <?> pretty x]-- prSuc Nothing = []- prSuc (Just x) = ["suc ->" <?> pretty x]--instance Pretty FastCompiledClauses where- pretty (FDone xs t) = ("done" <+> prettyList xs) <?> prettyPrec 10 t- pretty FFail = "fail"- pretty (FEta n _ cc ca) =- text ("eta " ++ show n ++ " of") <?>- vcat ("{} ->" <?> pretty cc :- [ "_ ->" <?> pretty cc | Just cc <- [ca] ])- pretty (FCase n bs) | fprojPatterns bs =- sep [ text $ "project " ++ show n- , nest 2 $ pretty bs- ]- pretty (FCase n bs) =- text ("case " ++ show n ++ " of") <?> pretty bs--instance Pretty a => Pretty (Thunk a) where- prettyPrec _ BlackHole = "<BLACKHOLE>"- prettyPrec p (Thunk cl) = prettyPrec p cl--instance Pretty (Pointer s) where- prettyPrec p = prettyPrec p . unsafeDerefPointer--instance Pretty (Closure s) where- prettyPrec _ (Closure Value{} (Lit (LitString unused)) _ _)- | unused == unusedPointerString = "_"- prettyPrec p (Closure isV t env spine) =- mparens (p > 9) $ fsep [ text tag- , nest 2 $ prettyPrec 10 t- , nest 2 $ prettyList $ zipWith envEntry [0..] (envToList env)- , nest 2 $ prettyList spine ]- where envEntry i c = text ("@" ++ show i ++ " =") <+> pretty c- tag = case isV of Value{} -> "V"; Unevaled -> "E"--instance Pretty (AM s) where- prettyPrec p (Eval cl ctrl) = prettyPrec p cl <?> prettyList ctrl- prettyPrec p (Match f cc sp stack ctrl) =- mparens (p > 9) $ sep [ "M" <+> pretty f- , nest 2 $ prettyList sp- , nest 2 $ prettyPrec 10 cc- , nest 2 $ pretty stack- , nest 2 $ prettyList ctrl ]--instance Pretty (CatchallFrame s) where- pretty Catchall{} = "Catchall"--instance Pretty (MatchStack s) where- pretty ([] :> _) = empty- pretty (ca :> _) = prettyList ca--instance Pretty (ControlFrame s) where- prettyPrec p (CaseK f _ _ _ _ mc) = mparens (p > 9) $ ("CaseK" <+> pretty (qnameName f)) <?> pretty mc- prettyPrec p (ForceK _ spine0 spine1) = mparens (p > 9) $ "ForceK" <?> prettyList (spine0 <> spine1)- prettyPrec p (EraseK _ sp0 sp1 sp2 sp3) = mparens (p > 9) $ sep [ "EraseK"- , nest 2 $ prettyList sp0- , nest 2 $ prettyList sp1- , nest 2 $ prettyList sp2- , nest 2 $ prettyList sp3 ]- prettyPrec _ (NatSucK n) = text ("+" ++ show n)- prettyPrec p (PrimOpK f _ vs cls _) = mparens (p > 9) $ sep [ "PrimOpK" <+> pretty f- , nest 2 $ prettyList vs- , nest 2 $ prettyList cls ]- prettyPrec p (UpdateThunk ps) = mparens (p > 9) $ "UpdateThunk" <+> text (show (length ps))- prettyPrec p (ApplyK spine) = mparens (p > 9) $ "ApplyK" <?> prettyList spine- prettyPrec p NormaliseK = "NormaliseK"- prettyPrec p (ArgK cl _) = mparens (p > 9) $ sep [ "ArgK" <+> prettyPrec 10 cl ]+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-all -dno-suppress-type-signatures -ddump-to-file -dno-typeable-binds #-}+{-# OPTIONS_GHC -fmax-worker-args=15 #-}+#if __GLASGOW_HASKELL__ > 902+{-# OPTIONS_GHC -fworker-wrapper-cbv #-}+#endif+++{-|++This module implements the Agda Abstract Machine used for compile-time reduction. It's a+call-by-need environment machine with an implicit heap maintained using 'STRef's. See the 'AM' type+below for a description of the machine.++Some other tricks that improves performance:++- Memoise getConstInfo.++ A big chunk of the time during reduction is spent looking up definitions in the signature. Any+ long-running reduction will use only a handful definitions though, so memoising getConstInfo is a+ big win.++- Optimised case trees.++ Since we memoise getConstInfo we can do some preprocessing of the definitions, returning a+ 'CompactDef' instead of a 'Definition'. In particular we streamline the case trees used for+ matching in a few ways:++ - Drop constructor arity information.+ - Use NameId instead of QName as map keys.+ - Special branch for natural number successor.++ None of these changes would make sense to incorporate into the actual case trees. The first two+ loses information that we need in other places and the third would complicate a lot of code+ working with case trees.++ 'CompactDef' also has a special representation for built-in/primitive+ functions that can be implemented as pure functions from 'Literal's.++-}+module Agda.TypeChecking.Reduce.Fast+ ( fastReduce, fastNormalise ) where++import Prelude hiding ((!!), null)++import Data.Foldable hiding (null)+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.Map.Strict as MapS+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.List as List+import Data.Text (Text)+import qualified Data.Text as T++import System.IO.Unsafe (unsafeDupablePerformIO)+import Data.IORef+import Data.STRef+import Data.Char++import Agda.Syntax.Common+import Agda.Syntax.Internal+import Agda.Syntax.Literal++import Agda.TypeChecking.CompiledClause+import Agda.TypeChecking.Monad hiding (Closure(..))+import Agda.TypeChecking.Reduce as R+import Agda.TypeChecking.Rewriting (rewrite)+import Agda.TypeChecking.Substitute++import Agda.Interaction.Options++import Agda.Utils.CallStack ( withCurrentCallStack )+import Agda.Utils.Char+import Agda.Utils.Float+import Agda.Utils.Lens+import Agda.Utils.List+import Agda.Utils.Maybe+import Agda.Utils.Maybe.Unboxable+import Agda.Utils.Memo (memoUnsafeInt)+import Agda.Utils.Monad+import Agda.Utils.Null (empty, null)+import Agda.Utils.Functor+import Agda.Syntax.Common.Pretty+import Agda.Utils.Size+import Agda.Utils.Zipper+import Agda.Utils.SmallSet qualified as SmallSet+import Agda.Utils.VarSet qualified as VarSet++import Agda.Utils.Impossible++import Debug.Trace++-- * Compact definitions++-- This is what the memoised getConstInfo returns. We essentially pick out only the+-- information needed for fast reduction from the definition.++data CompactDef =+ CompactDef { cdefUnconfirmed :: Bool+ , cdefDef :: CompactDefn+ , cdefRewriteRules :: RewriteRules+ }++data CompactDefn+ = CFun { cfunCompiled :: FastCompiledClauses, cfunProjection :: Maybe QName }+ | CCon { cconSrcCon :: ConHead, cconArity :: !Int }+ | CForce -- ^ primForce+ | CErase -- ^ primErase+ | CTyCon -- ^ Datatype or record type. Need to know this for primForce.+ | CAxiom -- ^ Axiom or abstract defn+ | CPrimOp !Int ([Literal] -> Term) (Maybe FastCompiledClauses)+ -- ^ Literals in reverse argument order+ | COther -- ^ In this case we fall back to slow reduction++data BuiltinEnv = BuiltinEnv+ { bZero, bSuc, bTrue, bFalse, bRefl :: Maybe ConHead+ , bPrimForce, bPrimErase :: Maybe QName }++-- | Compute a 'CompactDef' from a regular definition.+compactDef ::+ BuiltinEnv -> Definition -> Bool -> RewriteRules+ -> ReduceM CompactDef+compactDef bEnv def copatterns rewr = do++ shouldReduce <- shouldReduceDef (defName def)+ allowed <- viewTC eAllowedReductions++ let isConOrProj = case theDef def of+ Constructor{} -> True+ Function { funProjection = Right{} } -> True+ _ -> False++ let allowReduce =+ shouldReduce+ && (+ (RecursiveReductions `SmallSet.member` allowed)+ || (isConOrProj && ProjectionReductions `SmallSet.member` allowed)+ || (isInlineFun (theDef def) && InlineReductions `SmallSet.member` allowed)+ || (definitelyNonRecursive_ (theDef def) && (+ (copatterns && CopatternReductions `SmallSet.member` allowed)+ || (FunctionReductions `SmallSet.member` allowed))+ )+ )+ && (not (defNonterminating def) || SmallSet.member NonTerminatingReductions allowed)+ -- WARNING: don't use isPropM here because it relies on reduction,+ -- which causes an infinite loop.+ && (not $ isProp $ getSort $ defType def)+ && (not (isIrrelevant def))++ cdefn <-+ case theDef def of+ _ | not allowReduce -> pure CAxiom+ _ | Just (defName def) == bPrimForce bEnv -> pure CForce+ _ | Just (defName def) == bPrimErase bEnv ->+ case telView' (defType def) of+ TelV tel _ | natSize tel == 5 -> pure CErase+ | otherwise -> pure COther+ -- Non-standard equality. Fall back to slow reduce.+ _ | defBlocked def /= notBlocked_ -> pure COther -- Blocked definition+ 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 <$> either (const Nothing) Just proj }+ Function{funClauses = []} -> pure CAxiom+ Function{} -> pure COther -- Incomplete definition+ Datatype{dataClause = Nothing} -> pure CTyCon+ Record{recClause = Nothing} -> pure CTyCon+ Datatype{} -> pure COther -- TODO+ Record{} -> pure COther -- TODO+ Axiom{} -> pure CAxiom+ DataOrRecSig{} -> pure CAxiom+ AbstractDefn{} -> pure CAxiom+ GeneralizableVar{} -> __IMPOSSIBLE__+ PrimitiveSort{} -> pure COther -- TODO+ Primitive{}+ | not (FunctionReductions `SmallSet.member` allowed)+ -> pure CAxiom+ Primitive{ primName = name, primCompiled = cc } ->+ case name of+ -- "primShowInteger" -- integers are not literals++ -- Natural numbers+ PrimNatPlus -> mkPrim 2 $ natOp (+)+ PrimNatMinus -> mkPrim 2 $ natOp (\ x y -> max 0 (x - y))+ PrimNatTimes -> mkPrim 2 $ natOp (*)+ PrimNatDivSucAux -> mkPrim 4 $ natOp4 divAux+ PrimNatModSucAux -> mkPrim 4 $ natOp4 modAux+ PrimNatLess -> mkPrim 2 $ natRel (<)+ PrimNatEquality -> mkPrim 2 $ natRel (==)++ -- Word64+ PrimWord64ToNat -> mkPrim 1 $ \ [LitWord64 a] -> nat (fromIntegral a)+ PrimWord64FromNat -> mkPrim 1 $ \ [LitNat a] -> word (fromIntegral a)++ -- Levels+ -- "primLevelZero" -- levels are not literals+ -- "primLevelSuc" -- levels are not literals+ -- "primLevelMax" -- levels are not literals++ -- Floats+ PrimFloatInequality -> mkPrim 2 $ floatRel (<=)+ PrimFloatEquality -> mkPrim 2 $ floatRel (==)+ PrimFloatLess -> mkPrim 2 $ floatRel (<)+ PrimFloatIsInfinite -> mkPrim 1 $ floatPred isInfinite+ PrimFloatIsNaN -> mkPrim 1 $ floatPred isNaN+ PrimFloatIsNegativeZero -> mkPrim 1 $ floatPred isNegativeZero+ PrimFloatIsSafeInteger -> mkPrim 1 $ floatPred isSafeInteger+ -- "primFloatToWord64" -- returns a maybe+ -- "primFloatToWord64Injective" -- identities are not literals+ PrimNatToFloat -> mkPrim 1 $ \ [LitNat a] -> float (fromIntegral a)+ -- "primIntToFloat" -- integers are not literals+ -- "primFloatRound" -- integers and maybe are not literals+ -- "primFloatFloor" -- integers and maybe are not literals+ -- "primFloatCeiling" -- integers and maybe are not literals+ -- "primFloatToRatio" -- integers and sigma are not literals+ -- "primRatioToFloat" -- integers are not literals+ -- "primFloatDecode" -- integers and sigma are not literals+ -- "primFloatEncode" -- integers are not literals+ PrimFloatPlus -> mkPrim 2 $ floatOp (+)+ PrimFloatMinus -> mkPrim 2 $ floatOp (-)+ PrimFloatTimes -> mkPrim 2 $ floatOp (*)+ PrimFloatNegate -> mkPrim 1 $ floatFun negate+ PrimFloatDiv -> mkPrim 2 $ floatOp (/)+ PrimFloatSqrt -> mkPrim 1 $ floatFun sqrt+ PrimFloatExp -> mkPrim 1 $ floatFun exp+ PrimFloatLog -> mkPrim 1 $ floatFun log+ PrimFloatSin -> mkPrim 1 $ floatFun sin+ PrimFloatCos -> mkPrim 1 $ floatFun cos+ PrimFloatTan -> mkPrim 1 $ floatFun tan+ PrimFloatASin -> mkPrim 1 $ floatFun asin+ PrimFloatACos -> mkPrim 1 $ floatFun acos+ PrimFloatATan -> mkPrim 1 $ floatFun atan+ PrimFloatATan2 -> mkPrim 2 $ floatOp atan2+ PrimFloatSinh -> mkPrim 1 $ floatFun sinh+ PrimFloatCosh -> mkPrim 1 $ floatFun cosh+ PrimFloatTanh -> mkPrim 1 $ floatFun tanh+ PrimFloatASinh -> mkPrim 1 $ floatFun asinh+ PrimFloatACosh -> mkPrim 1 $ floatFun acosh+ PrimFloatATanh -> mkPrim 1 $ floatFun atanh+ PrimFloatPow -> mkPrim 2 $ floatOp (**)+ PrimShowFloat -> mkPrim 1 $ \ [LitFloat a] -> string (show a)++ -- Characters+ PrimCharEquality -> mkPrim 2 $ charRel (==)+ PrimIsLower -> mkPrim 1 $ charPred isLower+ PrimIsDigit -> mkPrim 1 $ charPred isDigit+ PrimIsAlpha -> mkPrim 1 $ charPred isAlpha+ PrimIsSpace -> mkPrim 1 $ charPred isSpace+ PrimIsAscii -> mkPrim 1 $ charPred isAscii+ PrimIsLatin1 -> mkPrim 1 $ charPred isLatin1+ PrimIsPrint -> mkPrim 1 $ charPred isPrint+ PrimIsHexDigit -> mkPrim 1 $ charPred isHexDigit+ PrimToUpper -> mkPrim 1 $ charFun toUpper+ PrimToLower -> mkPrim 1 $ charFun toLower+ PrimCharToNat -> mkPrim 1 $ \ [LitChar a] -> nat (fromIntegral (fromEnum a))+ PrimNatToChar -> mkPrim 1 $ \ [LitNat a] -> char (integerToChar a)+ PrimShowChar -> mkPrim 1 $ \ [a] -> string (prettyShow a)++ -- Strings+ -- "primStringToList" -- lists are not literals (TODO)+ -- "primStringFromList" -- lists are not literals (TODO)+ PrimStringAppend -> mkPrim 2 $ \ [LitString a, LitString b] -> text (b <> a)+ PrimStringEquality -> mkPrim 2 $ \ [LitString a, LitString b] -> bool (b == a)+ PrimShowString -> mkPrim 1 $ \ [a] -> string (prettyShow a)++ -- "primErase"+ -- "primForce"+ -- "primForceLemma"+ PrimQNameEquality -> mkPrim 2 $ \ [LitQName a, LitQName b] -> bool (b == a)+ PrimQNameLess -> mkPrim 2 $ \ [LitQName a, LitQName b] -> bool (b < a)+ PrimShowQName -> mkPrim 1 $ \ [LitQName a] -> string (prettyShow a)+ -- "primQNameFixity" -- fixities are not literals (TODO)+ PrimMetaEquality -> mkPrim 2 $ \ [LitMeta _ a, LitMeta _ b] -> bool (b == a)+ PrimMetaLess -> mkPrim 2 $ \ [LitMeta _ a, LitMeta _ b] -> bool (b < a)+ PrimShowMeta -> mkPrim 1 $ \ [LitMeta _ a] -> string (prettyShow a)++ _ -> pure COther+ where+ fcc = fastCompiledClauses bEnv <$> cc+ mkPrim n op = pure $ CPrimOp n op fcc++ divAux k m n j = k + div (max 0 $ n + m - j) (m + 1)+ modAux k m n j | n > j = mod (n - j - 1) (m + 1)+ | otherwise = k + n++ ~(Just true) = bTrue bEnv <&> \ c -> Con c ConOSystem []+ ~(Just false) = bFalse bEnv <&> \ c -> Con c ConOSystem []++ bool a = if a then true else false+ nat a = Lit . LitNat $! a+ word a = Lit . LitWord64 $! a+ float a = Lit . LitFloat $! a+ text a = Lit . LitString $! a+ string a = text (T.pack a)+ char a = Lit . LitChar $! a++ -- Remember reverse order!+ natOp f [LitNat a, LitNat b] = nat (f b a)+ natOp _ _ = __IMPOSSIBLE__++ natOp4 f [LitNat a, LitNat b, LitNat c, LitNat d] = nat (f d c b a)+ natOp4 _ _ = __IMPOSSIBLE__++ natRel f [LitNat a, LitNat b] = bool (f b a)+ natRel _ _ = __IMPOSSIBLE__++ floatFun f [LitFloat a] = float (f a)+ floatFun _ _ = __IMPOSSIBLE__++ floatOp f [LitFloat a, LitFloat b] = float (f b a)+ floatOp _ _ = __IMPOSSIBLE__++ floatPred f [LitFloat a] = bool (f a)+ floatPred _ _ = __IMPOSSIBLE__++ floatRel f [LitFloat a, LitFloat b] = bool (f b a)+ floatRel _ _ = __IMPOSSIBLE__++ charFun f [LitChar a] = char (f a)+ charFun _ _ = __IMPOSSIBLE__++ charPred f [LitChar a] = bool (f a)+ charPred _ _ = __IMPOSSIBLE__++ charRel f [LitChar a, LitChar b] = bool (f b a)+ charRel _ _ = __IMPOSSIBLE__++ return $+ CompactDef { cdefUnconfirmed = defTerminationUnconfirmed def+ , cdefDef = cdefn+ , cdefRewriteRules = if allowReduce then rewr else []+ }++-- Faster case trees ------------------------------------------------------++data FastCase c = FBranches+ { fprojPatterns :: Bool+ -- ^ We are constructing a record here (copatterns).+ -- 'conBranches' lists projections.+ , fconBranches :: Map NameId c+ -- ^ Map from constructor (or projection) names to their arity+ -- and the case subtree. (Projections have arity 0.)+ , fsucBranch :: Maybe c+ , flitBranches :: Map Literal c+ -- ^ Map from literal to case subtree.+ , fcatchallBranch :: Maybe c+ -- ^ (Possibly additional) catch-all clause.+ , ffallThrough :: Bool+ -- ^ (if True) In case of non-canonical argument use catchallBranch.+ }++--UNUSED Liang-Ting Chen 2019-07-16+--noBranches :: FastCase a+--noBranches = FBranches{ fprojPatterns = False+-- , fconBranches = Map.empty+-- , fsucBranch = Nothing+-- , flitBranches = Map.empty+-- , fcatchallBranch = Nothing+-- , ffallThrough = False }++-- | Case tree with bodies.++data FastCompiledClauses+ = FCase !Int (FastCase FastCompiledClauses)+ -- ^ @Case n bs@ stands for a match on the @n@-th argument+ -- (counting from zero) with @bs@ as the case branches.+ -- If the @n@-th argument is a projection, we have only 'conBranches'+ -- with arity 0.+ | FEta !Int [Arg QName] FastCompiledClauses (Maybe FastCompiledClauses)+ -- ^ Match on record constructor. Can still have a catch-all though. Just+ -- contains the fields, not the actual constructor.+ | FDone (CCDone Term)+ -- ^ See 'Done'.+ -- @FDone (CCDone _ mr xs b)@ stands for the body @b@ where the @xs@ contains hiding+ -- and name suggestions for the free variables. This is needed to build+ -- lambdas on the right hand side for partial applications which can+ -- still reduce.+ -- @mr@ indicates whether this leaf containts recursive mutually recursive calls.+ | FFail+ -- ^ Absurd case.++fastCompiledClauses :: BuiltinEnv -> CompiledClauses -> FastCompiledClauses+fastCompiledClauses bEnv cc =+ case cc of+ Fail{} -> FFail+ Done_ done -> FDone done+ Case (Arg _ n) Branches{ etaBranch = Just (c, cc), catchallBranch = ca } ->+ FEta n (conFields c) (fastCompiledClauses bEnv $ content cc) (fastCompiledClauses bEnv <$> ca)+ Case (Arg _ n) bs -> FCase n (fastCase bEnv bs)++fastCase :: BuiltinEnv -> Case CompiledClauses -> FastCase FastCompiledClauses+fastCase env (Branches proj con _ lit wild fT _) =+ FBranches+ { fprojPatterns = proj+ , fconBranches = Map.mapKeysMonotonic nameId $ fmap (fastCompiledClauses env . content) (stripSuc con)+ , fsucBranch = fmap (fastCompiledClauses env . content) $ flip Map.lookup con . conName =<< bSuc env+ , flitBranches = fmap (fastCompiledClauses env) lit+ , ffallThrough = Just True == fT+ , fcatchallBranch = fmap (fastCompiledClauses env) wild }+ where+ stripSuc | Just c <- bSuc env = Map.delete (conName c)+ | otherwise = id+++{-# INLINE lookupCon #-}+lookupCon :: QName -> FastCase c -> Maybe c+lookupCon c (FBranches _ cons _ _ _ _) = Map.lookup (nameId c) cons++-- QName memo -------------------------------------------------------------++{-# NOINLINE memoQName #-}+memoQName :: (QName -> a) -> (QName -> a)+memoQName f = unsafeDupablePerformIO $ do+ tbl <- newIORef Map.empty+ return (unsafeDupablePerformIO . f' tbl)+ where+ f' tbl x = do+ let i = nameId x+ m <- readIORef tbl+ case Map.lookup i m of+ Just y -> return y+ Nothing -> do+ let y = f x+ writeIORef tbl $! Map.insert i y m+ return y++-- * Fast reduction++data Normalisation = WHNF | NF+ deriving (Eq)++-- | The entry point to the reduction machine.+fastReduce :: Term -> ReduceM (Blocked Term)+fastReduce = fastReduce' WHNF++fastNormalise :: Term -> ReduceM Term+fastNormalise v = ignoreBlocking <$> fastReduce' NF v++fastReduce' :: Normalisation -> Term -> ReduceM (Blocked Term)+fastReduce' norm v = do+ tcState <- getTCState+ let name (Con c _ _) = c+ name _ = __IMPOSSIBLE__++ -- Gather builtins using 'BuiltinAccess' rather than with the default+ -- 'HasBuiltins ReduceM' instance. This increases laziness, allowing us to+ -- avoid costly builtin lookups unless needed.+ builtinName = fmap name . runBuiltinAccess tcState . getBuiltin'+ primitiveName = fmap primFunName . runBuiltinAccess tcState . getPrimitive'++ zero = builtinName builtinZero+ suc = builtinName builtinSuc+ true = builtinName builtinTrue+ false = builtinName builtinFalse+ refl = builtinName builtinRefl++ force = primitiveName PrimForce+ erase = primitiveName PrimErase++ bEnv = BuiltinEnv { bZero = zero, bSuc = suc, bTrue = true, bFalse = false, bRefl = refl,+ bPrimForce = force, bPrimErase = erase }+ rwr <- rewritingOption+ rwrLoc <- localRewritingOption++ constInfo <- case rwr || rwrLoc of -- András 2026-04-06: TODO more fine-grained choice+ True -> memoQName <$!> unKleisli \f -> do+ info <- getConstInfo f+ copatterns <- defCopatternLHS f info+ rewr <- getAllRewriteRulesForDefHead f+ compactDef bEnv info copatterns rewr+ False -> memoQName <$!> unKleisli \f -> do+ info <- getConstInfo f+ let copatterns = defCopatternLHS' info+ compactDef bEnv info copatterns []++ localRewr <- case rwrLoc of+ True -> memoUnsafeInt <$!> unKleisli getAllRewriteRulesForVarHead+ False -> pure (\_ -> [])++ ReduceM \redEnv ->+ reduceTm redEnv bEnv constInfo localRewr norm v+++-- * Closures++-- | The abstract machine represents terms as closures containing a 'Term', an environment, and a+-- spine of eliminations. Note that the environment doesn't necessarily bind all variables in the+-- term. The variables in the context in which the abstract machine is started are free in+-- closures. The 'IsValue' argument tracks whether the closure is in weak-head normal form.+data Closure s+ = Closure IsValue Term (Env s) (Spine s)+ -- ^ The environment applies to the 'Term' argument. The spine contains closures+ -- with their own environments.+ | BlackHole++-- | A thunk can be a 'BlackHole' while a plain 'Closure' can't. This is not enforced in types. We+-- could distinguish these by making 'Closure' an indexed GADT, but I don't think it's worth it.+type Thunk s = Closure s++-- | Used to track if a closure is @Unevaluated@ or a @Value@ (in weak-head normal form), and if so+-- why it cannot reduce further.+data IsValue = Value Blocked_ | Unevaled++#if __GLASGOW_HASKELL__ < 906+data SElim s+ = SApply !ArgInfo !(Pointer s)+ | SProj !ProjOrigin !QName+ | SIApply !(Pointer s)+ !(Pointer s)+ !(Pointer s)+#else+data SElim s+ = SApply !ArgInfo {-# UNPACK #-} !(Pointer s)+ | SProj !ProjOrigin !QName+ | SIApply {-# UNPACK #-} !(Pointer s)+ {-# UNPACK #-} !(Pointer s)+ {-# UNPACK #-} !(Pointer s)+#endif++sElimToElim :: SElim s -> Elim' (Pointer s)+sElimToElim = \case+ SApply i t -> Apply (Arg i t)+ SProj o x -> Proj o x+ SIApply l r t -> IApply l r t++-- | The spine is a list of eliminations. Application eliminations contain pointers.+type Spine s = [SElim s]++isValue :: Closure s -> IsValue+isValue (Closure isV _ _ _) = isV+isValue _ = __IMPOSSIBLE__++sAllApplyElims :: Spine s -> Maybe# [Pointer s]+sAllApplyElims = \case+ [] -> Just# []+ SApply _ p : es -> case sAllApplyElims es of+ Nothing# -> Nothing#+ Just# ps -> Just# (p:ps)+ SIApply _ _ p : es -> case sAllApplyElims es of+ Nothing# -> Nothing#+ Just# ps -> Just# (p:ps)+ _ -> Nothing#++setIsValue :: IsValue -> Closure s -> Closure s+setIsValue isV (Closure _ t env spine) = Closure isV t env spine+setIsValue isV _ = __IMPOSSIBLE__++-- | Apply a closure to a spine of eliminations. Note that this does not preserve the 'IsValue'+-- field.+clApply :: Closure s -> Spine s -> Closure s+clApply c [] = c+clApply (Closure _ t env es) es' = Closure Unevaled t env (es ++! es')+clApply _ _ = __IMPOSSIBLE__++-- | Apply a closure to a spine, preserving the 'IsValue' field. Use with care, since usually+-- eliminations do not preserve the value status.+clApply_ :: Closure s -> Spine s -> Closure s+clApply_ c [] = c+clApply_ (Closure b t env es) es' = Closure b t env (es ++! es')+clApply_ _ _ = __IMPOSSIBLE__++-- * Pointers and thunks++-- | Spines and environments contain pointers to closures to enable call-by-need evaluation.+data Pointer s = Pure (Closure s)+ -- ^ Not a pointer. Used for closures that do not need to be shared to avoid+ -- unnecessary updates.+ | Pointer {-# UNPACK #-} !(STPointer s)+ -- ^ An actual pointer is an 'STRef' to a 'Thunk'. The thunk is set to 'BlackHole'+ -- during the evaluation of its contents to make debugging loops easier.++type STPointer s = STRef s (Thunk s)++thunk :: Closure s -> Thunk s+thunk = id++derefPointer :: Pointer s -> ST s (Thunk s)+derefPointer (Pure cl) = return $ thunk cl+derefPointer (Pointer ptr) = readSTRef ptr++-- | In most cases pointers that we dereference do not contain black holes.+derefPointer_ :: Pointer s -> ST s (Closure s)+derefPointer_ ptr =+ derefPointer ptr <&> \case+ BlackHole -> __IMPOSSIBLE__+ cl -> cl++-- | Only use for debug printing!+unsafeDerefPointer :: Pointer s -> Thunk s+unsafeDerefPointer (Pure x) = thunk x+unsafeDerefPointer (Pointer p) = unsafeDupablePerformIO (unsafeSTToIO (readSTRef p))++readPointer :: STPointer s -> ST s (Thunk s)+readPointer = readSTRef++storePointer :: STPointer s -> Closure s -> ST s ()+storePointer ptr !cl = writeSTRef ptr (thunk cl)+ -- Note the strict match. To prevent leaking memory in case of unnecessary updates.++blackHole :: STPointer s -> ST s ()+blackHole ptr = writeSTRef ptr BlackHole++-- | Create a thunk. If the closure is a naked variable we can reuse the pointer from the+-- environment to avoid creating long pointer chains.+createThunk :: Closure s -> ST s (Pointer s)+createThunk cl@(Closure _ (Var x []) env []) =+ lookupEnv x env (\p -> return p)+ (\_ -> Pointer <$!> newSTRef (thunk cl))+createThunk cl = Pointer <$!> newSTRef (thunk cl)++-- | Create a thunk that is not shared or updated.+pureThunk :: Closure s -> Pointer s+pureThunk = Pure++-- * Environments++-- | The environment of a closure binds pointers to deBruijn indicies.+newtype Env s = Env [Pointer s]++emptyEnv :: Env s+emptyEnv = Env []+--UNUSED Liang-Ting Chen 2019-07-16+--isEmptyEnv :: Env s -> Bool+--isEmptyEnv (Env xs) = null xs++envSize :: Env s -> Int+envSize (Env xs) = length xs++envToList :: Env s -> [Pointer s]+envToList (Env xs) = xs++extendEnv :: Pointer s -> Env s -> Env s+extendEnv p (Env xs) = Env (p : xs)++{-# INLINE lookupEnv #-}+lookupEnv :: Int -> Env s -> (Pointer s -> a) -> (() -> a) -> a+lookupEnv i (Env e) found notfound = go i e where+ go 0 (p:ps) = found p+ go i (p:ps) = go (i - 1) ps+ go _ _ = notfound ()++-- * The Agda Abstract Machine++-- The abstract machine state has two states 'Eval' and 'Match' that determine what the machine is+-- currently working on: evaluating a closure in the Eval state and matching a spine against a+-- case tree in the Match state. Both states contain a 'ControlStack' of continuations for what to+-- do next. The heap is maintained implicitly using 'STRef's, hence the @s@ parameter.++-- | Evaluate the given closure (the focus) to weak-head normal form. If the 'IsValue'+-- field of the closure is 'Value' we look at the control stack for what to do. Being+-- strict in the control stack is important! We can spend a lot of steps with+-- unevaluated closures (where we update, but don't look at the control stack). For+-- instance, long chains of 'suc' constructors.+data Eval s = Eval !(Closure s) !(ControlStack s)++-- | @Match f cc spine stack ctrl@ Match the arguments @spine@ against the case tree+-- @cc@. The match stack contains a (possibly empty) list of 'Catchall' frames and a+-- closure to return in case of a stuck match.+data Match s = Match QName FastCompiledClauses (Spine s) {-# UNPACK #-} !(MatchStack s) !(ControlStack s)++data CatchallFrames s+ = CAFNil+ | CAFCons {-# UNPACK #-} !(CatchallFrame s) !(CatchallFrames s)++-- | The control stack for matching. Contains a list of CatchallFrame's and the closure to return in+-- case of a stuck match.+data MatchStack s = !(CatchallFrames s) :> (Closure s)+infixr 2 :>, >:++(>:) :: CatchallFrame s -> MatchStack s -> MatchStack s+(>:) c (cs :> cl) = CAFCons c cs :> cl+-- Previously written as:+-- c >: cs :> cl = c : cs :> cl+--+-- However, some versions/tools fail to parse infix data constructors properly.+-- For example, stylish-haskell@0.9.2.1 fails with the following error:+-- Language.Haskell.Stylish.Parse.parseModule: could not parse+-- src/full/Agda/TypeChecking/Reduce/Fast.hs: ParseFailed (SrcLoc+-- "<unknown>.hs" 625 1) "Parse error in pattern: "+--+-- See https://ghc.haskell.org/trac/ghc/ticket/10018 which may be related.++data CatchallFrame s = Catchall FastCompiledClauses (Spine s)+ -- ^ @Catchall cc spine@. Case trees are not fully expanded, that is,+ -- inner matches can be partial and covered by a catch-all at a higher+ -- level. This catch-all is represented on the match stack as a+ -- @Catchall@. @cc@ is the case tree in the catch-all case and @spine@ is+ -- the value of the pattern variables at the point of the catch-all.++-- An Elim' with a hole.+data ElimZipper a = ApplyCxt ArgInfo+ | IApplyType a a | IApplyFst a a | IApplySnd a a+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++instance Zipper (ElimZipper (Pointer s)) where+ type Carrier (ElimZipper (Pointer s)) = SElim s+ type Element (ElimZipper (Pointer s)) = Pointer s++ firstHole (SApply i arg) = Just (arg, ApplyCxt i)+ firstHole (SIApply a x y) = Just (a, IApplyType x y)+ firstHole SProj{} = Nothing++ plugHole x (ApplyCxt i) = SApply i x+ plugHole a (IApplyType x y) = SIApply a x y+ plugHole x (IApplyFst a y) = SIApply a x y+ plugHole y (IApplySnd a x) = SIApply a x y++ nextHole a (IApplyType x y) = Right (x, IApplyFst a y)+ nextHole x (IApplyFst a y) = Right (y, IApplySnd a x)+ nextHole y (IApplySnd a x) = Left (SIApply a x y)+ nextHole x c@ApplyCxt{} = Left $! plugHole x c++-- | A spine with a single hole for a pointer.+type SpineContext s = ComposeZipper (ListZipper (SElim s))+ (ElimZipper (Pointer s))++-- | Control frames are continuations that act on value closures.+data ControlStack s+ = CaseK QName ArgInfo (FastCase FastCompiledClauses) (Spine s) (Spine s) {-# UNPACK #-} !(MatchStack s) !(ControlStack s)+ -- ^ @CaseK f i bs spine0 spine1 stack@. Pattern match on the focus (with+ -- arg info @i@) using the @bs@ case tree. @f@ is the name of the function+ -- doing the matching, and @spine0@ and @spine1@ are the values bound to+ -- the pattern variables to the left and right (respectively) of the+ -- focus. The match stack contains catch-all cases we need to consider if+ -- this match fails.+ | ArgK (Closure s) (SpineContext s) !(ControlStack s)+ -- ^ @ArgK cl cxt@. Used when computing full normal forms. The closure is+ -- the head and the context is the spine with the current focus removed.+ | NormaliseK !(ControlStack s)+ -- ^ Indicates that the focus should be evaluated to full normal form.+ | ForceK QName (Spine s) (Spine s) !(ControlStack s)+ -- ^ @ForceK f spine0 spine1@. Evaluating @primForce@ of the focus. @f@ is+ -- the name of @primForce@ and is used to build the result if evaluation+ -- gets stuck. @spine0@ are the level and type arguments and @spine1@+ -- contains (if not empty) the continuation and any additional+ -- eliminations.+ | EraseK QName (Spine s) (Spine s) (Spine s) (Spine s) !(ControlStack s)+ -- ^ @EraseK f spine0 spine1 spine2 spine3@. Evaluating @primErase@. The+ -- first contains the level and type arguments. @spine1@ and @spine2@+ -- contain at most one argument between them. If in @spine1@ it's the+ -- value closure of the first argument to be compared and if in @spine2@+ -- it's the unevaluated closure of the second argument.+ -- @spine3@ contains the proof of equality we are erasing. It is passed+ -- around but never actually inspected.+ | NatSucK Integer !(ControlStack s)+ -- ^ @NatSucK n@. Add @n@ to the focus. If the focus computes to a natural+ -- number literal this returns a new literal, otherwise it constructs @n@+ -- calls to @suc@.+ | PrimOpK QName ([Literal] -> Term) [Literal] [Pointer s] (Maybe FastCompiledClauses) !(ControlStack s)+ -- ^ @PrimOpK f op lits es cc@. Evaluate the primitive function @f@ using+ -- the Haskell function @op@. @op@ gets a list of literal values in+ -- reverse order for the arguments of @f@ and computes the result as a+ -- term. The already computed arguments (in reverse order) are @lits@ and+ -- @es@ are the arguments that should be computed after the current focus.+ -- In case of built-in functions with corresponding Agda implementations,+ -- @cc@ contains the case tree.+ | UpdateThunk [STPointer s] !(ControlStack s)+ -- ^ @UpdateThunk ps@. Update the pointers @ps@ with the value of the+ -- current focus.+ | ApplyK (Spine s) !(ControlStack s)+ -- ^ @ApplyK spine@. Apply the current focus to the eliminations in @spine@.+ -- This is used when a thunk needs to be updated with a partial+ -- application of a function.+ | EmptyK+ -- ^ Finished execution.++-- * Compilation and decoding++-- | The initial abstract machine state. Wrap the term to be evaluated in an empty closure. Note+-- that free variables of the term are treated as constants by the abstract machine. If computing+-- full normal form we start off the control stack with a 'NormaliseK' continuation.+compile :: Normalisation -> Term -> Eval s+compile nf t =+ let !k = if nf == NF then NormaliseK EmptyK else EmptyK in+ Eval (Closure Unevaled t emptyEnv []) k++decodePointer :: Pointer s -> ST s Term+decodePointer p = decodeClosure_ =<< derefPointer_ p++-- | Note: it's important to be lazy in the spine and environment when decoding. Hence the+-- 'unsafeInterleaveST' here and in 'decodeEnv', and the special version of 'parallelS' in+-- 'decodeClosure'.+decodeSpine :: Spine s -> ST s Elims+decodeSpine spine = unsafeInterleaveST $ go spine where+ go [] = pure []+ go (e:es) = case e of+ SApply i t -> do+ t <- decodePointer t+ (Apply (Arg i t):) <$!> go es+ SProj o x -> (Proj o x:) <$!> go es+ SIApply l r t -> do+ l <- decodePointer l+ r <- decodePointer r+ t <- decodePointer t+ (IApply l r t:) <$!> go es++decodeEnv :: Env s -> ST s [Term]+decodeEnv env = unsafeInterleaveST $ traverse decodePointer (envToList env)++decodeClosure_ :: Closure s -> ST s Term+decodeClosure_ = ignoreBlocking <.> decodeClosure++-- | Turning an abstract machine closure back into a term. This happens in three cases:+-- * when reduction is finished and we return the weak-head normal term to the outside world.+-- * when the abstract machine encounters something it cannot handle and falls back to the slow+-- reduction engine+-- * when there are rewrite rules to apply+decodeClosure :: Closure s -> ST s (Blocked Term)+decodeClosure (Closure isV t env spine) = do+ vs <- decodeEnv env+ es <- decodeSpine spine+ return $ applyE (applySubst (parS vs) t) es <$ b+ where+ parS = foldr' (:#) IdS -- parallelS is too strict+ b = case isV of+ Value b -> b+ Unevaled -> notBlocked () -- only when falling back to slow reduce in which case the+ -- blocking tag is immediately discarded+decodeClosure _ = __IMPOSSIBLE__++-- | Turn a list of internal syntax eliminations into a spine. This builds closures and allocates+-- thunks for all the 'Apply' elims. We append the result onto the @Spine s@ argument.+elimsToSpine :: Env s -> Elims -> Spine s -> ST s (Spine s)+elimsToSpine env es sp0 = goETS es env sp0 where+ -- We don't preserve free variables of closures (in the sense of their+ -- decoding), since we freely add things to the spines.+ unknownFVs i+ | getFreeVariables i == unknownFreeVariables = i+ | otherwise = setFreeVariables unknownFreeVariables i++ -- Going straight for a value for literals is mostly to make debug traces+ -- less verbose and doesn't really buy anything performance-wise.+ closure _ _ t@Lit{} = let !v = Value $! notBlocked () in Closure v t emptyEnv []+ closure env fv t = let !env' = trimEnvironment fv env in Closure Unevaled t env' []++ goETS (e:es) env sp0 = case e of+ (Apply (Arg i t)) -> do+ !t <- createThunk (closure env (getFreeVariables i) t)+ let !i' = unknownFVs i+ (SApply i' t:) <$!> goETS es env sp0+ (Proj o f) -> (SProj o f:) <$!> goETS es env sp0+ (IApply a x y) -> do+ let mkThunk = createThunk . closure env UnknownFVs+ !e <- SIApply <$!> mkThunk a <*!> mkThunk x <*!> mkThunk y+ (e:) <$!> goETS es env sp0+ goETS [] _ sp0 = pure sp0+++-- | Trim unused entries from an environment. Currently only trims closed terms for performance+-- reasons.+trimEnvironment :: FreeVariables -> Env s -> Env s+trimEnvironment UnknownFVs env = env+trimEnvironment (KnownFVs fvs) env+ | null fvs = emptyEnv+ -- Environment trimming is too expensive (costs 50% on some benchmarks), and while it does make+ -- some cases run in constant instead of linear space you need quite contrived examples to+ -- notice the effect.+ | otherwise = env -- Env $ trim 0 $ envToList env+ -- where+ -- -- Important: strict enough that the trimming actually happens+ -- trim _ [] = []+ -- trim i (p : ps)+ -- | VarSet.member i fvs = (p :) $! trim (i + 1) ps+ -- | otherwise = (unusedPointer :) $! trim (i + 1) ps++-- | Build an environment for a body with some given free variables from a spine of arguments.+-- Returns a triple containing+-- * the left-over variable names (in case of partial application)+-- * the environment+-- * the remaining spine (in case of over-application)+buildEnv :: [Arg String] -> Spine s -> ([Arg String], Env s, Spine s)+buildEnv xs spine = go xs spine emptyEnv+ where+ go [] !sp !env = ([], env, sp)+ go xs0@(x : xs) sp env = case sp of+ [] -> (xs0, env, sp)+ SApply _ c : sp -> go xs sp (c `extendEnv` env)+ SIApply x y r : sp -> go xs sp (r `extendEnv` env)+ _ -> __IMPOSSIBLE__++unusedPointerString :: Text+unusedPointerString = T.pack (show (withCurrentCallStack Impossible))++unusedPointer :: Pointer s+unusedPointer = Pure (Closure (Value $ notBlocked ())+ (Lit (LitString unusedPointerString)) emptyEnv [])++-- * Running the abstract machine++-- | Evaluating a term in the abstract machine. It gets the type checking state and environment in+-- the 'ReduceEnv' argument, some precomputed built-in mappings in 'BuiltinEnv', the memoised+-- 'getConstInfo' function, a memoised function to lookup local rewrite rules, and a term to+-- reduce. The result is the weak-head normal form of the term with an attached blocking tag.+reduceTm ::+ ReduceEnv -> BuiltinEnv -> (QName -> CompactDef) -> (Nat -> RewriteRules)+ -> Normalisation -> Term -> Blocked Term+reduceTm rEnv bEnv !constInfo !localRewr normalisation = compileAndRun . traceDoc "-- fast reduce --"+ where+ -- Helpers to get information from the ReduceEnv.+ 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+ 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 = (redEnv rEnv ^. eCallByNeed) && not (optCallByName $ redSt rEnv ^. stPragmaOptions)+ iview = runReduce intervalView'++ runReduce :: ReduceM a -> a+ runReduce m = unReduceM m rEnv++#ifdef DEBUG+ -- Debug output. Taking care that we only look at the verbosity level once.+ hasVerb tag lvl = unReduceM (hasVerbosity tag lvl) rEnv+ doDebug = hasVerb "tc.reduce.fast" 110+ traceDoc :: Doc -> a -> a+ traceDoc+ | doDebug = trace . show+ | otherwise = const id++ -- Run the machine in a given state. Prints the state if the right verbosity level is active.+ runEval :: Eval s -> ST s (Blocked Term)+ runEval = if doDebug then \s -> trace (prettyShow s) (runEval' s)+ else runEval'++ -- Run the machine in a given state. Prints the state if the right verbosity level is active.+ runMatch :: Match s -> ST s (Blocked Term)+ runMatch = if doDebug then \s -> trace (prettyShow s) (runMatch' s)+ else runMatch'+#else+ {-# INLINE traceDoc #-}+ traceDoc :: Doc -> a -> a+ traceDoc _ a = a++ {-# INLINE runEval #-}+ -- Run the machine in a given state. Prints the state if the right verbosity level is active.+ runEval :: Eval s -> ST s (Blocked Term)+ runEval = runEval'++ {-# INLINE runMatch #-}+ -- Run the machine in a given state. Prints the state if the right verbosity level is active.+ runMatch :: Match s -> ST s (Blocked Term)+ runMatch = runMatch'+#endif+++ -- Checking for built-in zero and suc+ BuiltinEnv{ bZero = zero, bSuc = suc, bRefl = refl0 } = bEnv+ conNameId = nameId . conName+ isZero = case zero of+ Nothing -> const False+ Just z -> (conNameId z ==) . conNameId+ isSuc = case suc of+ Nothing -> const False+ Just s -> (conNameId s ==) . conNameId++ -- If there's a non-standard equality (for instance doubly-indexed) we fall back to slow reduce+ -- for primErase and "unbind" refl.+ refl = refl0 >>= \ c -> if cconArity (cdefDef $ constInfo $ conName c) == 0+ then Just c else Nothing++ -- The entry point of the machine.+ compileAndRun :: Term -> Blocked Term+ compileAndRun t = runST (runEval (compile normalisation t))+++ -- The main function. This is where the stuff happens!+ runEval' :: Eval s -> ST s (Blocked Term)+ runEval' (Eval BlackHole _) = __IMPOSSIBLE__++ -- Base case: The focus is a value closure and the control stack is empty. Decode and return.+ runEval' (Eval cl@(Closure Value{} _ _ _) EmptyK) = decodeClosure cl++ -- Unevaluated closure: inspect the term and take the appropriate action. For instance,+ -- - Change to the 'Match' state if a definition+ -- - 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+ runEval' s@(Eval cl@(Closure Unevaled t env spine) ctrl) = {-# SCC "runEval" #-}++ case t of++ -- Case: definition. Enter 'Match' state if defined function or shift to evaluating an+ -- argument and pushing the appropriate control frame for primitive functions. Fall back to+ -- slow reduce for unsupported definitions.+ Def f [] ->+ evalIApplyAM spine ctrl $+ case cdefDef (constInfo f) of+ CFun{ cfunCompiled = cc } -> runMatch (Match f cc spine (CAFNil :> cl) ctrl)+ CAxiom -> rewriteEval done+ CTyCon -> rewriteEval done+ CCon{} -> runEval done -- Only happens for builtinSharp (which is a Def when you bind it)+ CForce | (spine0, SApply _ v : spine1) <- splitAt' 4 spine ->+ evalPointerAM v [] (ForceK f spine0 spine1 ctrl)+ CForce -> runEval done -- partially applied+ CErase | (spine0, SApply _ v : spine1 : spine2) <- splitAt' 2 spine ->+ evalPointerAM v [] (EraseK f spine0 [] [spine1] spine2 ctrl)+ CErase -> runEval done -- partially applied+ CPrimOp n op cc | length spine == n, -- PrimOps can't be over-applied. They don't+ Just# (v : vs) <- sAllApplyElims spine -> -- return functions or records.+ evalPointerAM v [] (PrimOpK f op [] vs cc ctrl)+ CPrimOp{} -> runEval done -- partially applied+ COther -> fallbackEval s++ -- Case: zero. Return value closure with literal 0.+ Con c i [] | isZero c ->+ runEval (evalTrueValue (Lit (LitNat 0)) emptyEnv spine ctrl)++ -- Case: suc. Suc is strict in its argument to make sure we return a literal whenever+ -- possible. Push a 'NatSucK' frame on the control stack and evaluate the argument.+ Con c i [] | isSuc c, SApply _ v : _ <- spine ->+ evalPointerAM v [] (sucCtrl ctrl)++ -- Case: constructor. Perform beta reduction if projected from, otherwise return a value.+ Con c i []+ -- Constructors of types in Prop are not represented as+ -- CCon, so this match might fail!+ | CCon{cconSrcCon = c', cconArity = ar} <- cdefDef (constInfo (conName c)) ->+ evalIApplyAM spine ctrl $ do+ let dontProject = rewriteEval (evalTrueValue (Con c' i []) env spine ctrl)++ let doProj p (f:fs) (a:sp) restOfElims+ | unArg f == p = case a of+ -- Andreas #2170: fit argToDontCare here?!+ SApply _ arg -> evalPointerAM arg restOfElims ctrl+ _ -> __IMPOSSIBLE__+ | otherwise = doProj p fs sp restOfElims+ doProj _ _ _ _ = __IMPOSSIBLE__++ let shouldProj sp 0 = case sp of+ SProj _ p : rest -> doProj p (conFields c) spine rest+ _ -> dontProject+ shouldProj (_ : sp) ar = shouldProj sp (ar - 1)+ shouldProj [] ar = dontProject++ shouldProj spine ar++ | otherwise -> runEval done++ -- Case: variable. Look up the variable in the environment and evaluate the resulting+ -- pointer. If the variable is not in the environment it's a free variable and we adjust the+ -- deBruijn index appropriately.+ Var x [] ->+ evalIApplyAM spine ctrl $+ lookupEnv x env+ (\p -> evalPointerAM p spine ctrl)+ (\_ -> rewriteEval $ evalValue (notBlocked ()) (Var (x - envSize env) []) emptyEnv spine ctrl)++ -- Case: lambda. Perform the beta reduction if applied. Otherwise it's a value.+ Lam h b ->+ case spine of+ [] -> runEval done+ elim : spine' ->+ let getArg (SApply _ v) = v+ getArg (SIApply _ _ v) = v+ getArg SProj{} = __IMPOSSIBLE__ in+ case b of+ Abs _ b -> runEval (evalClosure b (getArg elim `extendEnv` env) spine' ctrl)+ NoAbs _ b -> runEval (evalClosure b env spine' ctrl)++ -- Case: values. Literals and function types are already in weak-head normal form.+ -- We throw away the environment for literals mostly to make debug printing less verbose.+ -- And we know the spine is empty since literals cannot be applied or projected.+ Lit{} -> runEval (evalTrueValue t emptyEnv [] ctrl)+ Pi{} -> runEval done+ DontCare{} -> runEval done++ -- Case: non-empty spine. If the focused term has a non-empty spine, we shift the+ -- eliminations onto the spine.+ Def f es -> shiftElims (Def f []) emptyEnv env es+ Con c i es -> shiftElims (Con c i []) emptyEnv env es+ Var x es -> shiftElims (Var x []) env env es++ -- Case: metavariable. If it's instantiated evaluate the value. Meta instantiations are open+ -- terms with a specified list of free variables. buildEnv constructs the appropriate+ -- environment for the closure. Avoiding shifting spines for open metas+ -- save a bit of performance.+ MetaV m es -> evalIApplyAM spine ctrl $+ case getMetaInst m of+ Nothing ->+ runEval (Eval (mkValue (blocked m ()) cl) ctrl)+ Just (InstV i) -> do+ spine' <- elimsToSpine env es spine+ let (zs, env, !spine'') = buildEnv (instTel i) spine'+ runEval (evalClosure (lams zs (instBody i)) env spine'' ctrl)+ Just OpenMeta{} -> __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.+ Level{} -> fallbackEval s+ Sort{} -> fallbackEval s+ Dummy{} -> fallbackEval s++ where done = Eval (mkValue (notBlocked ()) cl) ctrl+ shiftElims t env0 env es = do+ spine' <- elimsToSpine env es spine+ runEval (evalClosure t env0 spine' ctrl)++ -- If the current focus is a value closure, we look at the control stack.++ -- Case NormaliseK: The focus is a weak-head value that should be fully normalised.+ runEval' s@(Eval cl@(Closure b t env spine) (NormaliseK ctrl)) =+ case t of+ Def _ [] -> normaliseArgsAM (Closure b t emptyEnv []) spine ctrl+ Con _ _ [] -> normaliseArgsAM (Closure b t emptyEnv []) spine ctrl+ Var _ [] -> normaliseArgsAM (Closure b t emptyEnv []) spine ctrl+ MetaV _ [] -> normaliseArgsAM (Closure b t emptyEnv []) spine ctrl++ Lit{} -> runEval done++ -- We might get these from fallbackEval+ Def f es -> shiftElims (Def f []) emptyEnv env es+ Con c i es -> shiftElims (Con c i []) emptyEnv env es+ Var x es -> shiftElims (Var x []) env env es+ MetaV m es -> shiftElims (MetaV m []) emptyEnv env es++ _ -> fallbackEval s -- fallbackEval knows about NormaliseK++ where done = Eval (mkValue (notBlocked ()) cl) ctrl+ shiftElims t env0 env es = do+ spine' <- elimsToSpine env es spine+ runEval (Eval (Closure b t env0 spine') (NormaliseK ctrl))++ -- Case: ArgK: We successfully normalised an argument. Start on the next argument, or if there+ -- isn't one we're done.+ runEval' (Eval cl (ArgK cl0 cxt ctrl)) =+ case nextHole (pureThunk cl) cxt of+ Left spine -> runEval (Eval (clApply_ cl0 spine) ctrl)+ Right (p, cxt') -> evalPointerAM p [] (NormaliseK (ArgK cl0 cxt' ctrl))++ -- Case: NatSucK m++ -- If literal add m to the literal,+ runEval' (Eval cl@(Closure Value{} (Lit (LitNat n)) _ _) (NatSucK m ctrl)) =+ runEval (evalTrueValue (Lit $! LitNat $! m + n) emptyEnv [] ctrl)++ -- otherwise apply 'suc' m times.+ runEval' (Eval cl (NatSucK m ctrl)) =+ runEval (Eval (mkValue (notBlocked ()) $ plus m cl) ctrl)+ where+ plus 0 cl = cl+ plus n cl =+ let !(Arg i arg) = defaultArg (pureThunk (plus (n - 1) cl)) in+ trueValue (Con (fromMaybe __IMPOSSIBLE__ suc) ConOSystem []) emptyEnv+ $ SApply i arg : []++ -- Case: PrimOpK++ -- If literal apply the primitive function if no more arguments, otherwise+ -- store the literal in the continuation and evaluate the next argument.+ runEval' (Eval (Closure _ (Lit a) _ _) (PrimOpK f op vs es cc ctrl)) =+ case es of+ [] -> runEval (evalTrueValue (op (a : vs)) emptyEnv [] ctrl)+ e : es' -> evalPointerAM e [] (PrimOpK f op (a : vs) es' cc ctrl)++ -- If not a literal we use the case tree if there is one, otherwise we are stuck.+ runEval' (Eval cl@(Closure (Value blk) _ _ _) (PrimOpK f _ vs es mcc ctrl)) =+ case mcc of+ Nothing -> rewriteEval (Eval stuck ctrl)+ Just cc -> runMatch (Match f cc spine (CAFNil :> notstuck) ctrl)+ where+ p = pureThunk cl+ lits = map' (pureThunk . litClos) (reverse vs)+ spine = map' (SApply defaultArgInfo) $! lits ++! (p : es)+ stuck = Closure (Value blk) (Def f []) emptyEnv spine+ notstuck = Closure Unevaled (Def f []) emptyEnv spine+ litClos l = trueValue (Lit l) emptyEnv []++ -- Case: ForceK. Here we need to check if the argument is a canonical form (i.e. not a variable+ -- or stuck function call) and if so apply the function argument to the value. If it's not+ -- canonical we are stuck.+ runEval' (Eval arg@(Closure (Value blk) t _ _) (ForceK pf spine0 spine1 ctrl))+ | isCanonical t =+ case spine1 of+ SApply _ k : spine' ->+ evalPointerAM k (elim : spine') ctrl+ [] -> -- Partial application of primForce to canonical argument, return λ k → k arg.+ runEval (evalTrueValue (lam (defaultArg "k") $ Var 0 [Apply (Arg defaultArgInfo (Var 1 []))])+ (argPtr `extendEnv` emptyEnv) [] ctrl)+ _ -> __IMPOSSIBLE__+ | otherwise = rewriteEval (Eval stuck ctrl)+ where+ argPtr = pureThunk arg+ elim = SApply defaultArgInfo argPtr+ spine' = spine0 ++! (elim : spine1)+ stuck = Closure (Value blk) (Def pf []) emptyEnv spine'++ isCanonical = \case+ Lit{} -> True+ Con{} -> True+ Lam{} -> True+ Pi{} -> True+ Sort{} -> True+ Level{} -> True+ DontCare{} -> True+ Dummy{} -> False+ MetaV{} -> False+ Var{} -> False+ Def q _ -- Type constructors (data/record) are considered canonical for 'primForce'.+ | CTyCon <- cdefDef (constInfo q) -> True+ | otherwise -> False++ -- Case: EraseK. We evaluate both arguments to values, then do a simple check for the easy+ -- cases and otherwise fall back to slow reduce.+ runEval' (Eval cl2@(Closure Value{} arg2 _ _) (EraseK f spine0 [SApply _ p1] _ spine3 ctrl)) =+ derefPointer_ p1 >>= \case+ BlackHole -> __IMPOSSIBLE__+ cl1@(Closure _ arg1 _ sp1) -> case (arg1, arg2) of+ (Lit l1, Lit l2) | l1 == l2, isJust refl ->+ runEval (evalTrueValue (Con (fromJust refl) ConOSystem []) emptyEnv [] ctrl)+ _ ->+ let !i = hide defaultArgInfo+ !spine = spine0 ++! map' (SApply i . pureThunk) [cl1, cl2] ++! spine3 in+ fallbackEval (evalClosure (Def f []) emptyEnv spine ctrl)+ runEval' (Eval cl1@(Closure Value{} _ _ _) (EraseK f spine0 [] [SApply _ p2] spine3 ctrl)) =+ let !i = hide defaultArgInfo+ !thcl1 = pureThunk cl1 in+ evalPointerAM p2 [] (EraseK f spine0 [SApply i thcl1] [] spine3 ctrl)+ runEval' (Eval _ (EraseK{})) =+ __IMPOSSIBLE__++ -- Case: UpdateThunk. Write the value to the pointers in the UpdateThunk frame.+ runEval' (Eval cl@(Closure Value{} _ _ _) (UpdateThunk ps ctrl)) =+ mapM_ (`storePointer` cl) ps >> runEval (Eval cl ctrl)++ -- Case: ApplyK. Application after thunk update. Add the spine from the control frame to the+ -- closure.+ runEval' (Eval cl@(Closure Value{} _ _ _) (ApplyK spine ctrl)) =+ runEval (Eval (clApply cl spine) ctrl)++ -- Case: CaseK. Pattern matching against a value. If it's a stuck value the pattern match is+ -- stuck and we return the closure from the match stack (see stuckMatch). Otherwise we need to+ -- find a matching branch switch to the Match state. If there is no matching branch we look for+ -- a Catchall in the match stack, or fail if there isn't one (see failedMatch). If the current+ -- branches contain a catch-all case we need to push a Catchall on the match stack if picking+ -- one of the other branches.+ runEval' (Eval cl@(Closure (Value blk) t env spine) ctrl0@(CaseK f i bs spine0 spine1 stack ctrl)) =+ {-# SCC "runEval.CaseK" #-}+ case blk of+ Blocked{} | null [()|Con{} <- [t]] -> stuck -- we might as well check the blocking tag first+ _ -> case t of+ -- Case: suc constructor+ Con c ci [] | isSuc c -> matchSuc $ matchCatchall $ failedMatch f stack ctrl++ -- Case: constructor+ Con c ci [] -> matchCon c ci (length spine) $ matchCatchall $ failedMatch f stack ctrl++ -- Case: non-empty elims. We can get here from a fallback (which builds a value without+ -- shifting arguments onto spine)+ Con c ci es -> do+ spine' <- elimsToSpine env es spine+ runEval (evalValue blk (Con c ci []) emptyEnv spine' ctrl0)+ -- Case: natural number literals. Literal natural number patterns are translated to+ -- suc-matches, so there is no need to try matchLit.+ Lit (LitNat 0) -> matchLitZero $ matchCatchall $ failedMatch f stack ctrl+ Lit (LitNat n) -> matchLitSuc n $ matchCatchall $ failedMatch f stack ctrl++ -- Case: literal+ Lit l -> matchLit l $ matchCatchall $ failedMatch f stack ctrl++ -- Case: hcomp+ Def q [] | isJust $ lookupCon q bs -> matchCon' q (length spine) $ matchCatchall $ failedMatch f stack ctrl+ Def q es | isJust $ lookupCon q bs -> do+ spine' <- elimsToSpine env es spine+ runEval (evalValue blk (Def q []) emptyEnv spine' ctrl0)++ -- Case: not constructor or literal. In this case we are stuck.+ _ -> stuck+ where+ -- If ffallThrough is set we take the catch-all (if any) rather than being stuck. I think+ -- this happens for partial functions with --cubical (@saizan: is this true?).+ stuck | ffallThrough bs = matchCatchall reallyStuck+ | otherwise = reallyStuck++ reallyStuck = do+ -- Compute new reason for being stuck. See Agda.Syntax.Internal.stuckOn for the logic.+ blk' <- case blk of+ Blocked{} -> return blk+ NotBlocked r _ -> decodeClosure_ cl <&> \ v -> NotBlocked (stuckOn (Apply $ Arg i v) r) ()+ stuckMatch blk' stack ctrl++ -- This the spine at this point in the matching. A catch-all match doesn't change the spine.+ catchallSpine = spine0 ++! (SApply i p : spine1)+ where p = pureThunk cl -- cl is already a value so no need to thunk it.++ -- Push catch-all frame on the match stack if there is a catch-all (and we're not taking it+ -- right now).+ catchallStack = case fcatchallBranch bs of+ Nothing -> stack+ Just cc -> Catchall cc catchallSpine >: stack++ -- The matchX functions below all take an extra argument which is what to do if there is no+ -- appropriate branch in the case tree. ifJust is maybe with a different argument order+ -- letting you chain a bunch if maybe matches in if-then-elseif fashion.+ (m `ifJust` f) z = maybe z f m++ -- Matching constructor: Switch to the Match state, inserting the constructor arguments in+ -- the spine between spine0 and spine1.+ matchCon c ci ar = matchCon' (conName c) ar+ matchCon' q ar = lookupCon q bs `ifJust` \ cc ->+ runMatch (Match f cc (spine0 ++! spine ++! spine1) catchallStack ctrl)++ -- Catch-all: Don't add a Catchall to the match stack since this _is_ the catch-all.+ matchCatchall = fcatchallBranch bs `ifJust` \ cc ->+ runMatch (Match f cc catchallSpine stack ctrl)++ -- Matching literal: Switch to the Match state. There are no arguments to add to the spine.+ matchLit l = Map.lookup l (flitBranches bs) `ifJust` \ cc ->+ runMatch (Match f cc (spine0 ++! spine1) catchallStack ctrl)++ -- Matching a 'suc' constructor: Insert the argument in the spine.+ matchSuc = fsucBranch bs `ifJust` \ cc ->+ runMatch (Match f cc (spine0 ++! spine ++! spine1) catchallStack ctrl)++ -- Matching a non-zero natural number literal: Subtract one from the literal and+ -- insert it in the spine for the Match state.+ matchLitSuc n = fsucBranch bs `ifJust` \ cc ->+ let !arg' = SApply defaultArgInfo arg in+ runMatch (Match f cc (spine0 ++! (arg' : spine1)) catchallStack ctrl)+ where n' = n - 1+ arg = pureThunk $ trueValue (Lit $ LitNat n') emptyEnv []++ -- Matching a literal 0. Simply calls matchCon with the zero constructor.+ matchLitZero = matchCon (fromMaybe __IMPOSSIBLE__ zero) ConOSystem 0+ -- If we have a nat literal we have builtin zero.+++ -- Case: Match state. Here we look at the case tree and take the appropriate action:+ -- - FFail: stuck+ -- - FDone: evaluate body+ -- - FEta: eta expand argument+ -- - FCase on projection: pick corresponding branch and keep matching+ -- - FCase on argument: push CaseK frame on control stack and evaluate argument+ runMatch' :: Match s -> ST s (Blocked Term)+ runMatch' (Match f cc spine stack ctrl) = {-# SCC "runMatch" #-}+ case cc of+ -- Absurd match. You can get here for open terms.+ FFail -> stuckMatch (NotBlocked AbsurdMatch ()) stack ctrl++ -- Matching complete. Compute the environment for the body and switch to the Eval state.+ FDone (CCDone _ mr xs body) -> do+ let allowedReductions = redEnv rEnv ^. eAllowedReductions+ let undo = stuckMatch (NotBlocked ReallyNotBlocked ()) stack ctrl+ let abort =+ couldBeRecursive mr+ && cdefUnconfirmed (constInfo f)+ && (UnconfirmedReductions `SmallSet.notMember` allowedReductions)+ if abort then undo else do+ let (!zs, !env, !spine') = buildEnv xs spine+ runEval (Eval (Closure Unevaled (lams zs body) env spine') ctrl)++ -- A record pattern match. This does not block evaluation (since that would violate eta+ -- equality), so in this case we replace the argument with its projections in the spine and+ -- keep matching.+ FEta n fs cc ca -> do++ -- Recurse down to the application, replace it by projections+ -- in the spine, rebuild the spine. If we don't have enough+ -- arguments, return Nothing#+ let go 0 (SApply _ e : spine1) = do Just# <$!> goFs fs e spine1+ go n (e : spine1) = go (n - 1) spine1 >>= \case+ Nothing# -> pure Nothing#+ Just# sp -> pure $! Just# $! e:sp+ go _ [] = pure Nothing#++ -- Replace e by its projections in the spine.+ goFs [] e spine1 = pure spine1+ goFs (f:fs) e spine1 = do+ let projClosure (Arg ai f) =+ Closure Unevaled (Var 0 []) (extendEnv e emptyEnv) [SProj ProjSystem f]+ !t <- SApply defaultArgInfo <$!> createThunk (projClosure f)+ (t:) <$!> goFs fs e spine1++ go n spine >>= \case+ Nothing# ->+ -- Question: add lambda here? doesn't matter for equality, but might for+ -- rewriting or 'with'+ done Underapplied+ Just# spine' -> do+ let !stack' = caseMaybe ca stack \cc -> Catchall cc spine >: stack+ runMatch (Match f cc spine' stack' ctrl)++ -- Split on nth elimination in the spine. Can be either a regular split or a copattern+ -- split.+ FCase n bs ->+ case splitAt' n spine of+ -- If the nth elimination is not given, we're stuck.+ (_, []) -> done Underapplied+ -- Apply elim: push the current match on the control stack and evaluate the argument+ (spine0, SApply i e : spine1) ->+ evalPointerAM e [] $ CaseK f i bs spine0 spine1 stack ctrl+ -- Projection elim: in this case we must be in a copattern split and find the projection+ -- in the case tree and keep going. If it's not there it might be because it's not the+ -- original projection (issue #2265). If so look up the original projection instead.+ -- That _really_ should be there since copattern splits cannot be partial. Except of+ -- course, the user might still have written a partial function so we should check+ -- partialDefs before throwing an impossible (#3012).+ (spine0, SProj o p : spine1) ->+ case lookupCon p bs <|> ((`lookupCon` bs) =<< op) of+ Nothing+ | f `elem` partialDefs -> stuckMatch (NotBlocked (MissingClauses f) ()) stack ctrl+ | otherwise -> __IMPOSSIBLE__+ Just cc -> runMatch (Match f cc (spine0 ++! spine1) stack ctrl)+ where CFun{ cfunProjection = op } = cdefDef (constInfo p)+ (_, SIApply{} : _) -> __IMPOSSIBLE__ -- Paths cannot be defined by pattern matching+++ where done why = stuckMatch (NotBlocked why ()) stack ctrl++ -- 'evalPointerAM p spine ctrl'. Evaluate the closure pointed to by 'p' applied to 'spine' with+ -- the control stack 'ctrl'. If 'p' points to an unevaluated thunk, a 'BlackHole' is written to+ -- the pointer and an 'UpdateThunk' frame is pushed to the control stack. In this case the+ -- application to the spine has to be deferred until after the update through an 'ApplyK' frame.+ evalPointerAM :: Pointer s -> Spine s -> ControlStack s -> ST s (Blocked Term)+ evalPointerAM (Pure cl) spine ctrl = runEval (Eval (clApply cl spine) ctrl)+ evalPointerAM (Pointer p) spine ctrl = readPointer p >>= \ case+ BlackHole -> __IMPOSSIBLE__+ cl@(Closure Unevaled _ _ _) | callByNeed -> do+ blackHole p+ let !ctrl' = if not (null spine) then ApplyK spine ctrl else ctrl+ runEval (Eval cl (updateThunkCtrl p ctrl'))+ cl@(Closure _ _ _ _) -> runEval (Eval (clApply cl spine) ctrl)++ {-# INLINE evalIApplyAM #-}+ -- 'evalIApplyAM spine ctrl fallback' checks if any 'IApply x y r' has a canonical 'r' (i.e. 0 or 1),+ -- in that case continues evaluating 'x' or 'y' with the rest of 'spine' and same 'ctrl'.+ -- If no such 'IApply' is found we continue with 'fallback'.+ evalIApplyAM :: Spine s -> ControlStack s -> ST s (Blocked Term) -> ST s (Blocked Term)+ evalIApplyAM es ctrl fallback = go es+ where+ -- written as a worker/wrapper to possibly trigger some+ -- specialization wrt fallback+ go [] = fallback+ go (SIApply x y r : es) = do+ br <- evalPointerAM r [] EmptyK+ case iview $ ignoreBlocking br of+ IZero -> evalPointerAM x es ctrl+ IOne -> evalPointerAM y es ctrl+ _ -> (<* br) <$> go es+ go (e : es) = go es++ -- Normalise the spine and apply the closure to the result. The closure must be a value closure.+ normaliseArgsAM :: Closure s -> Spine s -> ControlStack s -> ST s (Blocked Term)+ normaliseArgsAM cl [] ctrl = runEval (Eval cl ctrl) -- nothing to do+ normaliseArgsAM cl spine ctrl =+ case firstHole spine of -- v Only projections, nothing to do. Note clApply_ and not clApply (or we'd loop)+ Nothing -> runEval (Eval (clApply_ cl spine) ctrl)+ Just (p, cxt) -> evalPointerAM p [] (NormaliseK (ArgK cl cxt ctrl))++ -- Fall back to slow reduction. This happens if we encounter a definition that's not supported+ -- by the machine (like a primitive function that does not work on literals), or a term that is+ -- not supported (Level and Sort at the moment). In this case we decode the current+ -- focus to a 'Term', call slow reduction and pack up the result in a value closure. If the top+ -- of the control stack is a 'NormaliseK' and the focus is a value closure (i.e. already in+ -- weak-head normal form) we call 'slowNormaliseArgs' and pop the 'NormaliseK' frame. Otherwise+ -- we use 'slowReduceTerm' to compute a weak-head normal form.+ fallbackEval :: Eval s -> ST s (Blocked Term)+ fallbackEval (Eval c ctrl) = do+ v <- decodeClosure_ c+ runEval (mkValue $ runReduce $ slow v)+ where mkValue b = evalValue (() <$ b) (ignoreBlocking b) emptyEnv [] ctrl'+ (slow, ctrl') = case ctrl of+ NormaliseK ctrl'+ | Value{} <- isValue c -> (notBlocked <.> slowNormaliseArgs, ctrl')+ _ -> (slowReduceTerm, ctrl)++ -- Applying rewrite rules to the current focus. This needs to decode the current focus, call+ -- rewriting and pack the result back up in a closure. In case some rewrite rules actually fired+ -- the next state is an unevaluated closure, otherwise it's a value closure.+ rewriteEval :: Eval s -> ST s (Blocked Term)+ rewriteEval s@(Eval (Closure (Value blk) t env spine) ctrl)+ | null rewr = runEval s+ | otherwise = traceDoc ("R" <+> pretty s) $ do+ v0 <- decodeClosure_ (Closure Unevaled t env [])+ es <- decodeSpine spine+ case runReduce (rewrite blk (applyE v0) rewr es) of+ NoReduction b -> runEval (evalValue (() <$ b) (ignoreBlocking b) emptyEnv [] ctrl)+ YesReduction _ v -> runEval (evalClosure v emptyEnv [] ctrl)+ where rewr = case t of+ Def f [] -> rewriteRules f+ Con c _ [] -> rewriteRules (conName c)+ Var x _ -> localRewr x+ _ -> __IMPOSSIBLE__+ rewriteEval _ = __IMPOSSIBLE__++ -- Add a NatSucK frame to the control stack. Pack consecutive suc's into a single frame.+ sucCtrl :: ControlStack s -> ControlStack s+ sucCtrl (NatSucK !n ctrl) = NatSucK (n + 1) ctrl+ sucCtrl ctrl = NatSucK 1 ctrl++ -- Add a UpdateThunk frame to the control stack. Pack consecutive updates into a single frame.+ updateThunkCtrl :: STPointer s -> ControlStack s -> ControlStack s+ updateThunkCtrl p (UpdateThunk ps ctrl) = UpdateThunk (p : ps) ctrl+ updateThunkCtrl p ctrl = UpdateThunk [p] ctrl++ -- When matching is stuck we return the closure from the 'MatchStack' with the appropriate+ -- 'IsValue' set.+ stuckMatch :: Blocked_ -> MatchStack s -> ControlStack s -> ST s (Blocked Term)+ stuckMatch blk (_ :> cl) ctrl = rewriteEval (Eval (mkValue blk cl) ctrl)++ -- On a mismatch we find the next 'Catchall' on the control stack and+ -- continue matching from there. If there isn't one we get an incomplete+ -- matching error (or get stuck if the function is marked partial).+ failedMatch :: QName -> MatchStack s -> ControlStack s -> ST s (Blocked Term)+ failedMatch f (CAFCons (Catchall cc spine) stack :> cl) ctrl = runMatch (Match f cc spine (stack :> cl) ctrl)+ failedMatch f (CAFNil :> cl) ctrl+ -- Bad work-around for #3870: don't fail hard during instance search.+ | speculative = rewriteEval (Eval (mkValue (NotBlocked (MissingClauses f) ()) cl) ctrl)+ | f `elem` partialDefs = rewriteEval (Eval (mkValue (NotBlocked (MissingClauses f) ()) cl) ctrl)+ | otherwise = rewriteEval (Eval (mkValue (NotBlocked ReallyNotBlocked ()) cl) ctrl) -- See #5396++ -- Some helper functions to build machine states and closures.+ evalClosure t env spine = Eval (Closure Unevaled t env spine)+ evalValue b t env spine = Eval (Closure (Value b) t env spine)+ evalTrueValue = evalValue $ notBlocked ()+ trueValue t env spine = Closure (Value $ notBlocked ()) t env spine+ mkValue b = setIsValue (Value b)++ -- Building lambdas+ lams :: [Arg String] -> Term -> Term+ lams xs t = foldr' lam t xs++ lam :: Arg String -> Term -> Term+ lam x t = Lam (argInfo x) (Abs (unArg x) t)++-- Pretty printing --------------------------------------------------------++instance Pretty a => Pretty (FastCase a) where+ prettyPrec p (FBranches _cop cs suc ls m _) =+ mparens (p > 0) $ vcat (prettyMap_ cs ++! prettyMap_ ls ++! prSuc suc ++! prC m)+ where+ prC Nothing = []+ prC (Just x) = ["_ ->" <?> pretty x]++ prSuc Nothing = []+ prSuc (Just x) = ["suc ->" <?> pretty x]++instance Pretty FastCompiledClauses where+ pretty (FDone done) = pretty done+ pretty FFail = "fail"+ pretty (FEta n _ cc ca) =+ text ("eta " ++! show n ++! " of") <?>+ vcat ("{} ->" <?> pretty cc :+ [ "_ ->" <?> pretty cc | Just cc <- [ca] ])+ pretty (FCase n bs) | fprojPatterns bs =+ sep [ text $ "project " ++! show n+ , nest 2 $ pretty bs+ ]+ pretty (FCase n bs) =+ text ("case " ++! show n ++! " of") <?> pretty bs++instance Pretty (Pointer s) where+ prettyPrec p = prettyPrec p . unsafeDerefPointer++instance Pretty (Closure s) where+ prettyPrec _ (Closure Value{} (Lit (LitString unused)) _ _)+ | unused == unusedPointerString = "_"+ prettyPrec p (Closure isV t env spine) =+ mparens (p > 9) $ fsep [ text tag+ , nest 2 $ prettyPrec 10 t+ , nest 2 $ prettyList $ zipWith' envEntry [0..] (envToList env)+ , nest 2 $ prettyList (map' sElimToElim spine) ]+ where envEntry i c = text ("@" ++! show i ++! " =") <+> pretty c+ tag = case isV of Value{} -> "V"; Unevaled -> "E"+ prettyPrec _ BlackHole = "<BLACKHOLE>"++instance Pretty (Eval s) where+ prettyPrec p (Eval cl ctrl) = prettyPrec p cl <?> pretty ctrl++instance Pretty (Match s) where+ prettyPrec p (Match f cc sp stack ctrl) =+ mparens (p > 9) $ sep [ "M" <+> pretty f+ , nest 2 $ prettyList (map' sElimToElim sp)+ , nest 2 $ prettyPrec 10 cc+ , nest 2 $ pretty stack+ , nest 2 $ pretty ctrl ]++instance Pretty (CatchallFrame s) where+ pretty Catchall{} = "Catchall"++instance Pretty (MatchStack s) where+ pretty (CAFNil :> _) = empty+ pretty (ca :> _) = prettyList $ asList ca where+ asList CAFNil = []+ asList (CAFCons c cs) = (c :) $! asList cs++instance Pretty (ControlStack s) where+ prettyPrec p (CaseK f _ _ _ _ mc ct) = mparens (p > 9) (("CaseK" <+> pretty (qnameName f)) <?> pretty mc)+ <+> prettyPrec p ct++ prettyPrec p (ForceK _ spine0 spine1 ct) = mparens (p > 9) (+ "ForceK" <?> prettyList (map' sElimToElim (spine0 ++! spine1)))+ <+> prettyPrec p ct+ prettyPrec p (EraseK _ sp0 sp1 sp2 sp3 ct) = mparens (p > 9) (sep+ [ "EraseK"+ , nest 2 $ prettyList $ map' sElimToElim sp0+ , nest 2 $ prettyList $ map' sElimToElim sp1+ , nest 2 $ prettyList $ map' sElimToElim sp2+ , nest 2 $ prettyList $ map' sElimToElim sp3 ])+ <+> prettyPrec p ct++ prettyPrec p (NatSucK n ct) = text ("+" ++! show n)+ <+> prettyPrec p ct+ prettyPrec p (PrimOpK f _ vs cls _ ct) = mparens (p > 9) (sep [ "PrimOpK" <+> pretty f+ , nest 2 $ prettyList vs+ , nest 2 $ prettyList cls ])+ <+> prettyPrec p ct+ prettyPrec p (UpdateThunk ps ct) = mparens (p > 9) ("UpdateThunk" <+> text (show (length ps)))+ <+> prettyPrec p ct+ prettyPrec p (ApplyK spine ct) = mparens (p > 9) ("ApplyK" <?> prettyList (map' sElimToElim spine))+ <+> prettyPrec p ct+ prettyPrec p (NormaliseK ct) = "NormaliseK"+ <+> prettyPrec p ct+ prettyPrec p (ArgK cl _ ct) = mparens (p > 9) (sep [ "ArgK" <+> prettyPrec 10 cl ])+ <+> prettyPrec p ct+ prettyPrec p EmptyK = "EmptyK"
src/full/Agda/TypeChecking/Reduce/Monad.hs view
@@ -3,8 +3,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Agda.TypeChecking.Reduce.Monad- ( constructorForm- , enterClosure+ ( enterClosure , getConstInfo , askR, applyWhenVerboseS ) where@@ -12,17 +11,15 @@ import Prelude hiding (null) import qualified Data.Map as Map-import Data.Maybe import System.IO.Unsafe import Agda.Syntax.Common.Pretty () --instance only import Agda.Syntax.Internal -import Agda.TypeChecking.Monad hiding (enterClosure, constructorForm)+import Agda.TypeChecking.Monad import Agda.TypeChecking.Substitute -import Agda.Utils.Lens import Agda.Utils.Maybe import Agda.Utils.Monad @@ -32,23 +29,6 @@ (Map.lookup b <$> useR stLocalBuiltins) (Map.lookup b <$> useR stImportedBuiltins) -constructorForm :: HasBuiltins m => Term -> m Term-constructorForm v = do- mz <- getBuiltin' builtinZero- ms <- getBuiltin' builtinSuc- return $ fromMaybe v $ constructorForm' mz ms v--enterClosure :: LensClosure c a => c -> (a -> ReduceM b) -> ReduceM b-enterClosure c | Closure _sig env scope cps x <- c ^. lensClosure = \case- -- The \case is a hack to correctly associate the where block to the rhs- -- rather than to the expression in the pattern guard.- f -> localR (mapRedEnvSt inEnv inState) (f x)- where- inEnv e = env- inState s =- -- TODO: use the signature here? would that fix parts of issue 118?- set stScope scope $ set stModuleCheckpoints cps s- withFreshR :: (ReadTCState m, HasFresh i) => (i -> m a) -> m a withFreshR f = do s <- getTCState@@ -62,24 +42,27 @@ addLetBinding' = defaultAddLetBinding' - updateContext rho f ret = withFreshR $ \ chkpt ->- localTC (\e -> e { envContext = f $ envContext e- , envCurrentCheckpoint = chkpt- , envCheckpoints = Map.insert chkpt IdS $- fmap (applySubst rho) (envCheckpoints e)- }) ret+ {-# INLINE updateContext #-}+ updateContext rho f ret = withFreshR \chkpt ->+ localTC ( over' eContext f+ . set eCurrentCheckpoint chkpt+ . over eCheckpoints (Map.insert chkpt IdS . fmap (applySubst rho)))+ ret++ addLocalRewrite = defaultAddLocalRewrite+ -- let-bindings keep track of own their context 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+ _ <- runTCM env st $ traceDebugMessage k n s $ pure () 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@@ -98,9 +81,10 @@ nowDebugPrinting = defaultNowDebugPrinting instance HasConstInfo ReduceM where- getRewriteRulesFor = defaultGetRewriteRulesFor+ getGlobalRewriteRulesFor = defaultGetGlobalRewriteRulesFor+ getLocalRewriteRulesFor = defaultGetLocalRewriteRulesFor 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
@@ -49,8 +49,6 @@ import Data.Either (partitionEithers) 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@@ -85,10 +83,14 @@ import qualified Agda.Utils.Set1 as Set1 import Agda.Utils.Size import qualified Agda.Utils.SmallSet as SmallSet+import qualified Agda.Utils.VarSet as VarSet+import Agda.Utils.VarSet (VarSet) import Agda.Utils.Impossible import Agda.Utils.Either+import Agda.Utils.List1 (nonEmpty) +-- | Require '--rewriting' for global REWRITE rules requireOptionRewriting :: TCM () requireOptionRewriting = unlessM (optRewriting <$> pragmaOptions) $ typeError NeedOptionRewriting@@ -99,7 +101,6 @@ -- Note: we do not care about hiding/non-hiding of lhs and rhs. verifyBuiltinRewrite :: Term -> Type -> TCM () verifyBuiltinRewrite v t = do- requireOptionRewriting caseMaybeM (relView t) (typeError $ IncorrectTypeForRewriteRelation v ShouldAcceptAtLeastTwoArguments) $ \ (RelView tel delta a b core) -> do@@ -141,13 +142,13 @@ -- Add rewrite rules to the signature forM_ rews $ \rew -> do- let f = rewHead rew+ let f = grHead rew matchables = getMatchables rew reportSDoc "rewriting" 10 $- "adding rule" <+> prettyTCM (rewName rew) <+>+ "adding rule" <+> prettyTCM (grName rew) <+> "to the definition of" <+> prettyTCM f reportSDoc "rewriting" 30 $ "matchable symbols: " <+> prettyTCM matchables- modifySignature $ addRewriteRulesFor f [rew] matchables+ addRewriteRulesFor f [rew] matchables -- Run confluence check for the new rules -- (should be done after adding all rules, see #3795)@@ -157,10 +158,11 @@ -- Global confluence checker requires rules to be sorted -- according to the generality of their lhs when (confChk == GlobalConfluenceCheck) $- forM_ (nubOn id $ map rewHead rews) sortRulesOfSymbol+ forM_ (nubOn id $ map grHead rews) sortRulesOfSymbol checkConfluenceOfRules confChk rews reportSDoc "rewriting" 10 $- "done checking confluence of rules" <+> prettyList_ (map (prettyTCM . rewName) rews)+ "done checking confluence of rules" <+>+ prettyList_ (map (prettyTCM . grName) rews) -- Auxiliary function for checkRewriteRule. -- | Get domain of rewrite relation.@@ -175,6 +177,42 @@ addContext delta $ prettyTCM a return (delta, a) +checkEquationValid ::+ RewriteSource -> RewriteAnn -> Type -> TCM (Maybe LocalEquation)+checkEquationValid s rewAnn t+ | isRewrite rewAnn = runMaybeT $ checkIsRewriteRelation s t+ | otherwise = pure Nothing++checkIsRewriteRelation ::+ RewriteSource -> Type -> MaybeT TCM LocalEquation+checkIsRewriteRelation q t = do+ rels <- lift getBuiltinRewriteRelations+ reportSDoc "rewriting.relations" 40 $ vcat+ [ "Rewrite relations:"+ , prettyList $ map prettyTCM $ toList rels+ ]+ TelV gamma1 core <- telView $ t+ reportSDoc "rewriting" 30 $ vcat+ [ "attempting to add rewrite rule of type "+ , prettyTCM gamma1+ , " |- " <+> do addContext gamma1 $ prettyTCM core+ ]+ case unEl core of+ Def rel es@(_:_:_) | rel `elem` rels -> do+ (delta, a) <- lift $ 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.+ n = size vs+ (us, [lhs, rhs]) = splitAt (n - 2) vs+ unless (size delta == size us) __IMPOSSIBLE__+ lhs <- instantiateFull lhs+ rhs <- instantiateFull rhs+ b <- instantiateFull $ applySubst (parallelS $ reverse us) a+ gamma1 <- instantiateFull gamma1+ pure $ LocalEquation gamma1 lhs rhs (unDom b)+ _ -> illegalRule q DoesNotTargetRewriteRelation+ -- | Check the validity of @q : Γ → rel us lhs rhs@ as rewrite rule -- @ -- Γ ⊢ lhs ↦ rhs : B@@ -183,7 +221,7 @@ -- Remember that @rel : Δ → A → A → Set i@, so -- @rel us : (lhs rhs : A[us/Δ]) → Set i@. -- Returns the checked rewrite rule to be added to the signature.-checkRewriteRule :: QName -> TCM (Maybe RewriteRule)+checkRewriteRule :: QName -> TCM (Maybe GlobalRewriteRule) checkRewriteRule q = runMaybeT $ setCurrentRange q do lift requireOptionRewriting rels <- lift getBuiltinRewriteRelations@@ -192,146 +230,188 @@ , 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. when (isEmptyFunction $ theDef def) $- illegalRule BeforeFunctionDefinition- -- Issue 6643: Also check that there are no mututal definitions+ illegalRule (GlobalRewrite def) BeforeFunctionDefinition+ -- Issue 6643: Also check that there are no mutual definitions -- that are not yet defined.- whenJustM (asksTC envMutualBlock) \ mb -> do+ whenJustM (viewTC eMutualBlock) \ mb -> do qs <- mutualNames <$> lookupMutualBlock mb when (Set.member q qs) $ forM_ qs $ \r -> do whenM (isEmptyFunction . theDef <$> getConstInfo r) $- illegalRule $ BeforeMutualFunctionDefinition r+ illegalRule (GlobalRewrite def) $ BeforeMutualFunctionDefinition r + eq <- checkIsRewriteRelation (GlobalRewrite def) (defType def)+ RewriteRule g h ps rhs b <- checkRewriteRule' eq (GlobalRewrite def)+ f <- case h of+ RewDefHead f -> pure f+ RewVarHead x -> illegalRule (GlobalRewrite def) LHSNotDefinitionOrConstructor - -- Get rewrite rule (type of q).- TelV gamma1 core <- telView $ defType def- reportSDoc "rewriting" 30 $ vcat- [ "attempting to add rewrite rule of type "- , prettyTCM gamma1- , " |- " <+> do addContext gamma1 $ prettyTCM core- ]+ top <- fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule++ pure $ GlobalRewriteRule q g f ps rhs b False top++checkLocalRewriteRule ::+ RewriteSource -> LocalEquation -> TCM (Maybe RewriteRule)+checkLocalRewriteRule s eq = runMaybeT $+ -- For now, we fail if the local rewrite rule contains metas ANYWHERE+ -- I think it should be possible to do better than this, but it is hard+ Set1.ifNull (allMetas Set.singleton eq)+ {- then -} (checkRewriteRule' eq s)+ {- else -} (illegalRule s . ContainsUnsolvedMetaVariables)++checkRewriteRule' :: LocalEquation -> RewriteSource -> MaybeT TCM RewriteRule+checkRewriteRule' eq@(LocalEquation gamma1 lhs rhs b) s = do+ reportSDoc "rewriting" 30 $+ "Checking rewrite rule: " <+> prettyTCM eq+ let failureBlocked :: Blocker -> MaybeT TCM a failureBlocked b- | Set1.IsNonEmpty ms <- allBlockingMetas b = illegalRule $ ContainsUnsolvedMetaVariables ms- | Set1.IsNonEmpty ps <- allBlockingProblems b = illegalRule $ BlockedOnProblems ps- | Set1.IsNonEmpty qs <- allBlockingDefs b = illegalRule $ RequiresDefinitions qs+ | Set1.IsNonEmpty ms <- allBlockingMetas b = illegalRule s $ ContainsUnsolvedMetaVariables ms+ | Set1.IsNonEmpty ps <- allBlockingProblems b = illegalRule s $ BlockedOnProblems ps+ | Set1.IsNonEmpty qs <- allBlockingDefs b = illegalRule s $ RequiresDefinitions qs | otherwise = __IMPOSSIBLE__- let failureFreeVars :: IntSet -> MaybeT TCM a- failureFreeVars xs = illegalRule $ VariablesNotBoundByLHS xs- let failureNonLinearPars :: IntSet -> MaybeT TCM a- failureNonLinearPars xs = illegalRule $ VariablesBoundMoreThanOnce xs+ let failureFreeVars :: VarSet -> MaybeT TCM a+ failureFreeVars xs = illegalRule s $ VariablesNotBoundByLHS xs+ let warnUnsafeVars :: VarSet -> MaybeT TCM ()+ warnUnsafeVars xs = unsafeRule s $ VariablesBoundInSingleton xs+ let failureNonLinearPars :: VarSet -> MaybeT TCM a+ failureNonLinearPars xs = illegalRule s $ VariablesBoundMoreThanOnce xs - -- Check that type of q targets rel.- case unEl core of- Def rel es@(_:_:_) | rel `elem` rels -> do- (delta, a) <- lift $ 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.- n = size vs- (us, [lhs, rhs]) = splitAt (n - 2) vs- unless (size delta == size us) __IMPOSSIBLE__- lhs <- instantiateFull lhs- rhs <- instantiateFull rhs- b <- instantiateFull $ applySubst (parallelS $ reverse us) a+ gamma0 <- getContextTelescope+ let gamma = gamma0 `abstract` gamma1 - gamma0 <- getContextTelescope- gamma1 <- instantiateFull gamma1- let gamma = gamma0 `abstract` gamma1+ reportSDoc "rewriting" 40 $+ "Full context: " <+> prettyTCM gamma - -- 2017-06-18, Jesper: Unfold inlined definitions on the LHS.- -- This is necessary to replace copies created by imports by their- -- original definition.- lhs <- modifyAllowedReductions (const $ SmallSet.singleton InlineReductions) $ reduce lhs+ -- 2017-06-18, Jesper: Unfold inlined definitions on the LHS.+ -- This is necessary to replace copies created by imports by their+ -- original definition.+ lhs <- modifyAllowedReductions (const $ SmallSet.singleton InlineReductions) $ reduce lhs - -- Find head symbol f of the lhs, its type, its parameters (in case of a constructor), and its arguments.- (f , hd , t , pars , es) <- case lhs of- Def f es -> do- def <- getConstInfo f- checkAxFunOrCon f def- return (f , Def f , defType def , [] , es)- Con c ci vs -> do- let hd = Con c ci- ~(Just ((_ , _ , pars) , t)) <- getFullyAppliedConType c $ unDom b- pars <- addContext gamma1 $ checkParametersAreGeneral c pars- return (conName c , hd , t , pars , vs)- _ -> do- reportSDoc "rewriting.rule.check" 30 $ hsep- [ "LHSNotDefinitionOrConstructor: ", prettyTCM lhs ]- illegalRule LHSNotDefinitionOrConstructor+ -- Find head symbol f of the lhs, its type, its parameters (in case of a constructor), and its arguments.+ (f , hd , t , pars , es) <- case lhs of+ Def f es -> do+ def <- getConstInfo f+ checkAxFunOrCon f def+ return (RewDefHead f , Def f , defType def , [] , es)+ Con c ci vs -> do+ let hd = Con c ci+ ~(Just ((_ , _ , pars) , t)) <- getFullyAppliedConType c b+ pars <- addContext gamma1 $ checkParametersAreGeneral c pars+ return (RewDefHead $ conName c , hd , t , pars , vs)+ Var x es | isLocalRewrite s -> do+ t <- addContext gamma1 $ typeOfBV x+ return (RewVarHead (x - size gamma1), Var x , t , [] , es)+ _ -> do+ reportSDoc "rewriting.rule.check" 30 $ hsep+ [ "LHSNotDefinitionOrConstructor: ", prettyTCM lhs ]+ illegalRule s LHSNotDefinitionOrConstructor - ifNotAlreadyAdded f $ do+ ifNotAlreadyAdded s f $ do - addContext gamma1 $ do+ let rewGamma = if isLocalRewrite s then gamma1 else gamma - checkNoLhsReduction f hd es+ telStart = size rewGamma - ps <- fromRightM failureBlocked $ lift $- catchPatternErr (pure . Left) $- Right <$> patternFrom relevant 0 (t , Def f) es+ addContext gamma1 $ do - reportSDoc "rewriting" 30 $- "Pattern generated from lhs: " <+> prettyTCM (PDef f ps)+ checkNoLhsReduction telStart f hd es - -- We need to check two properties on the variables used in the rewrite rule- -- 1. For actually being able to apply the rewrite rule, we need- -- that all variables that occur in the rule (on the left or the right)- -- are bound in a pattern position on the left.- -- 2. To preserve soundness, we need that all the variables that are used- -- in the *proof* of the rewrite rule are bound in the lhs.- -- For rewrite rules on constructors, we consider parameters to be bound- -- even though they don't appear in the lhs, since they can be reconstructed.- -- For postulated or abstract rewrite rules, we consider all arguments- -- as 'used' (see #5238).- let boundVars = nlPatVars ps- freeVars = allFreeVars (ps,rhs)- allVars = IntSet.fromList $ downFrom $ size gamma- usedVars = case theDef def of- Function{} -> usedArgs def- Axiom{} -> allVars- AbstractDefn{} -> allVars- Constructor{} -> allVars- Primitive{} -> allVars- DataOrRecSig{} -> __IMPOSSIBLE__- GeneralizableVar{} -> __IMPOSSIBLE__- Datatype{} -> __IMPOSSIBLE__- Record{} -> __IMPOSSIBLE__- PrimitiveSort{} -> __IMPOSSIBLE__- reportSDoc "rewriting" 70 $- "variables bound by the pattern: " <+> text (show boundVars)- reportSDoc "rewriting" 70 $- "variables free in the rewrite rule: " <+> text (show freeVars)- reportSDoc "rewriting" 70 $- "variables used by the rewrite rule: " <+> text (show usedVars)- unlessNull (freeVars IntSet.\\ boundVars) failureFreeVars- unlessNull (usedVars IntSet.\\ (boundVars `IntSet.union` IntSet.fromList pars)) failureFreeVars+ ps <- fromRightM failureBlocked $ lift $+ catchPatternErr (pure . Left) $+ Right <$> patternFrom+ NeverSing NeverSing telStart 0 (t , headToTerm telStart f) es - reportSDoc "rewriting" 70 $- "variables bound in (erased) parameter position: " <+> text (show pars)- unlessNull (boundVars `IntSet.intersection` IntSet.fromList pars) failureNonLinearPars+ reportSDoc "rewriting" 30 $+ "Pattern generated from lhs: " <+> prettyTCM (headToPat telStart f ps) - top <- fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule- let rew = RewriteRule q gamma f ps rhs (unDom b) False top+ -- We need to check two properties on the variables used in the rewrite rule+ -- 1. For actually being able to apply the rewrite rule, we need+ -- that all variables that occur in the rule (on the left or the right)+ -- are bound in a pattern position on the left.+ -- 2. To preserve soundness, we need that all the variables that are used+ -- in the *proof* of the rewrite rule are bound in the lhs.+ -- For rewrite rules on constructors, we consider parameters to be bound+ -- even though they don't appear in the lhs, since they can be reconstructed.+ -- For postulated or abstract rewrite rules, we consider all arguments+ -- as 'used' (see #5238).+ let PatVars neverSingPatVars maybeSingPatVars = nlPatVars ps+ boundVars = neverSingPatVars <> maybeSingPatVars+ telVars = VarSet.full telStart+ freeVarsLhs = telVars `VarSet.intersection` freeVarSet lhs+ freeVarsRhs = telVars `VarSet.intersection` freeVarSet rhs+ freeVars = freeVarsLhs <> freeVarsRhs+ usedVars = case s of+ LocalRewrite _ _ _ -> VarSet.empty+ GlobalRewrite def -> case theDef def of+ Function{} -> usedArgs def+ Axiom{} -> telVars+ AbstractDefn{} -> telVars+ Constructor{} -> telVars+ Primitive{} -> telVars+ DataOrRecSig{} -> __IMPOSSIBLE__+ GeneralizableVar{} -> __IMPOSSIBLE__+ Datatype{} -> __IMPOSSIBLE__+ Record{} -> __IMPOSSIBLE__+ PrimitiveSort{} -> __IMPOSSIBLE__+ reportSDoc "rewriting" 70 $+ "variables bound by pattern never singularly: " <+>+ text (show neverSingPatVars)+ reportSDoc "rewriting" 70 $+ "variables bound by the pattern: " <+> text (show boundVars)+ reportSDoc "rewriting" 70 $+ "variables free in the lhs: " <+> text (show freeVarsLhs)+ reportSDoc "rewriting" 70 $+ "variables free in the rhs: " <+> text (show freeVarsRhs)+ reportSDoc "rewriting" 70 $+ "variables used by the rewrite rule: " <+> text (show usedVars) - reportSDoc "rewriting" 10 $ vcat- [ "checked rewrite rule" , prettyTCM rew ]- reportSDoc "rewriting" 90 $ vcat- [ "checked rewrite rule" , text (show rew) ]+ -- All variables occurring in the rewrite must be bound somewhere+ -- (otherwise the rewrite will simply never fire)+ unlessNull (freeVars VarSet.\\ boundVars) failureFreeVars+ -- #5238: All variables used in the proof of the rewrite must be+ -- present in the context for the rewrite to fire safely.+ -- Searching the context is not feasible though, so we instead use the+ -- tighter criteria that the variables must occur somewhere on the LHS.+ unlessNull (usedVars VarSet.\\ (boundVars `VarSet.union` VarSet.fromList pars)) failureFreeVars+ reportSDoc "rewriting" 70 $+ "variables bound in (erased) parameter position: " <+> text (show pars)+ unlessNull (boundVars `VarSet.intersection` VarSet.fromList pars) failureNonLinearPars - return rew+ -- #5929: All variables occurring on the rhs should be bound in+ -- contexts that will never become definitionally singular (even after+ -- a substitution), otherwise we can lose subject reduction.+ unlessNull (freeVarsRhs VarSet.\\ neverSingPatVars) warnUnsafeVars - _ -> illegalRule DoesNotTargetRewriteRelation+ top <- fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule+ let rew = RewriteRule rewGamma f ps rhs b + reportSDoc "rewriting" 10 $ vcat+ [ "checked rewrite rule" , prettyTCM rew ]+ reportSDoc "rewriting" 90 $ vcat+ [ "checked rewrite rule" , text (show rew) ]++ return rew where- illegalRule :: IllegalRewriteRuleReason -> MaybeT TCM a- illegalRule reason = do- lift $ warning $ IllegalRewriteRule q reason- mzero+ ifNotAlreadyAdded ::+ RewriteSource -> RewriteHead -> MaybeT TCM RewriteRule+ -> MaybeT TCM RewriteRule+ ifNotAlreadyAdded (GlobalRewrite def) (RewDefHead f) cont = do+ rews <- getGlobalRewriteRulesFor f+ -- check if q is already an added rewrite rule+ case List.find ((defName def ==) . grName) rews of+ Just rew -> illegalRule (GlobalRewrite def) DuplicateRewriteRule+ Nothing -> cont+ ifNotAlreadyAdded (GlobalRewrite def) (RewVarHead x) cont = __IMPOSSIBLE__+ ifNotAlreadyAdded (LocalRewrite _ _ _) f cont = cont - checkNoLhsReduction :: QName -> (Elims -> Term) -> Elims -> MaybeT TCM ()- checkNoLhsReduction f hd es = do+ checkNoLhsReduction ::+ Nat -> RewriteHead -> (Elims -> Term) -> Elims+ -> MaybeT TCM ()+ checkNoLhsReduction telStart f hd es = do -- Skip this check when global confluence check is enabled, as -- redundant rewrite rules may be required to prove confluence. unlessM ((== Just GlobalConfluenceCheck) . optConfluenceCheck <$> pragmaOptions) $ do@@ -341,16 +421,19 @@ fail = do reportSDoc "rewriting" 20 $ "v = " <+> text (show v) reportSDoc "rewriting" 20 $ "v' = " <+> text (show v')- illegalRule $ LHSReduces v v'- es' <- case v' of- Def f' es' | f == f' -> return es'- Con c' _ es' | f == conName c' -> return es'+ illegalRule s $ LHSReduces v v'+ es' <- case (f, v') of+ (RewDefHead f, Def f' es') | f == f' -> return es'+ (RewDefHead f, Con c' _ es') | f == conName c' -> return es'+ (RewVarHead x, Var x' es') | x + telStart == x' -> return es' _ -> fail unless (null es && null es') $ do- a <- lift $ computeElimHeadType f es es'- pol <- getPolarity' CmpEq f+ a <- lift $ computeRewHeadType telStart f es es'+ pol <- case f of+ RewDefHead f -> getPolarity' CmpEq f+ RewVarHead x -> pure [] ok <- lift $ dontAssignMetas $ tryConversion $- compareElims pol [] a (Def f []) es es'+ compareElims pol [] a (headToTerm telStart f []) es es' unless ok fail checkAxFunOrCon :: QName -> Definition -> MaybeT TCM ()@@ -358,7 +441,7 @@ Axiom{} -> return () def@Function{} -> do whenJust (maybeRight (funProjection def)) $ \proj -> case projProper proj of- Nothing -> illegalRule $ HeadSymbolIsProjectionLikeFunction f+ Nothing -> illegalRule s $ HeadSymbolIsProjectionLikeFunction f Just{} -> __IMPOSSIBLE__ -- Andreas, 2024-08-20 -- A projection ought to be impossible in the head, since they are represented@@ -368,7 +451,7 @@ whenM (isJust . optConfluenceCheck <$> pragmaOptions) $ do let simpleClause cl = (patternsToElims (namedClausePats cl) , clauseBody cl) cls <- instantiateFull $ map simpleClause $ funClauses def- unless (noMetas cls) $ illegalRule $ HeadSymbolContainsMetas f+ unless (noMetas cls) $ illegalRule s $ HeadSymbolContainsMetas f Constructor{} -> return () AbstractDefn{} -> return ()@@ -382,18 +465,10 @@ GeneralizableVar{} -> __IMPOSSIBLE__ where- illegalHead = illegalRule $ HeadSymbolIsTypeConstructor f-- ifNotAlreadyAdded :: QName -> MaybeT TCM RewriteRule -> MaybeT TCM RewriteRule- ifNotAlreadyAdded f cont = do- rews <- getRewriteRulesFor f- -- check if q is already an added rewrite rule- case List.find ((q ==) . rewName) rews of- Just rew -> illegalRule DuplicateRewriteRule- Nothing -> cont+ illegalHead = illegalRule s $ HeadSymbolIsTypeConstructor f - usedArgs :: Definition -> IntSet- usedArgs def = IntSet.fromList $ map snd $ usedIxs+ usedArgs :: Definition -> VarSet+ usedArgs def = VarSet.fromList $ map snd $ usedIxs where occs = defArgOccurrences def allIxs = zip occs $ downFrom $ size occs@@ -413,8 +488,15 @@ _ -> errorNotGeneral errorNotGeneral :: MaybeT TCM a- errorNotGeneral = illegalRule $ ConstructorParametersNotGeneral c vs+ errorNotGeneral = illegalRule s $ ConstructorParametersNotGeneral c $+ fromMaybe __IMPOSSIBLE__ $ nonEmpty vs +checkRewConstraint :: LocalEquation -> TCM ()+checkRewConstraint+ eq@(LocalEquation {lEqContext = g, lEqLHS = l, lEqRHS = r, lEqType = t}) = do+ c <- viewTC eCall+ traceCall (CheckLocalRewriteConstraint eq c) $ addContext g $ equalTerm t l r+ -- | @rewriteWith t f es rew@ where @f : t@ -- tries to rewrite @f es@ with @rew@, returning the reduct if successful. rewriteWith :: Type@@ -422,9 +504,7 @@ -> RewriteRule -> Elims -> ReduceM (Either (Blocked Term) Term)-rewriteWith t hd rew@(RewriteRule q gamma _ ps rhs b isClause _) es- | isClause = return $ Left $ NotBlocked ReallyNotBlocked $ hd es- | otherwise = do+rewriteWith t hd rew@(RewriteRule gamma _ ps rhs b) es = do traceSDoc "rewriting.rewrite" 50 (sep [ "{ attempting to rewrite term " <+> prettyTCM (hd es) , " having head " <+> prettyTCM (hd []) <+> " of type " <+> prettyTCM t@@ -449,16 +529,20 @@ -- | @rewrite b v rules es@ tries to rewrite @v@ applied to @es@ with the -- rewrite rules @rules@. @b@ is the default blocking tag.-rewrite :: Blocked_ -> (Elims -> Term) -> RewriteRules -> Elims -> ReduceM (Reduced (Blocked Term) Term)+rewrite ::+ Blocked_ -> (Elims -> Term) -> RewriteRules -> Elims+ -> ReduceM (Reduced (Blocked Term) Term) rewrite block hd rules es = do- rewritingAllowed <- optRewriting <$> pragmaOptions+ rewritingAllowed <- anyRewritingOption if (rewritingAllowed && not (null rules)) then do- (_ , t) <- fromMaybe __IMPOSSIBLE__ <$> getTypedHead (hd [])- loop block t rules =<< instantiateFull' es -- TODO: remove instantiateFull?+ (_ , t) <- fromMaybe __IMPOSSIBLE__ <$> getLocalHeadType (hd [])+ loop block t rules es else return $ NoReduction (block $> hd es) where- loop :: Blocked_ -> Type -> RewriteRules -> Elims -> ReduceM (Reduced (Blocked Term) Term)+ loop ::+ Blocked_ -> Type -> RewriteRules -> Elims+ -> ReduceM (Reduced (Blocked Term) Term) loop block t [] es = traceSDoc "rewriting.rewrite" 20 (sep [ "failed to rewrite " <+> prettyTCM (hd es)@@ -475,5 +559,4 @@ Right w -> return $ YesReduction YesSimplification $ w `applyE` es2 | otherwise = loop (block `mappend` NotBlocked Underapplied ()) t rews es - rewArity :: RewriteRule -> Int rewArity = length . rewPats
src/full/Agda/TypeChecking/Rewriting.hs-boot view
@@ -7,3 +7,4 @@ verifyBuiltinRewrite :: Term -> Type -> TCM () rewrite :: Blocked_ -> (Elims -> Term) -> RewriteRules -> Elims -> ReduceM (Reduced (Blocked Term) Term)+checkRewConstraint :: LocalEquation -> TCM ()
src/full/Agda/TypeChecking/Rewriting/Clause.hs view
@@ -11,7 +11,6 @@ import Agda.TypeChecking.Monad -import Agda.Utils.Functor import Agda.Utils.Impossible import Agda.Utils.Monad import Agda.Syntax.Common.Pretty@@ -23,7 +22,8 @@ {-# INLINABLE getClausesAsRewriteRules #-} -- | Get all the clauses of a definition and convert them to rewrite -- rules.-getClausesAsRewriteRules :: (HasConstInfo m, ReadTCState m, MonadFresh NameId m) => QName -> m [RewriteRule]+getClausesAsRewriteRules :: (HasConstInfo m, ReadTCState m, MonadFresh NameId m)+ => QName -> m [GlobalRewriteRule] getClausesAsRewriteRules f = do cls <- defClauses <$> getConstInfo f forMaybeM (zip [1..] cls) $ \(i,cl) -> do@@ -43,19 +43,19 @@ -- if @clauseBody cl@ is @Nothing@. Precondition: @clauseType cl@ is -- not @Nothing@. clauseToRewriteRule :: (MonadTCEnv m, ReadTCState m)- => QName -> QName -> Clause -> m (Maybe RewriteRule)+ => QName -> QName -> Clause -> m (Maybe GlobalRewriteRule) clauseToRewriteRule f q cl | hasDefP (namedClausePats cl) = return Nothing clauseToRewriteRule f q cl = do top <- fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule- return $ clauseBody cl <&> \rhs -> RewriteRule- { rewName = q- , rewContext = clauseTel cl- , rewHead = f- , rewPats = toNLPat $ namedClausePats cl- , rewRHS = rhs- , rewType = unArg $ fromMaybe __IMPOSSIBLE__ $ clauseType cl- , rewFromClause = True- , rewTopModule = top+ return $ clauseBody cl <&> \rhs -> GlobalRewriteRule+ { grName = q+ , grContext = clauseTel cl+ , grHead = f+ , grPats = toNLPat $ namedClausePats cl+ , grRHS = rhs+ , grType = unArg $ fromMaybe __IMPOSSIBLE__ $ clauseType cl+ , grFromClause = True+ , grTopModule = top } class ToNLPat a b where@@ -73,12 +73,12 @@ instance ToNLPat (Arg DeBruijnPattern) (Elim' NLPat) where toNLPat (Arg ai p) = case p of- VarP _ x -> app $ PVar (dbPatVarIndex x) []+ VarP _ x -> app $ PVar MaybeSing (dbPatVarIndex x) [] DotP _ u -> app $ PTerm u ConP c _ ps -> app $ PDef (conName c) $ toNLPat ps LitP o l -> app $ PTerm $ Lit l ProjP o f -> Proj o f- IApplyP _ u v x -> IApply (PTerm u) (PTerm v) $ PVar (dbPatVarIndex x) []+ IApplyP _ u v x -> IApply (PTerm u) (PTerm v) $ PVar MaybeSing (dbPatVarIndex x) [] DefP _ f ps -> app $ PDef f $ toNLPat ps where
src/full/Agda/TypeChecking/Rewriting/Confluence.hs view
@@ -38,7 +38,6 @@ ) where import Control.Applicative-import Control.Arrow ((***)) import Control.Monad.Except ( MonadError(..) ) import Control.Monad.Reader ( MonadReader(..), asks, runReaderT ) @@ -90,6 +89,7 @@ import Agda.Utils.Permutation import Agda.Utils.Singleton import Agda.Utils.Size+import Agda.Utils.Tuple ((***)) -- | Check confluence of the clauses of the given function wrt rewrite rules of the -- constructors they match against@@ -97,48 +97,49 @@ checkConfluenceOfClauses confChk f = do rews <- getClausesAsRewriteRules f let noMetasInPats rew- | noMetas (rewPats rew) = return True+ | noMetas (grPats rew) = return True | otherwise = False <$ do warning $ ConfluenceCheckingIncompleteBecauseOfMeta f rews <- filterM noMetasInPats rews- let matchables = map getMatchables rews+ let matchables = map' getMatchables rews reportSDoc "rewriting.confluence" 30 $- "Function" <+> prettyTCM f <+> "has matchable symbols" <+> prettyList_ (map prettyTCM matchables)+ "Function" <+> prettyTCM f <+> "has matchable symbols" <+> prettyList_ (map' prettyTCM matchables) modifySignature $ setMatchableSymbols f $ concat matchables- let hasRules g = not . null <$> getRewriteRulesFor g- forM_ (zip rews matchables) $ \(rew,ms) ->- unlessNullM (filterM hasRules ms) $ \_ -> do++ let hasRules g = not . null <$> getGlobalRewriteRulesFor g+ forM_ (zip' rews matchables) \(rew,ms) ->+ unlessNullM (filterM hasRules ms) \_ -> do checkConfluenceOfRules confChk [rew] -- | Check confluence of the given rewrite rules wrt all other rewrite -- rules (also amongst themselves).-checkConfluenceOfRules :: ConfluenceCheck -> [RewriteRule] -> TCM ()+checkConfluenceOfRules :: ConfluenceCheck -> [GlobalRewriteRule] -> TCM () checkConfluenceOfRules confChk rews = inTopContext $ inAbstractMode $ do -- Global confluence: we need to check the triangle property for each rewrite -- rule of each head symbol as well as rules that match on them when (confChk == GlobalConfluenceCheck) $ do- let getSymbols rew = let f = rewHead rew in+ let getSymbols rew = let f = grHead rew in (Set.insert f) . defMatchable <$> getConstInfo f allSymbols <- Set.toList . Set.unions <$> traverse getSymbols rews forM_ allSymbols $ \f -> do rewsf <- getAllRulesFor f forM_ rewsf $ \rew -> do reportSDoc "rewriting.confluence.triangle" 10 $- "(re)checking triangle property for rule" <+> prettyTCM (rewName rew)+ "(re)checking triangle property for rule" <+> prettyTCM (grName rew) checkTrianglePropertyForRule rew forM_ (tails rews) $ listCase (return ()) $ \rew rewsRest -> do reportSDoc "rewriting.confluence" 10 $- "Checking confluence of rule" <+> prettyTCM (rewName rew)+ "Checking confluence of rule" <+> prettyTCM (grName rew) reportSDoc "rewriting.confluence" 30 $ "Checking confluence of rule" <+> prettyTCM rew - let f = rewHead rew- qs = rewPats rew- tel = rewContext rew+ let f = grHead rew+ qs = grPats rew+ tel = grContext rew def <- getConstInfo f- (fa , hdf) <- addContext tel $ makeHead def (rewType rew)+ (fa , hdf) <- addContext tel $ makeHead def (grType rew) reportSDoc "rewriting.confluence" 30 $ addContext tel $ "Head symbol" <+> prettyTCM (hdf []) <+> "of rewrite rule has type" <+> prettyTCM fa@@ -146,9 +147,10 @@ -- Step 1: check other rewrite rules that overlap at top position forMM_ (getAllRulesFor f) $ \ rew' -> do unless (any (sameRuleName rew') (rew:rewsRest) ||- (rewFromClause rew && rewFromClause rew')) $+ (grFromClause rew && grFromClause rew')) $ checkConfluenceTop hdf rew rew'- reportSDoc "rewriting.confluence" 30 $ "Finished step 1 of confluence check of rule" <+> prettyTCM (rewName rew)+ reportSDoc "rewriting.confluence" 30 $+ "Finished step 1 of confluence check of rule" <+> prettyTCM (grName rew) -- Step 2: check other rewrite rules that overlap with a subpattern -- of this rewrite rule@@ -162,7 +164,8 @@ forM_ rews' $ \rew' -> do unless (any (sameRuleName rew') rewsRest) $ checkConfluenceSub hdf hdg rew rew' hole- reportSDoc "rewriting.confluence" 30 $ "Finished step 2 of confluence check of rule" <+> prettyTCM (rewName rew)+ reportSDoc "rewriting.confluence" 30 $+ "Finished step 2 of confluence check of rule" <+> prettyTCM (grName rew) -- Step 3: check other rewrite rules that have a subpattern which -- overlaps with this rewrite rule@@ -171,39 +174,41 @@ "Symbol" <+> prettyTCM g <+> "has rules that match on" <+> prettyTCM f forMM_ (getAllRulesFor g) $ \ rew' -> do unless (any (sameRuleName rew') rewsRest) $ do- es' <- nlPatToTerm (rewPats rew')- let tel' = rewContext rew'+ es' <- nlPatToTerm (grPats rew')+ let tel' = grContext rew' def' <- getConstInfo g- (ga , hdg) <- addContext tel' $ makeHead def' (rewType rew')+ (ga , hdg) <- addContext tel' $ makeHead def' (grType rew') forMM_ (addContext tel' $ allHolesList (ga , hdg) es') $ \ hole -> do let f' = ohHeadName hole when (f == f') $ checkConfluenceSub hdg hdf rew' rew hole- reportSDoc "rewriting.confluence" 30 $ "Finished step 3 of confluence check of rule" <+> prettyTCM (rewName rew)+ reportSDoc "rewriting.confluence" 30 $+ "Finished step 3 of confluence check of rule" <+> prettyTCM (grName rew) where -- Check confluence of two rewrite rules that have the same head symbol, -- e.g. @f ps --> a@ and @f ps' --> b@.- checkConfluenceTop :: (Elims -> Term) -> RewriteRule -> RewriteRule -> TCM ()+ checkConfluenceTop ::+ (Elims -> Term) -> GlobalRewriteRule -> GlobalRewriteRule -> TCM () checkConfluenceTop hd rew1 rew2 =- traceCall (CheckConfluence (rewName rew1) (rewName rew2)) $+ traceCall (CheckConfluence (grName rew1) (grName rew2)) $ localTCStateSavingWarnings $ do - sub1 <- makeMetaSubst $ rewContext rew1- sub2 <- makeMetaSubst $ rewContext rew2+ sub1 <- makeMetaSubst $ grContext rew1+ sub2 <- makeMetaSubst $ grContext rew2 - let f = rewHead rew1 -- == rewHead rew2- a1 = applySubst sub1 $ rewType rew1- a2 = applySubst sub2 $ rewType rew2+ let f = grHead rew1 -- == grHead rew2+ a1 = applySubst sub1 $ grType rew1+ a2 = applySubst sub2 $ grType rew2 - es1 <- applySubst sub1 <$> nlPatToTerm (rewPats rew1)- es2 <- applySubst sub2 <$> nlPatToTerm (rewPats rew2)+ es1 <- applySubst sub1 <$> nlPatToTerm (grPats rew1)+ es2 <- applySubst sub2 <$> nlPatToTerm (grPats rew2) reportSDoc "rewriting.confluence" 30 $ vcat- [ "checkConfluenceTop" <+> prettyTCM (rewName rew1) <+> prettyTCM (rewName rew2)+ [ "checkConfluenceTop" <+> prettyTCM (grName rew1) <+> prettyTCM (grName rew2) , " f = " <+> prettyTCM f- , " ctx1 = " <+> prettyTCM (rewContext rew1)- , " ctx2 = " <+> prettyTCM (rewContext rew2)+ , " ctx1 = " <+> prettyTCM (grContext rew1)+ , " ctx2 = " <+> prettyTCM (grContext rew2) , " es1 = " <+> prettyTCM es1 , " es2 = " <+> prettyTCM es2 ]@@ -213,10 +218,10 @@ let n = min (size es1) (size es2) (es1' , es1r) = splitAt n es1 (es2' , es2r) = splitAt n es2- esr = es1r ++ es2r+ esr = es1r ++! es2r - lhs1 = hd $ es1' ++ esr- lhs2 = hd $ es2' ++ esr+ lhs1 = hd $ es1' ++! esr+ lhs2 = hd $ es2' ++! esr -- Use type of rewrite rule with the most eliminations a | null es1r = a2@@ -238,32 +243,36 @@ -- Get the rhs of both rewrite rules (after unification). In -- case of different arities, add additional arguments from -- one side to the other side.- let rhs1 = applySubst sub1 (rewRHS rew1) `applyE` es2r- rhs2 = applySubst sub2 (rewRHS rew2) `applyE` es1r+ let rhs1 = applySubst sub1 (grRHS rew1) `applyE` es2r+ rhs2 = applySubst sub2 (grRHS rew2) `applyE` es1r return (rhs1 , rhs2) - whenJust maybeCriticalPair $ uncurry (checkCriticalPair a hd (es1' ++ esr))+ whenJust maybeCriticalPair $ uncurry (checkCriticalPair a hd (es1' ++! esr)) -- Check confluence between two rules that overlap at a subpattern, -- e.g. @f ps[g qs] --> a@ and @g qs' --> b@.- checkConfluenceSub :: (Elims -> Term) -> (Elims -> Term) -> RewriteRule -> RewriteRule -> OneHole Elims -> TCM ()+ checkConfluenceSub ::+ (Elims -> Term) -> (Elims -> Term)+ -> GlobalRewriteRule -> GlobalRewriteRule -> OneHole Elims -> TCM () checkConfluenceSub hdf hdg rew1 rew2 hole0 = do- reportSDoc "rewriting.confluence" 100 $ "foo 2" <+> prettyTCM (rewName rew1) <+> prettyTCM (rewName rew2)- traceCall (CheckConfluence (rewName rew1) (rewName rew2)) $ localTCStateSavingWarnings $ do+ reportSDoc "rewriting.confluence" 100 $+ "foo 2" <+> prettyTCM (grName rew1) <+> prettyTCM (grName rew2)+ traceCall (CheckConfluence (grName rew1) (grName rew2)) $+ localTCStateSavingWarnings $ do reportSDoc "rewriting.confluence" 20 $- "Checking confluence of rules" <+> prettyTCM (rewName rew1) <+>- "and" <+> prettyTCM (rewName rew2) <+> "at subpattern position"+ "Checking confluence of rules" <+> prettyTCM (grName rew1) <+>+ "and" <+> prettyTCM (grName rew2) <+> "at subpattern position" - sub1 <- makeMetaSubst $ rewContext rew1+ sub1 <- makeMetaSubst $ grContext rew1 let bvTel0 = ohBoundVars hole0 k = size bvTel0 b0 = applySubst (liftS k sub1) $ ohType hole0 g = ohHeadName hole0 es0 = applySubst (liftS k sub1) $ ohElims hole0- qs2 = rewPats rew2+ qs2 = grPats rew2 -- TODO: support IApply in forceEtaExpansion let isIApply IApply{} = True@@ -273,70 +282,75 @@ -- 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.- hole1 <- addContext bvTel0 $+ mhole1 <- addContext bvTel0 $ forceEtaExpansion b0 (hdg es0) $ drop (size es0) qs2 - verboseS "rewriting.confluence.eta" 30 $- unless (size es0 == size qs2) $- addContext bvTel0 $- reportSDoc "rewriting.confluence.eta" 30 $ vcat- [ "forceEtaExpansion result:"- , nest 2 $ "bound vars: " <+> prettyTCM (ohBoundVars hole1)- , nest 2 $ "hole contents: " <+> addContext (ohBoundVars hole1) (prettyTCM $ ohContents hole1)- ]+ -- Issue #8636: If eta-expansion is not possible (e.g. the subpattern+ -- is a constructor of a different record type), we cannot check this+ -- potential overlap, so we skip it.+ whenJust mhole1 $ \hole1 -> do - let hole = hole1 `composeHole` hole0- g = ohHeadName hole -- == rewHead rew2- es' = ohElims hole- bvTel = ohBoundVars hole- plug = ohPlugHole hole+ verboseS "rewriting.confluence.eta" 30 $+ unless (size es0 == size qs2) $+ addContext bvTel0 $+ reportSDoc "rewriting.confluence.eta" 30 $ vcat+ [ "forceEtaExpansion result:"+ , nest 2 $ "bound vars: " <+> prettyTCM (ohBoundVars hole1)+ , nest 2 $ "hole contents: " <+> addContext (ohBoundVars hole1) (prettyTCM $ ohContents hole1)+ ] - sub2 <- addContext bvTel $ makeMetaSubst $ rewContext rew2+ let hole = hole1 `composeHole` hole0+ g = ohHeadName hole -- == grHead rew2+ es' = ohElims hole+ bvTel = ohBoundVars hole+ plug = ohPlugHole hole - let es1 = applySubst (liftS (size bvTel) sub1) es'- es2 <- applySubst sub2 <$> nlPatToTerm (rewPats rew2)+ sub2 <- addContext bvTel $ makeMetaSubst $ grContext rew2 - -- Make sure we are comparing eliminations with the same arity- -- (see #3810). Because we forced eta-expansion of es1, we- -- know that it is at least as long as es2.- when (size es1 < size es2) __IMPOSSIBLE__- let n = size es2- (es1' , es1r) = splitAt n es1+ let es1 = applySubst (liftS (size bvTel) sub1) es'+ es2 <- applySubst sub2 <$> nlPatToTerm (grPats rew2) - let lhs1 = applySubst sub1 $ hdf $ plug $ hdg es1- lhs2 = applySubst sub1 $ hdf $ plug $ hdg $ es2 ++ es1r- a = applySubst sub1 $ rewType rew1+ -- Make sure we are comparing eliminations with the same arity+ -- (see #3810). Because we forced eta-expansion of es1, we+ -- know that it is at least as long as es2.+ when (size es1 < size es2) __IMPOSSIBLE__+ let n = size es2+ (es1' , es1r) = splitAt n es1 - reportSDoc "rewriting.confluence" 20 $ sep- [ "Considering potential critical pair at subpattern: "- , nest 2 $ prettyTCM $ lhs1 , " =?= "- , nest 2 $ prettyTCM $ lhs2 , " : " , nest 2 $ prettyTCM a- ]+ let lhs1 = applySubst sub1 $ hdf $ plug $ hdg es1+ lhs2 = applySubst sub1 $ hdf $ plug $ hdg $ es2 ++! es1r+ a = applySubst sub1 $ grType rew1 - maybeCriticalPair <- tryUnification lhs1 lhs2 $ do- -- Unify the subpattern of the first rewrite rule with the lhs- -- of the second one- ga <- defType <$> getConstInfo g- gpol <- getPolarity' CmpEq g- onlyReduceTypes $ addContext bvTel $- compareElims gpol [] ga (hdg []) es1' es2+ reportSDoc "rewriting.confluence" 20 $ sep+ [ "Considering potential critical pair at subpattern: "+ , nest 2 $ prettyTCM $ lhs1 , " =?= "+ , nest 2 $ prettyTCM $ lhs2 , " : " , nest 2 $ prettyTCM a+ ] - -- Right-hand side of first rewrite rule (after unification)- let rhs1 = applySubst sub1 $ rewRHS rew1+ maybeCriticalPair <- tryUnification lhs1 lhs2 $ do+ -- Unify the subpattern of the first rewrite rule with the lhs+ -- of the second one+ ga <- defType <$> getConstInfo g+ gpol <- getPolarity' CmpEq g+ onlyReduceTypes $ addContext bvTel $+ compareElims gpol [] ga (hdg []) es1' es2 - -- Left-hand side of first rewrite rule, with subpattern- -- rewritten by the second rewrite rule- let w = applySubst sub2 (rewRHS rew2) `applyE` es1r- reportSDoc "rewriting.confluence" 30 $ sep- [ "Plugging hole with w = "- , nest 2 $ addContext bvTel $ prettyTCM w- ]- let rhs2 = applySubst sub1 $ hdf $ plug w+ -- Right-hand side of first rewrite rule (after unification)+ let rhs1 = applySubst sub1 $ grRHS rew1 - return (rhs1 , rhs2)+ -- Left-hand side of first rewrite rule, with subpattern+ -- rewritten by the second rewrite rule+ let w = applySubst sub2 (grRHS rew2) `applyE` es1r+ reportSDoc "rewriting.confluence" 30 $ sep+ [ "Plugging hole with w = "+ , nest 2 $ addContext bvTel $ prettyTCM w+ ]+ let rhs2 = applySubst sub1 $ hdf $ plug w - whenJust maybeCriticalPair $ uncurry (checkCriticalPair a hdf (applySubst sub1 $ plug $ hdg es1))+ return (rhs1 , rhs2) + whenJust maybeCriticalPair $ uncurry (checkCriticalPair a hdf (applySubst sub1 $ plug $ hdg es1))+ checkCriticalPair :: Type -- Type of the critical pair -> (Elims -> Term) -- Head of lhs@@ -352,7 +366,7 @@ reportSDoc "rewriting.confluence" 30 $ sep [ "Abstracting over metas: "- , prettyList_ (map (text . show) ms)+ , prettyList_ (map' (text . show) ms) ] (gamma , (a,es,rhs1,rhs2)) <- fromMaybe __IMPOSSIBLE__ <$> abstractOverMetas ms (a,es,rhs1,rhs2)@@ -386,17 +400,17 @@ GlobalConfluenceCheck -> do (f, t) <- fromMaybe __IMPOSSIBLE__ <$> getTypedHead (hd []) - let checkEqualLHS :: RewriteRule -> TCM Bool- checkEqualLHS (RewriteRule q delta _ ps _ _ _ _) = do+ let checkEqualLHS :: GlobalRewriteRule -> TCM Bool+ checkEqualLHS (GlobalRewriteRule q delta _ ps _ _ _ _) = do onlyReduceTypes (nonLinMatch delta (t , hd) ps es) >>= \case Left _ -> return False Right sub -> do- let us = applySubst sub $ map var $ downFrom $ size delta+ let us = applySubst sub $ map' var $ downFrom $ size delta as = applySubst sub $ flattenTel delta reportSDoc "rewriting.confluence.global" 35 $- applyUnless (null us) (<+> ("with instantiation" <+> prettyList_ (map prettyTCM us))) $+ applyUnless (null us) (<+> ("with instantiation" <+> prettyList_ (map' prettyTCM us))) $ prettyTCM (hd es) <+> "is an instance of the LHS of rule" <+> prettyTCM q- ok <- allDistinctVars $ zip us as+ ok <- allDistinctVars $ zip' us as when ok $ reportSDoc "rewriting.confluence.global" 30 $ "It is equal to the LHS of rewrite rule" <+> prettyTCM q return ok@@ -413,13 +427,17 @@ unlessM (sameRHS `or2M` anyM checkEqualLHS rews) $ addContext gamma $ warning $ RewriteAmbiguousRules (hd es) rhs1 rhs2 - checkTrianglePropertyForRule :: RewriteRule -> TCM ()- checkTrianglePropertyForRule (RewriteRule q gamma f ps rhs b c _) = addContext gamma $ do+ checkTrianglePropertyForRule :: GlobalRewriteRule -> TCM ()+ checkTrianglePropertyForRule (GlobalRewriteRule q gamma f ps rhs b c _) =+ addContext gamma $ do+ u <- nlPatToTerm $ PDef f ps -- First element in the list is the "best reduct" @ρ(u)@ (rhou,vs) <- fromMaybe __IMPOSSIBLE__ . uncons <$> allParallelReductions u+ reportSDoc "rewriting.confluence" 40 $ ("rho(" <> prettyTCM u <> ") =") <+> prettyTCM rhou- reportSDoc "rewriting.confluence" 40 $ ("S(" <> prettyTCM u <> ") =") <+> prettyList_ (map prettyTCM vs)+ reportSDoc "rewriting.confluence" 40 $ ("S(" <> prettyTCM u <> ") =") <+> prettyList_ (map' prettyTCM vs)+ -- If present, last element is always equal to u caseMaybe (initLast vs) (return ()) $ \(vs',u') -> do unless (u == u') __IMPOSSIBLE__@@ -449,31 +467,33 @@ -- we replicate the old (unhygienic) approach to rewrite rule scoping -- here to avoid a regression. -- See also #7969 for a reason why the code below is questionable.- rules <- sortRules =<< getFilteredRewriteRulesFor False f+ rules <- sortRules =<< getFilteredGlobalRewriteRulesFor False f modifySignature $ over sigRewriteRules $ HMap.insert f rules where- sortRules :: PureTCM m => [RewriteRule] -> m [RewriteRule]+ sortRules :: PureTCM m => [GlobalRewriteRule] -> m [GlobalRewriteRule] sortRules rs = do- ordPairs <- deleteLoops . Set.fromList . map (rewName *** rewName) <$>+ ordPairs <- deleteLoops . Set.fromList . map' (grName *** grName) <$> filterM (uncurry $ flip moreGeneralLHS) [(r1,r2) | r1 <- rs, r2 <- rs] let perm = fromMaybe __IMPOSSIBLE__ $- topoSort (\r1 r2 -> (rewName r1,rewName r2) `Set.member` ordPairs) rs+ topoSort (\r1 r2 -> (grName r1,grName r2) `Set.member` ordPairs) rs reportSDoc "rewriting.confluence.sort" 50 $ "sorted rules: " <+>- prettyList_ (map (prettyTCM . rewName) $ permute perm rs)- return $ permute perm rs+ prettyList_ (map' (prettyTCM . grName) $ permute perm rs)+ return $! permute perm rs - moreGeneralLHS :: PureTCM m => RewriteRule -> RewriteRule -> m Bool+ moreGeneralLHS :: PureTCM m+ => GlobalRewriteRule -> GlobalRewriteRule -> m Bool moreGeneralLHS r1 r2- | sameRuleName r1 r2 = return False- | rewHead r1 /= rewHead r2 = return False- | otherwise = addContext (rewContext r2) $ do- def <- getConstInfo $ rewHead r1- (t, hd) <- makeHead def (rewType r2)- (vs :: Elims) <- nlPatToTerm $ rewPats r2- res <- isRight <$> onlyReduceTypes (nonLinMatch (rewContext r1) (t, hd) (rewPats r1) vs)+ | sameRuleName r1 r2 = return False+ | grHead r1 /= grHead r2 = return False+ | otherwise = addContext (grContext r2) $ do+ def <- getConstInfo $ grHead r1+ (t, hd) <- makeHead def (grType r2)+ (vs :: Elims) <- nlPatToTerm $ grPats r2+ res <- isRight <$> onlyReduceTypes+ (nonLinMatch (grContext r1) (t, hd) (grPats r1) vs) when res $ reportSDoc "rewriting.confluence.sort" 55 $- "the lhs of " <+> prettyTCM (rewName r1) <+>- "is more general than the lhs of" <+> prettyTCM (rewName r2)+ "the lhs of " <+> prettyTCM (grName r1) <+>+ "is more general than the lhs of" <+> prettyTCM (grName r2) return res deleteLoops :: Ord a => Set (a,a) -> Set (a,a)@@ -499,17 +519,18 @@ return (ftype , Def f) _ -> return (defType def , Def $ defName def) -sameRuleName :: RewriteRule -> RewriteRule -> Bool-sameRuleName = (==) `on` rewName+sameRuleName :: GlobalRewriteRule -> GlobalRewriteRule -> Bool+sameRuleName = (==) `on` grName -- | Get both clauses and rewrite rules for the given symbol-getAllRulesFor :: (HasConstInfo m, ReadTCState m, MonadFresh NameId m) => QName -> m [RewriteRule]-getAllRulesFor f = (++) <$> getRewriteRulesFor f <*> getClausesAsRewriteRules f+getAllRulesFor :: (HasConstInfo m, ReadTCState m, MonadFresh NameId m)+ => QName -> m [GlobalRewriteRule]+getAllRulesFor f = (++!) <$> getGlobalRewriteRulesFor f <*> getClausesAsRewriteRules f -- | Build a substitution that replaces all variables in the given -- telescope by fresh metavariables.-makeMetaSubst :: (MonadMetaSolver m) => Telescope -> m Substitution-makeMetaSubst gamma = parallelS . reverse . map unArg <$> newTelMeta gamma+makeMetaSubst :: Telescope -> TCM Substitution+makeMetaSubst gamma = parallelS . reverse . map' unArg <$> newTelMeta gamma computingOverlap :: (MonadTCEnv m) => m a -> m a computingOverlap = locallyTC eConflComputingOverlap $ const True@@ -567,7 +588,7 @@ -- Get type of head symbol (f , t) <- fromMaybe __IMPOSSIBLE__ <$> getTypedHead (hd []) reportSDoc "rewriting.parreduce" 60 $ "topLevelReductions: head symbol" <+> prettyTCM (hd []) <+> ":" <+> prettyTCM t- RewriteRule q gamma _ ps rhs b c _ <- scatterMP (getAllRulesFor f)+ GlobalRewriteRule q gamma _ ps rhs b c _ <- scatterMP (getAllRulesFor f) reportSDoc "rewriting.parreduce" 60 $ "topLevelReductions: trying rule" <+> prettyTCM q -- Don't reduce if underapplied guard $ length es >= length ps@@ -577,7 +598,7 @@ Left block -> empty -- Matching succeeded Right sub -> do- let vs = map (lookupS sub) $ [0..(size gamma-1)]+ let vs = map' (lookupS sub) $ [0..(size gamma-1)] sub' <- parallelS <$> parReduce vs es1' <- parReduce es1 let w = (applySubst sub' rhs) `applyE` es1'@@ -619,7 +640,7 @@ parReduce e@Proj{} = pure e parReduce e@IApply{} = pure e -- TODO -instance (Free a, Subst a, ParallelReduce a) => ParallelReduce (Abs a) where+instance (Subst a, ParallelReduce a) => ParallelReduce (Abs a) where parReduce = mapAbstraction __DUMMY_DOM__ parReduce @@ -639,7 +660,7 @@ -- Construct telescope (still containing the metas) let n = size ms'- gamma = unflattenTel' n ns $ map defaultDom as+ gamma = unflattenTel' n ns $ map' defaultDom as -- Replace metas by variables let metaIndex x = (n-1-) <$> elemIndex x ms'@@ -710,8 +731,8 @@ -- 2. @v : _A@ and @es = [.fst]@: this will instantiate -- @_A := _A1 × _A2@ and return the @OneHole Term@ -- @([v .fst]) , (v .snd)@.-forceEtaExpansion :: Type -> Term -> [Elim' a] -> TCM (OneHole Term)-forceEtaExpansion a v [] = return $ idHole a v+forceEtaExpansion :: Type -> Term -> [Elim' a] -> TCM (Maybe (OneHole Term))+forceEtaExpansion a v [] = return $ Just $ idHole a v forceEtaExpansion a v (e:es) = case e of Apply (Arg i w) -> do@@ -727,7 +748,7 @@ let body = raise 1 v `apply` [Arg i $ var 0] -- Continue with remaining eliminations- addContext dom $ ohAddBV "x" dom . fmap (Lam i . mkAbs "x") <$>+ addContext dom $ fmap (ohAddBV "x" dom . fmap (Lam i . mkAbs "x")) <$> forceEtaExpansion cod body es Proj o f -> do@@ -737,23 +758,29 @@ [ "Forcing" , prettyTCM v , ":" , prettyTCM a , "to be projectible by" , prettyTCM f ] r <- fromMaybe __IMPOSSIBLE__ <$> getRecordOfField f Defn{ defType = ra, theDef = RecordDefn rdef } <- getConstInfo r++ if not (isEtaRecordDef rdef) then return Nothing else do+ pars <- newArgsMeta ra s <- ra `piApplyM` pars >>= \s -> ifIsSort s return __IMPOSSIBLE__- equalType a $ El s (Def r $ map Apply pars)+ equalType a $ El s (Def r $ map' Apply pars) -- Eta-expand v at record type r, and get field corresponding to f- (_ , c , ci , fields) <- etaExpandRecord_ r pars rdef v- let fs = map argFromDom $ _recFields rdef- i = fromMaybe __IMPOSSIBLE__ $ elemIndex f $ map unArg fs- fContent = unArg $ fromMaybe __IMPOSSIBLE__ $ fields !!! i- fUpdate w = Con c ci $ map Apply $ updateAt i (w <$) fields+ mcfields <- etaExpandRecord_ r pars rdef v+ case mcfields of+ Nothing -> return Nothing -- Issue #8636: cannot eta-expand+ Just (_, c, ci, fields) -> do+ let fs = map' argFromDom $ _recFields rdef+ i = fromMaybe __IMPOSSIBLE__ $ elemIndex f $ map' unArg fs+ fContent = unArg $ fromMaybe __IMPOSSIBLE__ $ fields !!! i+ fUpdate w = Con c ci $ map' Apply $ updateAt i (w <$) fields - -- Get type of field corresponding to f- ~(Just (El _ (Pi b c))) <- getDefType f =<< reduce a- let fa = c `absApp` v+ -- Get type of field corresponding to f+ ~(Just (El _ (Pi b c))) <- getDefType f =<< reduce a+ let fa = c `absApp` v - -- Continue with remaining eliminations- fmap fUpdate <$> forceEtaExpansion fa fContent es+ -- Continue with remaining eliminations+ fmap (fmap fUpdate) <$> forceEtaExpansion fa fContent es IApply{} -> __IMPOSSIBLE__ -- Not yet implemented @@ -911,7 +938,8 @@ LockUniv -> pure LockUniv LevelUniv -> pure LevelUniv IntervalUniv -> pure IntervalUniv- PiSort s t u -> PiSort <$> metasToVars s <*> metasToVars t <*> metasToVars u+ PiSort c s t u -> PiSort c <$>+ metasToVars s <*> metasToVars t <*> metasToVars u FunSort s t -> FunSort <$> metasToVars s <*> metasToVars t UnivSort s -> UnivSort <$> metasToVars s MetaS x es -> MetaS x <$> metasToVars es
src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs view
@@ -26,27 +26,23 @@ import Control.Applicative ( Alternative ) import Control.Monad.Except ( MonadError(..), ExceptT, runExceptT )-import Control.Monad.State ( MonadState, StateT, runStateT ) import Data.Maybe 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.Internal -import Agda.TypeChecking.Conversion.Pure (pureEqualTermB)+import Agda.TypeChecking.Conversion.Pure (pureBlockOrEqualTermPureTCM) import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Free.Reduce import Agda.TypeChecking.Irrelevance (isPropM) import Agda.TypeChecking.Level-import Agda.TypeChecking.Monad hiding (constructorForm)+import Agda.TypeChecking.Monad import Agda.TypeChecking.Pretty import Agda.TypeChecking.Records import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Reduce.Monad import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope import Agda.TypeChecking.Primitive.Cubical.Base@@ -54,13 +50,15 @@ import Agda.Utils.Either import Agda.Utils.Function (applyWhen) import Agda.Utils.Functor-import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Permutation import Agda.Utils.Size+import Agda.Utils.VarSet (VarSet)+import Agda.Utils.VarSet qualified as VarSet+import Agda.Utils.StrictState import Agda.Utils.Impossible @@ -72,6 +70,7 @@ , MonadError Blocked_, MonadState NLMState , HasBuiltins, HasConstInfo, HasOptions, ReadTCState , MonadTCEnv, MonadReduce, MonadAddContext, MonadDebug+ , MonadFileId , PureTCM ) @@ -297,24 +296,27 @@ MetaV m es -> matchingBlocked $ blocked_ m _ -> no "" case p of- PVar i bvs -> traceSDoc "rewriting.match" 60 ("matching a PVar: " <+> text (show i)) $ do- let vars = map unArg bvs- let allowedVars :: IntSet- allowedVars = IntSet.fromList vars- badVars :: IntSet- badVars = IntSet.difference (IntSet.fromList (downFrom n)) allowedVars- perm :: Permutation- perm = Perm n $ reverse vars- tel :: Telescope- tel = permuteContext perm k- ok <- addContext k $ reallyFree badVars v- case ok of- Left b -> block b- Right Nothing -> no ""- Right (Just v) ->- let t' = telePi tel $ renameP impossible perm t- v' = teleLam tel $ renameP impossible perm v- in tellSub r (i-n) t' v'+ PVar s i bvs -> traceSDoc "rewriting.match" 60 ("matching a PVar: " <+> text (show i)) $ do+ case n of+ 0 -> tellSub r (i-n) t v+ _ -> do+ let vars = map' unArg bvs+ let allowedVars :: VarSet+ allowedVars = VarSet.fromList vars+ badVars :: VarSet+ badVars = VarSet.complement n allowedVars+ perm :: Permutation+ perm = Perm n $ reverse vars+ tel :: Telescope+ tel = permuteContext perm k+ ok <- addContext k $ liftReduce $ reallyFree badVars v+ case ok of+ Left b -> block b+ Right Nothing -> no ""+ Right (Just v) ->+ let t' = telePi tel $ renameP impossible perm t+ v' = teleLam tel $ renameP impossible perm v+ in tellSub r (i-n) t' v' PDef f ps -> traceSDoc "rewriting.match" 60 ("matching a PDef: " <+> prettyTCM f) $ do v <- addContext k $ constructorForm =<< unLevel v@@ -330,7 +332,7 @@ Nothing -> no "" _ | Pi a b <- unEl t -> do let ai = domInfo a- pbody = PDef f $ raise 1 ps ++ [ Apply $ Arg ai $ PTerm $ var 0 ]+ pbody = PDef f $ raise 1 ps ++! [ Apply $ Arg ai $ PTerm $ var 0 ] body = raise 1 v `apply` [ Arg (domInfo a) $ var 0 ] k' <- extendContext k (absName b) a match r gamma k' (absBody b) pbody body@@ -339,18 +341,21 @@ -- type, e.g., we eta-expand both v to (c vs) and -- the pattern (p = PDef f ps) to @c (p .f1) ... (p .fn)@. RecordDefn def <- addContext k $ theDef <$> getConstInfo d- (tel, c, ci, vs) <- addContext k $ etaExpandRecord_ d pars def v- 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 ""+ metelcivs <- addContext k $ etaExpandRecord_ d pars def v+ case metelcivs of+ Nothing -> no "" -- Issue #8636: cannot eta-expand+ Just (tel, c, ci, vs) -> do+ 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@@ -371,31 +376,45 @@ PSort ps -> case v of Sort s -> match r gamma k () ps s v -> maybeBlock v- PBoundVar i ps -> case v of- Var i' es | i == i' -> do- let ti = maybe __IMPOSSIBLE__ (unDom . ctxEntryDom) $ lookupBV_ i k+ PBoundVar i ps -> traceSDoc "rewriting.match" 60+ ("Matching a PBoundVar" <+> addContext gamma (addContext k $+ prettyTCM $ PBoundVar i ps) <+> "with" <+>+ (addContext k $ prettyTCM v)) $ case v of+ -- Either we are matching a higher order bound variable in k or we+ -- are matching a locally bound variable outside gamma+ -- (gamma is the rewrite telescope - i.e. the telescope of pattern+ -- variables which are in scope in the pattern but not in the term we+ -- matching against)+ Var i' es | (i < size k && i == i')+ || (i >= size k && i == i' + size gamma) -> do+ ti <- addContext gamma $ addContext k $ typeOfBV i match r gamma k (ti , Var i) ps es _ | Pi a b <- unEl t -> do let ai = domInfo a- pbody = PBoundVar (1 + i) $ raise 1 ps ++ [ Apply $ Arg ai $ PTerm $ var 0 ]+ pbody = PBoundVar (1 + i) $ raise 1 ps ++! [ Apply $ Arg ai $ PTerm $ var 0 ] body = raise 1 v `apply` [ Arg ai $ var 0 ] k' <- extendContext k (absName b) a match r gamma k' (absBody b) pbody body _ | Just (d, pars) <- etaRecord -> do RecordDefn def <- addContext k $ theDef <$> getConstInfo d- (tel, c, ci, vs) <- addContext k $ etaExpandRecord_ d pars def v- 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 ""+ metelcivs <- addContext k $ etaExpandRecord_ d pars def v+ case metelcivs of+ Nothing -> no "" -- Issue #8636: cannot eta-expand+ Just (tel, c, ci, vs) -> do+ 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 (addContext k $ prettyTCM u)) $- tellEq gamma k t u v+ -- #8231: We need to skip testing conversion if we are matching at+ -- at irrelevant relevance+ unless (isIrrelevant r) $ tellEq gamma k t u v extendContext :: MonadAddContext m => Context -> ArgName -> Dom Type -> m Context-extendContext cxt x a = withFreshName empty x \ y -> return $ CtxVar y a : cxt+extendContext cxt x a = withFreshName empty x \y -> return $ CxExtendVar y a cxt makeSubstitution :: Telescope -> Sub -> Maybe Substitution@@ -425,7 +444,7 @@ caseEitherM (runNLM $ match relevant gamma empty t p v) (no "matching") $ \ s -> do let msub = makeSubstitution gamma $ s ^. nlmSub eqs = s ^. nlmEqs- traceSDoc "rewriting.match" 90 (text $ "msub = " ++ show msub) $ case msub of+ 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@@ -437,7 +456,7 @@ -- Returns `Nothing` if the terms are equal, or `Just b` if the terms are not -- (where b contains information about possible metas blocking the comparison) equal :: PureTCM m => Type -> Term -> Term -> m (Maybe Blocked_)-equal a u v = pureEqualTermB a u v >>= \case+equal a u v = pureBlockOrEqualTermPureTCM a u v >>= \case Left b -> return $ Just $ Blocked b () Right True -> return Nothing Right False -> traceSDoc "rewriting.match" 10 (sep@@ -448,9 +467,20 @@ -- | Utility function for getting the name and type of a head term (i.e. a -- `Def` or `Con` with no arguments)+-- Fails on variable heads getTypedHead :: PureTCM m => Term -> m (Maybe (QName, Type))-getTypedHead = \case- Def f [] -> Just . (f,) . defType <$> getConstInfo f+getTypedHead x = do+ t <- getLocalHeadType x+ case t of+ Just (Just f, t) -> pure $ Just (f, t)+ Just (Nothing, t) -> pure Nothing+ Nothing -> pure Nothing++-- | Utility function for getting the type of a head term. Includes a case+-- for variables (which are valid heads of local rewrite rules)+getLocalHeadType :: PureTCM m => Term -> m (Maybe (Maybe QName, Type))+getLocalHeadType = \case+ Def f [] -> Just . (Just f,) . defType <$> getConstInfo f Con (ConHead { conName = c }) _ [] -> do -- Andreas, 2018-09-08, issue #3211: -- discount module parameters for constructor heads@@ -459,9 +489,12 @@ -- case we don't have enough parameters getNumberOfParameters c >>= \case Just npars -> do- let ws = replicate (npars - size vs) $ defaultArg __DUMMY_TERM__+ 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+ t <- t0 `piApplyM` (vs ++! ws)+ return $ Just (Just c , t)+ Nothing -> pure Nothing+ Var x [] -> do+ t <- domOfBV x+ pure $ Just (Nothing, unDom t)+ _ -> pure Nothing
src/full/Agda/TypeChecking/Rewriting/NonLinPattern.hs view
@@ -10,10 +10,7 @@ import Prelude hiding ( null ) -import Control.Monad.Reader ( asks )--import Data.IntSet (IntSet)-import qualified Data.IntSet as IntSet+import Data.Foldable (Foldable(fold)) import Agda.Syntax.Common import Agda.Syntax.Internal@@ -21,9 +18,7 @@ import Agda.Syntax.Internal.MetaVars ( AllMetas, unblockOnAllMetasIn ) import Agda.TypeChecking.Datatypes-import Agda.TypeChecking.Free-import Agda.TypeChecking.Free.Lazy-import Agda.TypeChecking.Irrelevance (isPropM)+import Agda.TypeChecking.Irrelevance ( isDefSing, isPatternVar ) import Agda.TypeChecking.Level import Agda.TypeChecking.Monad import Agda.TypeChecking.Pretty@@ -40,66 +35,75 @@ import Agda.Utils.Null import Agda.Utils.Singleton import Agda.Utils.Size+import qualified Agda.Utils.SmallSet as SmallSet+import qualified Agda.Utils.VarSet as VarSet+import Agda.Utils.VarSet (VarSet) -- | Turn a term into a non-linear pattern, treating the -- free variables as pattern variables.--- The first argument indicates the relevance we are working under: if this--- is Irrelevant, then we construct a pattern that never fails to match.--- The second argument is the number of bound variables (from pattern lambdas).--- The third argument is the type of the term.+-- The first two arguments indicate whether the pattern we are under is+-- definitionally singular. Specifically, the first tracks the definitional+-- singularity of the last |PDef|/|PBoundVar| match, while the second tracks+-- the current definitional singularity.+-- The third argument and fourth arguments, k0 and k1, partition the context+-- into three chunks: the local context, the telescope of+-- of pattern variables associated with the rewrite and the pattern-lambda+-- bound variables.+-- The fifth argument is the type of the term. class PatternFrom a b where- patternFrom :: Relevance -> Int -> TypeOf a -> a -> TCM b+ patternFrom :: DefSing -> DefSing -> Int -> Int -> TypeOf a -> a -> TCM b instance (PatternFrom a b) => PatternFrom (Arg a) (Arg b) where- patternFrom r k t u = let r' = r `composeRelevance` getRelevance u- in traverse (patternFrom r' k $ unDom t) u+ patternFrom r0 r1 k0 k1 t u+ = let r1' = r1 `maxDefSing` relToDefSing (getRelevance u)+ in traverse (patternFrom r0 r1' k0 k1 $ unDom t) u -instance PatternFrom Elims [Elim' NLPat] where- patternFrom r k (t,hd) = \case+instance PatternFrom Elims PElims where+ patternFrom r0 r1 k0 k1 (t,hd) = \case [] -> return [] (Apply u : es) -> do (a, b) <- assertPi t- p <- patternFrom r k a u+ p <- patternFrom r0 r1 k0 k1 a u let t' = absApp b (unArg u) let hd' = hd . (Apply u:)- ps <- patternFrom r k (t',hd') es+ ps <- patternFrom r0 r1 k0 k1 (t',hd') es return $ Apply p : ps (IApply x y i : es) -> do (s, q, l, b, u, v) <- assertPath t let t' = El s $ unArg b `apply` [ defaultArg i ] let hd' = hd . (IApply x y i:) interval <- primIntervalType- p <- patternFrom r k interval i- ps <- patternFrom r k (t',hd') es+ p <- patternFrom r0 r1 k0 k1 interval i+ ps <- patternFrom r0 r1 k0 k1 (t',hd') es return $ IApply (PTerm x) (PTerm y) p : ps (Proj o f : es) -> do (a,b) <- assertProjOf f t let u = hd [] t' = b `absApp` u hd' <- applyDef o f (argFromDom a $> u)- ps <- patternFrom r k (t',applyE hd') es+ ps <- patternFrom r0 r1 k0 k1 (t',applyE hd') es return $ Proj o f : ps instance (PatternFrom a b) => PatternFrom (Dom a) (Dom b) where- patternFrom r k t = traverse $ patternFrom r k t+ patternFrom r0 r1 k0 k1 t = traverse $ patternFrom r0 r1 k0 k1 t instance PatternFrom Type NLPType where- patternFrom r k _ a = workOnTypes $- NLPType <$> patternFrom r k () (getSort a)- <*> patternFrom r k (sort $ getSort a) (unEl a)+ patternFrom r0 r1 k0 k1 _ a = workOnTypes $+ NLPType <$> patternFrom r0 r1 k0 k1 () (getSort a)+ <*> patternFrom r0 r1 k0 k1 (sort $ getSort a) (unEl a) instance PatternFrom Sort NLPSort where- patternFrom r k _ s = do+ patternFrom r0 r1 k0 k1 _ s = do s <- abortIfBlocked s case s of- Univ u l -> PUniv u <$> patternFrom r k () l+ Univ u l -> PUniv u <$> patternFrom r0 r1 k0 k1 () l Inf u n -> return $ PInf u n SizeUniv -> return PSizeUniv LockUniv -> return PLockUniv LevelUniv -> return PLevelUniv IntervalUniv -> return PIntervalUniv- PiSort _ _ _ -> __IMPOSSIBLE__+ PiSort{} -> __IMPOSSIBLE__ FunSort _ _ -> __IMPOSSIBLE__ UnivSort _ -> __IMPOSSIBLE__ MetaS{} -> __IMPOSSIBLE__@@ -112,37 +116,43 @@ __IMPOSSIBLE__ instance PatternFrom Level NLPat where- patternFrom r k _ l = do+ patternFrom r0 r1 k0 k1 _ l = do t <- levelType v <- reallyUnLevelView l- patternFrom r k t v+ patternFrom r0 r1 k0 k1 t v instance PatternFrom Term NLPat where- patternFrom r0 k t v = do+ patternFrom r0 r1 k0 k1 t v = do t <- abortIfBlocked t etaRecord <- isEtaRecordType t- prop <- isPropM t- let r = if prop then irrelevant else r0- v <- unLevel =<< abortIfBlocked v+ r1 <- maxDefSing r1 <$> isDefSing k0 k1 t+ -- We need to handle the primRewriteNoMatch primitive specially so need to+ -- stop it reducing away+ v <- modifyAllowedReductions (SmallSet.delete RewriteNoMatchReductions) $+ unLevel =<< abortIfBlocked v reportSDoc "rewriting.build" 60 $ sep [ "building a pattern from term v = " <+> prettyTCM v , " of type " <+> prettyTCM t ] pview <- pathViewAsPi'whnf+ noMatchPrim <- getPrimitive' builtinRewriteNoMatch+ let isRewriteNoMatch f = maybe False ((==) f . primFunName) noMatchPrim 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)+ p <- addContext a (patternFrom r0 r1 (k0 + 1) (k1 + 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)+ p <- addContext a (patternFrom r0 r1 (k0 + 1) (k1 + 1) (absBody b) body) return $ PLam (domInfo a) $ Abs (absName b) p (_ , Var i es)- | i < k -> do+ -- Variables before k0 are locally bound outside the rewrite telescope+ -- Variables after k1 are bound in higher order patterns+ | not $ isPatternVar k0 k1 i -> do t <- typeOfBV i- PBoundVar i <$> patternFrom r k (t , Var i) es+ PBoundVar i <$> patternFrom r1 r1 k0 k1 (t , Var i) es -- The arguments of `var i` should be distinct bound variables -- in order to build a Miller pattern | Just vs <- allApplyElims es -> do@@ -152,24 +162,35 @@ 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+ Just j | k0 < j || j < k1 -> return $ Just $ v $> j+ _ -> return Nothing case sequence mbvs of Just bvs | fastDistinct bvs -> do- let allBoundVars = IntSet.fromList (downFrom k)- ok = not (isIrrelevant r) ||- IntSet.fromList (map unArg bvs) == allBoundVars- if ok then return (PVar i bvs) else done+ let allBoundVars = VarSet.full k1+ ok = not (isAlwaysSing r1) ||+ VarSet.fromList (map unArg bvs) == allBoundVars+ if ok then return (PVar r0 i bvs) else done+ -- Important: Definitional singularity at |PVar|s should be+ -- that of the surrounding pattern (|r| rather than |r'|).+ -- If only the variable itself might be definitionally singular+ -- that is not a problem. _ -> done | otherwise -> done (_ , _ ) | Just (d, pars) <- etaRecord -> do RecordDefn def <- theDef <$> getConstInfo d- (tel, c, ci, vs) <- etaExpandRecord_ d pars def v- ct <- assertConOf c t- PDef (conName c) <$> patternFrom r k (ct , Con c ci) (map Apply vs)+ metelcivs <- etaExpandRecord_ d pars def v+ case metelcivs of+ Nothing -> done -- Issue #8636: cannot eta-expand+ Just (tel, c, ci, vs) -> do+ ct <- assertConOf c t+ PDef (conName c) <$> patternFrom r1 r1 k0 k1 (ct , Con c ci) (map Apply vs) (_ , Lam{}) -> errNotPi t (_ , Lit{}) -> done- (_ , Def f es) | isIrrelevant r -> done+ -- Terms wrapped in the primRewriteNoMatch primitive are converted to PTerms+ -- (i.e. rather than matching, we will just test conversion)+ (_ , Def f (l : a : Apply x : es)) | isRewriteNoMatch f ->+ return $ PTerm $ applyE (unArg x) es+ (_ , Def f es) | isAlwaysSing r1 -> done (_ , Def f es) -> do Def lsuc [] <- primLevelSuc Def lmax [] <- primLevelMax@@ -178,21 +199,21 @@ [x , y] | f == lmax -> done _ -> do ft <- defType <$> getConstInfo f- PDef f <$> patternFrom r k (ft , Def f) es- (_ , Con c ci vs) | isIrrelevant r -> done+ PDef f <$> patternFrom r1 r1 k0 k1 (ft , Def f) es+ (_ , Con c ci vs) | isAlwaysSing r1 -> done (_ , 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+ PDef (conName c) <$> patternFrom r1 r1 k0 k1 (ct , Con c ci) vs+ (_ , Pi a b) | isAlwaysSing r1 -> done (_ , Pi a b) -> do- pa <- patternFrom r k () a- pb <- addContext a (patternFrom r (k + 1) () $ absBody b)+ pa <- patternFrom r0 r1 k0 k1 () a+ pb <- addContext a (patternFrom r0 r1 (k0 + 1) (k1 + 1) () $ absBody b) return $ PPi pa (Abs (absName b) pb)- (_ , Sort s) -> PSort <$> patternFrom r k () s+ (_ , Sort s) -> PSort <$> patternFrom r0 r1 k0 k1 () s (_ , Level l) -> __IMPOSSIBLE__ (_ , DontCare{}) -> __IMPOSSIBLE__ (_ , MetaV m _) -> __IMPOSSIBLE__- (_ , Dummy s _) -> __IMPOSSIBLE_VERBOSE__ s+ (_ , Dummy s _) -> __IMPOSSIBLE_VERBOSE__ (show s) -- | Convert from a non-linear pattern to a term. @@ -216,7 +237,7 @@ instance NLPatToTerm NLPat Term where nlPatToTerm = \case- PVar i xs -> Var i . map Apply <$> nlPatToTerm xs+ PVar s i xs -> Var i . map Apply <$> nlPatToTerm xs PTerm u -> return u PDef f es -> (theDef <$> getConstInfo f) >>= \case Constructor{ conSrcCon = c } -> Con c ConOSystem <$> nlPatToTerm es@@ -240,15 +261,40 @@ nlPatToTerm PLevelUniv = return LevelUniv nlPatToTerm PIntervalUniv = return IntervalUniv +data PatVars = PatVars+ { neverSingPatVars :: VarSet+ -- ^ Variables bound in never definitionally singular contexts+ , maybeSingPatVars :: VarSet+ -- ^ Variables bound in possibly definitionally singular contexts+ }+ deriving (Eq)++instance Null PatVars where+ empty = PatVars empty empty+ null (PatVars ps ps') = null ps && null ps'++instance Semigroup PatVars where+ PatVars ps ps' <> PatVars qs qs' = PatVars (ps <> qs) (ps' <> qs')++instance Monoid PatVars where+ mempty = PatVars mempty mempty++instance Singleton (DefSing, Int) PatVars where+ singleton (NeverSing, x) = PatVars (singleton x) empty+ singleton (MaybeSing, x) = PatVars empty (singleton x)+ singleton (AlwaysSing, x) = __IMPOSSIBLE__+ -- | Gather the set of pattern variables of a non-linear pattern class NLPatVars a where- nlPatVarsUnder :: Int -> a -> IntSet+ nlPatVarsUnder :: Int -> a -> PatVars - nlPatVars :: a -> IntSet- nlPatVars = nlPatVarsUnder 0+ default nlPatVarsUnder ::+ ( NLPatVars p, Foldable f, Functor f, a ~ f p+ ) => Int -> a -> PatVars+ nlPatVarsUnder k x = fold $ nlPatVarsUnder k <$> x -instance {-# OVERLAPPABLE #-} (Foldable f, NLPatVars a) => NLPatVars (f a) where- nlPatVarsUnder k = foldMap $ nlPatVarsUnder k+ nlPatVars :: a -> PatVars+ nlPatVars = nlPatVarsUnder 0 instance NLPatVars NLPType where nlPatVarsUnder k (NLPType l a) = nlPatVarsUnder k (l, a)@@ -264,22 +310,27 @@ instance NLPatVars NLPat where nlPatVarsUnder k = \case- PVar i _ -> singleton $ i - k- PDef _ es -> nlPatVarsUnder k es- PLam _ p -> nlPatVarsUnder k p- PPi a b -> nlPatVarsUnder k (a, b)- PSort s -> nlPatVarsUnder k s+ PVar s i _ -> singleton (s, i - k)+ PDef _ es -> nlPatVarsUnder k es+ PLam _ p -> nlPatVarsUnder k p+ PPi a b -> nlPatVarsUnder k (a, b)+ PSort s -> nlPatVarsUnder k s PBoundVar _ es -> nlPatVarsUnder k es- PTerm{} -> empty+ PTerm{} -> empty instance (NLPatVars a, NLPatVars b) => NLPatVars (a,b) where- nlPatVarsUnder k (a,b) = nlPatVarsUnder k a `mappend` nlPatVarsUnder k b+ nlPatVarsUnder k (a,b) = nlPatVarsUnder k a <> nlPatVarsUnder k b instance NLPatVars a => NLPatVars (Abs a) where nlPatVarsUnder k = \case Abs _ v -> nlPatVarsUnder (k + 1) v NoAbs _ v -> nlPatVarsUnder k v +instance NLPatVars a => NLPatVars (Arg a) where+instance NLPatVars a => NLPatVars (Dom a) where+instance NLPatVars a => NLPatVars (Elim' a) where+instance NLPatVars PElims where+ -- | Get all symbols that a non-linear pattern matches against class GetMatchables a where getMatchables :: a -> [QName]@@ -294,13 +345,13 @@ instance GetMatchables a => GetMatchables (Abs a) where instance (GetMatchables a, GetMatchables b) => GetMatchables (a,b) where- getMatchables (x,y) = getMatchables x ++ getMatchables y+ getMatchables (x,y) = getMatchables x ++! getMatchables y instance GetMatchables NLPat where getMatchables p = case p of- PVar _ _ -> empty- PDef f es -> singleton f ++ getMatchables es+ PVar{} -> empty+ PDef f es -> singleton f ++! getMatchables es PLam _ x -> getMatchables x PPi a b -> getMatchables (a,b) PSort s -> getMatchables s@@ -320,38 +371,10 @@ PIntervalUniv -> empty instance GetMatchables Term where- getMatchables = getDefs' __IMPOSSIBLE__ singleton--instance GetMatchables RewriteRule where- getMatchables = getMatchables . rewPats---- | Only computes free variables that are not bound (see 'nlPatVars'),--- i.e., those in a 'PTerm'.--instance Free NLPat where- freeVars' = \case- PVar _ _ -> mempty- PDef _ es -> freeVars' es- PLam _ u -> freeVars' u- PPi a b -> freeVars' (a,b)- PSort s -> freeVars' s- PBoundVar _ es -> freeVars' es- PTerm t -> freeVars' t--instance Free NLPType where- freeVars' (NLPType s a) =- ifM (asks ((IgnoreNot ==) . feIgnoreSorts))- {- then -} (freeVars' (s, a))- {- else -} (freeVars' a)+ getMatchables = getDefListNoMetas -instance Free NLPSort where- freeVars' = \case- PUniv _ l -> freeVars' l- PInf f n -> mempty- PSizeUniv -> mempty- PLockUniv -> mempty- PLevelUniv -> mempty- PIntervalUniv -> mempty+instance GetMatchables GlobalRewriteRule where+ getMatchables = getMatchables . grPats -- Throws a pattern violation if the given term contains any -- metavariables.@@ -361,15 +384,13 @@ 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+errNotPi t = typeError . IlltypedRewriteRule =<< fsep [ prettyTCM t , "should be a function type, but it isn't." , "Do you have any non-confluent rewrite rules?"@@ -381,7 +402,7 @@ OType t -> errNotPath t errNotPath :: Type -> TCM a-errNotPath t = typeError . GenericDocError =<< fsep+errNotPath t = typeError . IlltypedRewriteRule =<< fsep [ prettyTCM t , "should be a path type, but it isn't." , "Do you have any non-confluent rewrite rules?"@@ -395,7 +416,7 @@ _ -> errNotProjOf f t errNotProjOf :: QName -> Type -> TCM a-errNotProjOf f t = typeError . GenericDocError =<< fsep+errNotProjOf f t = typeError . IlltypedRewriteRule =<< fsep [ prettyTCM f , "should be a projection from type" , prettyTCM t , "but it isn't." , "Do you have any non-confluent rewrite rules?"@@ -407,7 +428,7 @@ Nothing -> errNotConOf c t errNotConOf :: ConHead -> Type -> TCM a-errNotConOf c t = typeError . GenericDocError =<< fsep+errNotConOf c t = typeError . IlltypedRewriteRule =<< 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
@@ -61,7 +61,7 @@ import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.Lens-import Agda.Utils.List ( (!!!), initWithDefault )+import Agda.Utils.List hiding (Suffix) import qualified Agda.Utils.List as List import Agda.Utils.List1 ( List1, pattern (:|) ) import qualified Agda.Utils.List1 as List1@@ -71,21 +71,17 @@ import Agda.Syntax.Common.Pretty ( prettyShow ) import Agda.Utils.Size import Agda.Utils.Tuple+import qualified Agda.Utils.VarSet as VarSet import Agda.Utils.Impossible+import Agda.Utils.Singleton (singleton) --------------------------------------------------------------------------- -- * Data structures for checking arguments --------------------------------------------------------------------------- -- | Ranges of checked arguments, where present.-type MaybeRanges = [Maybe Range]--acElims :: ArgsCheckState a -> [Elim]-acElims = map caElim . acCheckedArgs--acRanges :: ArgsCheckState a -> MaybeRanges-acRanges = map caRange . acCheckedArgs+type ArgRanges = [Range] setACElims :: [Elim] -> ArgsCheckState a -> ArgsCheckState a setACElims es st = st{ acCheckedArgs = go es (acCheckedArgs st) }@@ -94,14 +90,12 @@ go (e : es) (ca : cas) = ca{ caElim = e } : go es cas go _ _ = __IMPOSSIBLE__ --- | A checked argument without constraint or range.-defaultCheckedArg :: Elim -> CheckedArg-defaultCheckedArg e = CheckedArg { caElim = e, caRange = Nothing, caConstraint = Nothing }- ----------------------------------------------------------------------------- -- * Applications ----------------------------------------------------------------------------- +-- | Extract the "head constraints" (currently lock constraints 'CheckLockedVars')+-- from the application checker (final) state. acHeadConstraints :: (Elims -> Term) -> ArgsCheckState a -> [Constraint] acHeadConstraints hd = go hd . acCheckedArgs where@@ -111,10 +105,12 @@ CheckedArg e _ mc : cas -> applyWhenJust mc (\ c -> (lazyAbsApp c (hd []) :)) $ go (hd . (e :)) cas +-- | Check the "head constraints" (currently lock constraints 'CheckLockedVars')+-- accumulated during checking of an application. checkHeadConstraints :: (Elims -> Term) -> ArgsCheckState a -> TCM Term checkHeadConstraints hd st = do- mapM_ solveConstraint_ (acHeadConstraints hd st)- return $ hd (acElims st)+ mapM_ solveConstraint_ $ acHeadConstraints hd st+ return $ hd $ map' caElim $ acCheckedArgs st -- | @checkApplication hd args e t@ checks an application.@@ -130,16 +126,16 @@ reportSDoc "tc.check.app" 20 $ vcat [ "checkApplication" , nest 2 $ "hd = " <+> prettyA hd- , nest 2 $ "args = " <+> sep (map prettyA args)+ , nest 2 $ "args = " <+> do prettyList $ fmap prettyA args , nest 2 $ "e = " <+> prettyA e , nest 2 $ "t = " <+> prettyTCM t ] reportSDoc "tc.check.app" 70 $ vcat [ "checkApplication (raw)"- , nest 2 $ text $ "hd = " ++ show hd- , nest 2 $ text $ "args = " ++ show (deepUnscope args)- , nest 2 $ text $ "e = " ++ show (deepUnscope e)- , nest 2 $ text $ "t = " ++ show t+ , nest 2 $ text $ "hd = " ++! show hd+ , nest 2 $ text $ "args = " ++! show (deepUnscope args)+ , nest 2 $ text $ "e = " ++! show (deepUnscope e)+ , nest 2 $ text $ "t = " ++! show t ] case unScope hd of -- Subcase: unambiguous projection@@ -148,26 +144,23 @@ -- Subcase: ambiguous projection A.Proj o p -> do- checkProjApp cmp e o (unAmbQ p) hd args t+ checkProjApp cmp e o p hd args t -- Subcase: unambiguous constructor A.Con ambC | Just c <- getUnambiguous ambC -> do -- augment c with record fields, but do not revert to original name- con <-- fromRightM- (sigError c (typeError $ AbstractConstructorNotInScope c)) $- getOrigConHead c+ con <- getOrigConHead c checkConstructorApplication cmp e t con hd args -- Subcase: ambiguous constructor- A.Con (AmbQ cs0) -> do+ A.Con ambC -> do let cont c = checkConstructorApplication cmp e t c hd args- afterDisambiguation cont $ disambiguateConstructor cs0 args t+ afterDisambiguation cont $ disambiguateConstructor ambC args t -- Subcase: pattern synonym A.PatternSyn n -> do- (ns, p) <- lookupPatternSyn n- p <- return $ setRange (getRange n) $ killRange $ vacuous p -- Pattern' Void -> Pattern' Expr+ A.PatternSynDefn ns p0 <- lookupPatternSyn n+ let p = setRange (getRange n) $ killRange $ vacuous p0 -- Pattern' Void -> Pattern' Expr -- Expand the pattern synonym by substituting for -- the arguments we have got and lambda-lifting -- over the ones we haven't.@@ -187,8 +180,7 @@ tTerm <- primAgdaTerm tName <- primQName - -- Andreas, 2021-05-13, can we use @initWithDefault __IMPOSSIBLE__@ here?- let argTel = init $ telToList tel -- last argument is the hole term+ let argTel = initWithDefault __IMPOSSIBLE__ $ telToList tel -- last argument is the hole term -- inspect macro type to figure out if arguments need to be wrapped in quote/quoteTerm mkArg :: Type -> NamedArg A.Expr -> NamedArg A.Expr@@ -233,11 +225,11 @@ target <- addContext tel newTypeMeta_ -- Z x y let holeType = telePi_ tel target -- (x : X) (y : Y x) → Z x y let hd = namedArg arg- (Just vs, EmptyTel) <- mapFst allApplyElims <$> checkArguments_ CmpLeq ExpandLast hd args tel+ (Just vs, EmptyTel) <- first allApplyElims <$> checkArguments_ CmpLeq ExpandLast hd args tel -- a b : (x : X) (y : Y x) (_, hole) <- newValueMeta RunMetaOccursCheck CmpLeq holeType unquoteM hd hole holeType- let rho = reverse (map unArg vs) ++# IdS -- [x := a, y := b]+ let rho = reverse (map' unArg vs) ++# IdS -- [x := a, y := b] coerce CmpEq (apply hole vs) (applySubst rho target) t -- H a b : A where metaTel :: [Arg a] -> TCM Telescope@@ -264,18 +256,23 @@ v <- checkExpr' CmpEq e t return (v, t) inferApplication exh hd args e = postponeInstanceConstraints $ do- SortKit{..} <- sortKit+ SortKit{ isNameOfUniv } <- sortKit case unScope hd of- A.Proj o p | isAmbiguous p -> inferProjApp e o (unAmbQ p) hd args+ A.Proj o p | isAmbiguous p -> inferProjApp e o p hd args A.Def' x s | Just (sz, u) <- isNameOfUniv x -> inferUniv sz u e x s args _ -> do+ -- Issue #8683: the side conditions on the arguments of the cubical+ -- primitives have to be checked in inference mode as well.+ mk <- cubicalPrimitiveArgsCheck hd (f, t0) <- inferHead hd res <- runExceptT $ checkArgumentsE CmpEq exh hd args t0 Nothing case res of- Right st@(ACState{acType = t1}) -> fmap (,t1) $ unfoldInlined =<< checkHeadConstraints f st+ Right st@(ACState{acType = t1}) -> fmap (,t1) $+ unfoldInlined =<< checkHeadConstraints f =<< checkCubicalPrimitiveArgs mk st Left problem -> do t <- workOnTypes $ newTypeMeta_- v <- postponeArgs problem CmpEq exh hd args t0 t $ \ st -> unfoldInlined =<< checkHeadConstraints f st+ v <- postponeArgs problem CmpEq exh hd args t0 t $ \ st ->+ unfoldInlined =<< checkHeadConstraints f =<< checkCubicalPrimitiveArgs mk st return (v, t) -----------------------------------------------------------------------------@@ -289,9 +286,9 @@ rel <- getRelevance . defArgInfo <$> getConstInfo x let app = case proj of- Nothing -> \ args -> Def x $ map Apply args+ Nothing -> \ args -> Def x $ map' Apply args Just p -> \ args -> projDropParsApply p o rel args- mapFst applyE <$> inferDef app x+ first applyE <$> inferDef app x -- | Infer the type of a head thing (variable, function symbol, or constructor). -- We return a function that applies the head to arguments.@@ -338,10 +335,7 @@ -- First, inferDef will try to apply the constructor -- to the free parameters of the current context. We ignore that.- con <-- fromRightM- (sigError c (typeError $ AbstractConstructorNotInScope c)) $- getOrigConHead c+ con <- getOrigConHead c (u, a) <- inferDef (\ _ -> Con con ConOCon []) c -- Next get the number of parameters in the current context.@@ -371,8 +365,10 @@ -- Irrelevant defs are only allowed in irrelevant position. -- Erased defs are only allowed in erased position (see #3855). checkModality x d+ reportSDoc "tc.term.def" 30 $ " checked modality!" case theDef d of GeneralizableVar{} -> do+ reportSDoc "tc.term.def" 30 $ " we are a GeneralizableVar" -- Generalizable variables corresponds to metas created -- at the point where they should be generalized. Module parameters -- have already been applied to the meta, so we don't have to do that@@ -383,10 +379,11 @@ debug [] t v return (v, t) _ -> do+ reportSDoc "tc.term.def" 30 $ " we are not a GeneralizableVar" -- since x is considered living in the top-level, we have to -- apply it to the current context vs <- freeVarsToApply x- reportSDoc "tc.term.def" 30 $ " free vars:" <+> prettyList_ (map prettyTCM vs)+ reportSDoc "tc.term.def" 30 $ " free vars:" <+> prettyList_ (map' prettyTCM vs) let t = defType d v = mkTerm vs -- applies x to vs, dropping parameters @@ -402,9 +399,9 @@ debug :: Args -> Type -> Term -> TCM () debug vs t v = do reportSDoc "tc.term.def" 60 $- "freeVarsToApply to def " <+> hsep (map (text . show) vs)+ "freeVarsToApply to def " <+> hsep (map' (text . show) vs) reportSDoc "tc.term.def" 10 $ vcat- [ "inferred def " <+> prettyTCM x <+> hsep (map prettyTCM vs)+ [ "inferred def " <+> prettyTCM x <+> hsep (map' prettyTCM vs) , nest 2 $ ":" <+> prettyTCM t , nest 2 $ "-->" <+> prettyTCM v ] @@ -421,14 +418,8 @@ -- not be any need to insert hidden lambdas. checkHeadApplication :: Comparison -> A.Expr -> Type -> A.Expr -> [NamedArg A.Expr] -> TCM Term checkHeadApplication cmp e t hd args = do- SortKit{..} <- sortKit+ SortKit{ isNameOfUniv } <- sortKit sharp <- fmap nameOfSharp <$> coinductionKit- pOr <- getNameOfConstrained builtinPOr- pComp <- getNameOfConstrained builtinComp- pHComp <- getNameOfConstrained builtinHComp- pTrans <- getNameOfConstrained builtinTrans- mglue <- getNameOfConstrained builtin_glue- mglueU <- getNameOfConstrained builtin_glueU case hd of A.Def' c s | Just (sz, u) <- isNameOfUniv c -> checkUniv sz u cmp e t c s args @@ -436,34 +427,63 @@ -- sharp we generate in the body of the wrapper is a Con. A.Def c | Just c == sharp -> checkSharpApplication e t c args - -- Cubical primitives- A.Def c | Just c == pComp -> defaultResult' $ Just $ checkPrimComp c- A.Def c | Just c == pHComp -> defaultResult' $ Just $ checkPrimHComp c- A.Def c | Just c == pTrans -> defaultResult' $ Just $ checkPrimTrans c- A.Def c | Just c == pOr -> defaultResult' $ Just $ checkPOr c- A.Def c | Just c == mglue -> defaultResult' $ Just $ check_glue c- A.Def c | Just c == mglueU -> defaultResult' $ Just $ check_glueU c-- _ -> defaultResult+ -- The cubical primitives get their side conditions checked here as well.+ _ -> defaultResult' =<< cubicalPrimitiveArgsCheck hd where- defaultResult :: TCM Term- defaultResult = defaultResult' Nothing- defaultResult' :: Maybe (MaybeRanges -> Args -> Type -> TCM Args) -> TCM Term+ defaultResult' :: Maybe (ArgRanges -> Args -> Type -> TCM Args) -> TCM Term defaultResult' mk = do (f, t0) <- inferHead hd- expandLast <- asksTC envExpandLast- checkArguments cmp expandLast hd args t0 t $ \ st@(ACState cas _fun t1 checkedTarget) -> do- let check :: Maybe (TCM Args)- check = do- k <- mk- vs <- allApplyElims $ map caElim cas- pure $ k (map caRange cas) vs t1- st' <- case check of- Just ck -> (`setACElims` st) . map Apply <$> ck- Nothing -> pure st+ expandLast <- viewTC eExpandLast+ checkArguments cmp expandLast hd args t0 t $ \ st@(ACState _cas _fun t1 checkedTarget) -> do+ st' <- checkCubicalPrimitiveArgs mk st v <- unfoldInlined =<< checkHeadConstraints f st' coerce' cmp checkedTarget v t1 t +-- | Which cubical primitive is this head, if any, and how are the side+-- conditions on its arguments checked?+--+-- These side conditions have to be verified wherever such a primitive is+-- elaborated. In particular also in inference mode (see 'inferApplication'),+-- which is used e.g. for the scrutinee of a @with@, the right-hand side of a+-- pattern-matching @let@, the principal argument of an ambiguous projection,+-- and the first argument of the reflection primitive @unify@. (Issue #8683.)+cubicalPrimitiveArgsCheck ::+ A.Expr+ -- ^ The head of the application.+ -> TCM (Maybe (ArgRanges -> Args -> Type -> TCM Args))+cubicalPrimitiveArgsCheck hd = case unScope hd of+ A.Def c -> loop c+ [ (builtinComp , checkPrimComp )+ , (builtinHComp , checkPrimHComp)+ , (builtinTrans , checkPrimTrans)+ , (builtinPOr , checkPOr )+ , (builtin_glue , check_glue )+ , (builtin_glueU, check_glueU )+ ]+ _ -> return Nothing+ where+ loop _ [] = return Nothing+ loop c ((b, k) : bks) = getNameOfConstrained b >>= \case+ Just c' | c' == c -> return $ Just $ k c+ _ -> loop c bks++-- | Check the side conditions on the arguments of a cubical primitive+-- (if the head is one), and return the possibly updated (blocked) arguments.+checkCubicalPrimitiveArgs ::+ Maybe (ArgRanges -> Args -> Type -> TCM Args)+ -- ^ Result of 'cubicalPrimitiveArgsCheck' for the head of the application.+ -> ArgsCheckState a+ -> TCM (ArgsCheckState a)+checkCubicalPrimitiveArgs mk st@(ACState cas _fun t1 _) = do+ let check :: Maybe (TCM Args)+ check = do+ k <- mk+ vs <- allApplyElims $ map' caElim cas+ pure $ k (map' caRange cas) vs t1+ case check of+ Just ck -> (`setACElims` st) . map' Apply <$> ck+ Nothing -> pure st+ -- Issue #3019 and #4170: Don't insert trailing implicits when checking arguments to existing -- metavariables. turnOffExpandLastIfExistingMeta :: A.Expr -> TCM a -> TCM a@@ -574,7 +594,7 @@ -> CheckArgumentsE' -- Case: no arguments, do not insert trailing hidden arguments: We are done.-checkArgumentsE' S{ sArgs = [], .. }+checkArgumentsE' S{ sArgs = [], sFun, sFunType, sChecked, sExpand } | isDontExpandLast sExpand = return $ ACState { acCheckedArgs = []@@ -584,12 +604,12 @@ } -- Case: no arguments, but need to insert trailing hiddens.-checkArgumentsE' S{ sArgs = [], .. } =+checkArgumentsE' S{ sArgs = [], sFun, sFunType, sChecked, sResultType } = traceCallE (CheckArguments sFun [] sFunType sResultType) $ lift $ do sResultType <- traverse (unEl <.> reduce) sResultType- (us, t) <- implicitArgs (-1) (expand sResultType) sFunType+ (ncargs, t) <- implicitCheckedArgs (-1) (\ h _x -> expand sResultType h) sFunType return $ ACState- { acCheckedArgs = map (defaultCheckedArg . Apply) us+ { acCheckedArgs = map' namedThing ncargs , acFun = sFun , acType = t , acData = sChecked@@ -603,9 +623,9 @@ -- Case: argument given. checkArgumentsE'- s@S{ sArgs = sArgs@((arg@(Arg info e), sArgsVisible) : args), .. } =+ s@S{ sArgs = sArgs@((arg@(Arg info e), sArgsVisible) : args), sArgsLen, sChecked, sComp, sFun, sFunType, sPathView, sResultType, sSkipCheck, sSizeLtChecked } = - traceCallE (CheckArguments sFun (map fst sArgs) sFunType sResultType) $ do+ traceCallE (CheckArguments sFun (map' fst sArgs) sFunType sResultType) $ do lift $ reportSDoc "tc.term.args" 30 $ sep [ "checkArgumentsE" -- , " sArgs =" <+> prettyA sArgs@@ -626,14 +646,14 @@ -- insert an instance argument if arg is not instance or has different name expand hy y = not (sameHiding hy hx) || maybe False (y /=) mx reportSDoc "tc.term.args" 30 $ vcat- [ "calling implicitNamedArgs"+ [ "calling implicitCheckedArgs" , nest 2 $ "hx = " <+> text (show hx) , nest 2 $ "mx = " <+> maybe "nothing" prettyTCM mx ]- (nargs, sFunType) <- lift $ implicitNamedArgs (-1) expand sFunType+ (ncargs, sFunType) <- lift $ implicitCheckedArgs (-1) expand sFunType -- Separate names from args.- let (mxs, us) = unzip $ map (\ (Arg ai (Named mx u)) -> (mx, Apply $ Arg ai u)) nargs- xs = catMaybes mxs+ let (mxs, cargs) = List.unzipWith (\ (Named mx ca) -> (mx, ca)) ncargs+ xs = catMaybes mxs -- We need a function type here, but we don't know which kind -- (implicit/explicit). But it might be possible to use injectivity to@@ -643,10 +663,10 @@ -- We are done inserting implicit args. Now, try to check @arg@. ifBlocked sFunType (\ _ sFunType -> throwError $ ACState- { acCheckedArgs = map defaultCheckedArg us+ { acCheckedArgs = cargs , acFun = sFun , acType = sFunType- , acData = map fst sArgs+ , acData = map' fst sArgs }) {- else -} $ \ _ sFunType -> do -- What can go wrong?@@ -693,89 +713,103 @@ (NotCheckedTarget, False, Just sResultType) | sArgsVisible -> do -- How many visible Π's (up to at most sArgsLen) does -- sFunType start with?- TelV tel tgt <- telViewUpTo' sArgsLen visible sFunType- let visiblePis = size tel+ tel <- runMaybeT $ safeTelViewUpTo' sArgsLen visible sFunType+ case tel of+ Nothing -> do+ -- Telescope has invalidated @rewrite arguments in it, so we+ -- have to delay checking the target type+ -- We could make this a bit more efficient by counting the+ -- number of @rewrite arguments and skipping exactly that many+ -- args+ return s { sSkipCheck = Skip }+ Just (TelV tel tgt) -> do+ let visiblePis = size tel - -- The free variables less than visiblePis in tgt.- freeInTgt =- fst $ IntSet.split visiblePis $ freeVars tgt+ -- The free variables less than visiblePis in tgt.+ freeInTgt =+ fst $ VarSet.split visiblePis $ freeVarSet 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- -- Andreas, 2024-03-01, issue #7158 reported by Amy.- -- We need to check that the arity of the function type- -- is sufficient before checking the target,- -- otherwise the target is non-sensical.- if visiblePis < sArgsLen then return s else do+ 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 `VarSet.member` freeInTgt+ then skip x+ else skip 0+ IsRigid -> do+ -- Andreas, 2024-03-01, issue #7158 reported by Amy.+ -- We need to check that the arity of the function type+ -- is sufficient before checking the target,+ -- otherwise the target is non-sensical.+ if visiblePis < sArgsLen then return s else 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+ -- Is any free variable in tgt less than+ -- visiblePis?+ let dep = not (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, sResultType, s) <-- if sSizeLtChecked- then return (False, sResultType, s)- else do- sResultType <- reduce sResultType- isSizeLt <- isSizeType sResultType <&> \case- Just (BoundedLt _) -> True- _ -> False- return ( isSizeLt- , sResultType- , s{ sResultType = Just sResultType- , sSizeLtChecked = True- , sSkipCheck =- if isSizeLt then Skip else DontSkip- }- )- if isSizeLt 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, sResultType, s) <-+ if sSizeLtChecked+ then return (False, sResultType, s)+ else do+ sResultType <- reduce sResultType+ isSizeLt <- isSizeType sResultType <&> \case+ Just (BoundedLt _) -> True+ _ -> False+ return ( isSizeLt+ , sResultType+ , s{ sResultType = Just sResultType+ , 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 sResultType ]- chk <-- traceCall- (CheckTargetType- (fuseRange sFun sArgs) tgt1 sResultType) $- CheckedTarget <$>- ifNoConstraints_ (compareType sComp tgt1 sResultType)- (return Nothing) (return . Just)- return s{ sChecked = chk }+ 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 sResultType ]+ chk <-+ traceCall+ (CheckTargetType+ (fuseRange sFun sArgs) tgt1 sResultType) $+ CheckedTarget <$>+ ifNoConstraints_ (compareType sComp tgt1 sResultType)+ (return Nothing) (return . Just)+ return s{ sChecked = chk } _ -> return s -- sFunType <- lift $ forcePi (getHiding info) -- (maybe "_" rangedThing $ nameOf e) sFunType case unEl sFunType of- Pi (Dom{domInfo = info', domName = dname, unDom = a}) b- | let name = bareNameWithDefault "_" dname,+ Pi dom@(unDom -> a) b+ | let info' = dom ^. dInfo,+ let dname = dom ^. dName,+ let name = bareNameWithDefault "_" dname, sameHiding info info' && (visible info || maybe True (name ==) mx) -> do- u <- lift $ applyModalityToContext info' $ do+ whenJust (domEq dom) \eq ->+ reportSDoc "rewriting" 30 $+ "Applying equational constraint to context: " <+> prettyTCM eq+ u <- lift $ applyDomToContext dom $ do -- Andreas, 2014-05-30 experiment to check non-dependent arguments -- after the spine has been processed. Allows to propagate type info -- from ascribed type into extended-lambdas. Would solve issue 1159.@@ -792,26 +826,18 @@ let e' = e { nameOf = (nameOf e) <|> dname } checkNamedArg (Arg info' e') a - let- c = case getLock info' of- IsLock{} -> Just $ Abs "t" $- CheckLockedVars (Var 0 []) (raise 1 sFunType)- (raise 1 $ Arg info' u) (raise 1 a)- _ -> Nothing- lift $ reportSDoc "tc.term.lock" 40 $ text "lock =" <+> text (show $ getLock info')- lift $ reportSDoc "tc.term.lock" 40 $- addContext (defaultDom $ sFunType) $- maybe (text "nothing") (prettyTCM . absBody) c+ c <- lift $ makeLockConstraint sFunType u -- save relevance info' from domain in argument- let ca = CheckedArg{ caElim = Apply (Arg info' u), caRange = Just (getRange e), caConstraint = c }- addCheckedArgs us ca $+ let ca = CheckedArg{ caElim = Apply (Arg info' u), caRange = getRange e, caConstraint = c }+ addCheckedArgs cargs ca $ checkArgumentsE' s{ sFunType = absApp b u } | otherwise -> do+ let info' = dom ^. dInfo reportSDoc "error" 10 $ nest 2 $ vcat- [ text $ "info = " ++ show info- , text $ "info' = " ++ show info'- , text $ "absName b = " ++ absName b- , text $ "nameOf e = " ++ show (nameOf e)+ [ text $ "info = " ++! show info+ , text $ "info' = " ++! show info'+ , text $ "absName b = " ++! absName b+ , text $ "nameOf e = " ++! show (nameOf e) ] wrongPi _@@ -821,25 +847,24 @@ u <- lift $ checkExpr (namedThing e) =<< primIntervalType let ca = CheckedArg { caElim = IApply (unArg x) (unArg y) u- , caRange = Just (getRange e)+ , caRange = getRange e , caConstraint = Nothing }- addCheckedArgs us ca $+ addCheckedArgs cargs ca $ checkArgumentsE' s{ sChecked = NotCheckedTarget , sFunType = El sort $ unArg bA `apply` [argN u] } _ -> shouldBePi where- -- Andrea: Here one would add constraints too. addCheckedArgs ::- Elims+ [CheckedArg] -> CheckedArg -> CheckArgumentsE' -> CheckArgumentsE'- addCheckedArgs us ca cont = do+ addCheckedArgs cas ca cont = do let upd :: ArgsCheckState a -> ArgsCheckState a- upd st = st{ acCheckedArgs = map defaultCheckedArg us ++ ca : acCheckedArgs st }+ upd st = st{ acCheckedArgs = cas ++! ca : acCheckedArgs st } -- Add checked arguments to both regular and exceptional result of @cont@. withError upd $ upd <$> cont @@ -914,11 +939,9 @@ checkArgumentsE cmp exh fun args (telePi tel __DUMMY_TYPE__) Nothing case z of Right (ACState cas _ t _) -> do- unless (all (isNothing . caConstraint) cas) do- typeError $ NotSupported $- "Head constraints are not (yet) supported in this position."+ es <- noHeadConstraints cas let TelV tel' _ = telView' t- return (map caElim cas, tel')+ return (es, tel') Left _ -> __IMPOSSIBLE__ -- type cannot be blocked as it is generated by telePi -- | @checkArguments cmp exph hd args t0 t k@ tries @checkArgumentsE cmp exph hd args t0 t@.@@ -971,20 +994,20 @@ postponeArgs (ACState cas fun t1 es) cmp exph hd args t0 t k = do reportSDoc "tc.term.expr.args" 80 $ sep [ "postponed checking arguments"- , nest 4 $ prettyList (map (prettyA . namedThing . unArg) args)+ , nest 4 $ prettyList (map' (prettyA . namedThing . unArg) args) , nest 2 $ "against" , nest 4 $ prettyTCM t0 ] $$ sep [ "progress:"- , nest 2 $ "checked" <+> prettyList (map (prettyTCM . caElim) cas)+ , nest 2 $ "checked" <+> prettyList (map' (prettyTCM . caElim) cas) , nest 2 $ "remaining" <+> sep- [ prettyList (map (prettyA . namedThing . unArg) es)+ [ prettyList (map' (prettyA . namedThing . unArg) es) , nest 2 $ ":" <+> prettyTCM t1 ] ] postponeTypeCheckingProblem_ $ CheckArgs cmp exph fun es t1 t $ \ (ACState cas' func t pid) ->- k $ ACState (cas ++ cas') func t pid+ k $ ACState (cas ++! cas') func t pid ----------------------------------------------------------------------------- -- * Constructors@@ -1014,7 +1037,7 @@ [ "org =" <+> prettyTCM org , "t =" <+> prettyTCM t , "c =" <+> prettyTCM c- , "args =" <+> prettyTCM args+ , "args =" <+> do prettyList $ fmap prettyTCM args ] ] cdef <- getConInfo c@@ -1044,8 +1067,8 @@ -- from t = Def d' vs, we drop the additional parameters. npars' <- getNumberOfParameters d' caseMaybe (sequenceA $ Pair (Just npars) npars') fallback $ \ (Pair n n') -> do- reportSDoc "tc.term.con" 50 $ nest 2 $ text $ "n = " ++ show n- reportSDoc "tc.term.con" 50 $ nest 2 $ text $ "n' = " ++ show n'+ reportSDoc "tc.term.con" 50 $ nest 2 $ text $ "n = " ++! show n+ reportSDoc "tc.term.con" 50 $ nest 2 $ text $ "n' = " ++! show n' when (n > n') -- preprocessor does not like ', so put on next line __IMPOSSIBLE__ let ps = take n $ drop (n' - n) vs@@ -1058,11 +1081,11 @@ reportSDoc "tc.term.con" 20 $ nest 2 $ "ctype' =" <+> prettyTCM ctype' -- get the parameter names let TelV ptel _ = telView'UpTo n ctype- let pnames = map (fmap fst) $ telToList ptel+ let pnames = map' (fmap fst) $ telToList ptel -- drop the parameter arguments args' = dropArgs pnames args -- check the non-parameter arguments- expandLast <- asksTC envExpandLast+ expandLast <- viewTC eExpandLast checkArguments cmp expandLast hd args' ctype' t \ st@(ACState _ _ t' targetCheck) -> do reportSDoc "tc.term.con" 20 $ nest 2 $ vcat [ text "es =" <+> prettyTCM es@@ -1112,20 +1135,21 @@ -- | Successfully disambiguate constructor with given choice. decideOn :: ConHead -> DisambiguateConstructor decideOn c = do- reportSLn "tc.check.term.con" 40 $ " decided on: " ++ prettyShow c+ reportSLn "tc.check.term.con" 40 $ " decided on: " ++! prettyShow c storeDisambiguatedConstructor (conInductive c) (conName c) return $ Right c -- | Returns an unblocking action in case of failure.-disambiguateConstructor :: List1 QName -> A.Args -> Type -> DisambiguateConstructor-disambiguateConstructor cs0 args t = do- reportSLn "tc.check.term.con" 40 $ "Ambiguous constructor: " ++ prettyShow cs0- reportSDoc "tc.check.term.con" 40 $ vcat $ "Arguments:" : map (nest 2 . prettyTCM) args+disambiguateConstructor :: AmbiguousQName -> A.Args -> Type -> DisambiguateConstructor+disambiguateConstructor ambC args t = do+ reportSLn "tc.check.term.con" 40 $ "Ambiguous constructor: " ++! prettyShow ambC+ reportSDoc "tc.check.term.con" 40 $ vcat $ "Arguments:" : map' (nest 2 . prettyTCM) args+ let cs0 = getAmbiguous ambC -- Get the datatypes of the various constructors let getData Constructor{conData = d} = d getData _ = __IMPOSSIBLE__- reportSLn "tc.check.term.con" 40 $ " ranges before: " ++ prettyShow (getRange cs0)+ reportSLn "tc.check.term.con" 40 $ " ranges before: " ++! prettyShow (getRange cs0) -- We use the reduced constructor when disambiguating, but -- the original constructor for type checking. This is important -- since they may have different types (different parameters).@@ -1133,12 +1157,12 @@ -- Andreas, 2017-08-13, issue #2686: ignore abstract constructors ccons <- List1.rights <$> do forM cs0 $ \ c -> mapRight (c,) <$> getConForm c- reportSLn "tc.check.term.con" 40 $ " reduced: " ++ prettyShow (map snd ccons)+ reportSLn "tc.check.term.con" 40 $ " reduced: " ++! prettyShow (map' snd ccons) case ccons of [] -> typeError $ AbstractConstructorNotInScope $ List1.head cs0 [(c0,con)] -> do let c = setConName c0 con- reportSLn "tc.check.term.con" 40 $ " only one non-abstract constructor: " ++ prettyShow c+ reportSLn "tc.check.term.con" 40 $ " only one non-abstract constructor: " ++! prettyShow c decideOn c cons@(c0,_):conss -> do dcs :: List1 (QName, Type, ConHead) <- forM (cons :| conss) $ \ (c, con) -> do@@ -1173,7 +1197,7 @@ ifBlocked t1 (\ b _ -> disambiguateByArgs dcs args $ postpone b) $ \ _ t' -> caseMaybeM (isDataOrRecord $ unEl t') (badCon t') $ \ (d, _) -> do let dcs' = filter ((d ==) . fst3) dcs- case map thd3 dcs' of+ case map' thd3 dcs' of [c] -> decideOn c [] -> badCon $ t' $> Def d [] -- If the information from the target type did not eliminate ambiguity fully,@@ -1202,9 +1226,9 @@ -- without full-fledged type inference. askel <- visibleVarArgs reportSDoc "tc.check.term.con" 40 $ hsep $- "trying disambiguation by arguments" : map prettyTCM askel+ "trying disambiguation by arguments" : map' prettyTCM askel reportSDoc "tc.check.term.con" 80 $ hsep $- "trying disambiguation by arguments" : map pretty askel+ "trying disambiguation by arguments" : map' pretty askel -- Filter out candidates with definitive mismatches. cands <- filterM (\ (_d, t, _c) -> matchSkel askel =<< visibleConDoms t) dcs@@ -1307,7 +1331,7 @@ -- | Inferring the type of an overloaded projection application. -- See 'inferOrCheckProjApp'. -inferProjApp :: A.Expr -> ProjOrigin -> List1 QName -> A.Expr -> A.Args -> TCM (Term, Type)+inferProjApp :: A.Expr -> ProjOrigin -> AmbiguousQName -> A.Expr -> A.Args -> TCM (Term, Type) inferProjApp e o ds hd args0 = do (v, t, _) <- inferOrCheckProjApp e o ds hd args0 Nothing return (v, t)@@ -1315,7 +1339,7 @@ -- | Checking the type of an overloaded projection application. -- See 'inferOrCheckProjApp'. -checkProjApp :: Comparison -> A.Expr -> ProjOrigin -> List1 QName -> A.Expr -> A.Args -> Type -> TCM Term+checkProjApp :: Comparison -> A.Expr -> ProjOrigin -> AmbiguousQName -> A.Expr -> A.Args -> Type -> TCM Term checkProjApp cmp e o ds hd args0 t = do (v, ti, targetCheck) <- inferOrCheckProjApp e o ds hd args0 (Just (cmp, t)) coerce' cmp targetCheck v ti t@@ -1327,7 +1351,7 @@ Comparison -> A.Expr -> ProjOrigin- -> List1 QName+ -> AmbiguousQName -> A.Expr -> A.Args -> Type@@ -1350,7 +1374,7 @@ -- ^ The whole expression which constitutes the application. -> ProjOrigin -- ^ The origin of the projection involved in this projection application.- -> List1 QName+ -> AmbiguousQName -- ^ The projection name (potentially ambiguous). -> A.Expr -- ^ The projection as expression.@@ -1363,8 +1387,8 @@ inferOrCheckProjApp e o ds hd args mt = do reportSDoc "tc.proj.amb" 20 $ vcat [ "checking ambiguous projection"- , text $ " ds = " ++ prettyShow ds- , text " args = " <+> sep (map prettyTCM args)+ , text $ " ds = " ++! prettyShow ds+ , text " args = " <+> do prettyList $ fmap prettyTCM args , text " t = " <+> caseMaybe mt "Nothing" prettyTCM ] @@ -1399,7 +1423,7 @@ ifBlocked (unDom dom) (\ m _ -> postpone m) $ {-else-} \ _ ta -> do caseMaybeM (isRecordType ta) (refuseProjNotRecordType ds Nothing ta) \ (_q, _pars, RecordData{ _recFields = fs }) -> do- case forMaybe fs $ \ f -> Fold.find (unDom f ==) ds of+ case forMaybe fs $ \ f -> Fold.find (unDom f ==) (getAmbiguous ds) of [] -> refuseProjNoMatching ds [d] -> do storeDisambiguatedProjection d@@ -1424,7 +1448,7 @@ -- ^ The whole expression which constitutes the application. -> ProjOrigin -- ^ The origin of the projection involved in this projection application.- -> List1 QName+ -> AmbiguousQName -- ^ The projection name (potentially ambiguous). -> A.Expr -- ^ The projection (as application head).@@ -1463,7 +1487,7 @@ -- try to project it with all of the possible projections let try d = do reportSDoc "tc.proj.amb" 30 $ vcat- [ text $ "trying projection " ++ prettyShow d+ [ text $ "trying projection " ++! prettyShow d , " td = " <+> caseMaybeM (getDefType d ta) "Nothing" prettyTCM ] @@ -1471,10 +1495,10 @@ def <- lift $ getConstInfo d let isP = isProjection_ $ theDef def reportSDoc "tc.proj.amb" 40 $ vcat $- text ( " isProjection = " ++ caseMaybe isP "no" (const "yes")+ text ( " isProjection = " ++! caseMaybe isP "no" (const "yes") ) : caseMaybe isP [] (\ Projection{ projProper = proper, projOrig = orig } ->- [ text $ " proper = " ++ show proper- , text $ " orig = " ++ prettyShow orig+ [ text $ " proper = " ++! show proper+ , text $ " orig = " ++! prettyShow orig ]) -- Andreas, 2017-01-21, issue #2422@@ -1507,8 +1531,8 @@ let tfull = defType def TelV tel _ <- lift $ telViewUpTo' (-1) (not . visible) tfull reportSDoc "tc.proj.amb" 30 $ vcat- [ text $ " size tel = " ++ show (size tel)- , text $ " size pars = " ++ show (size pars)+ [ text $ " size tel = " ++! show (size tel)+ , text $ " size pars = " ++! show (size pars) ] -- See issue 1960 for when the following assertion fails for -- the correct disambiguation.@@ -1517,7 +1541,7 @@ guard =<< do isNothing <$> do lift $ checkModality' d def return (orig, (d, (pars, (dom, u, tb)))) - cands <- List1.groupOn fst . List1.catMaybes <$> mapM (runMaybeT . try) ds+ cands <- List1.groupOn fst . List1.catMaybes <$> mapM (runMaybeT . try) (getAmbiguous ds) case cands of [] -> refuseProjNoMatching ds (_:_:_) -> refuseProj ds $ fwords "several matching candidates can be applied."@@ -1529,13 +1553,15 @@ -- Check parameters tfull <- typeOfConst d- (args0, princArg : args') <- pure $ splitAt k args+ (args0, princArg : args') <- pure $ splitAt' k args (_,_) <- checkKnownArguments args0 pars tfull -- Check remaining arguments- fun <- pure $ A.App (A.defaultAppInfo $ getRange (hd, args0, princArg))- (A.unAppView $ A.Application hd args0)- princArg+ let+ fun = A.App+ (A.defaultAppInfo $ getRange (hd, args0, princArg))+ (A.unAppView $ A.Application hd args0)+ princArg z <- runExceptT $ checkArgumentsE cmp ExpandLast fun args' tb (snd <$> mt) case z of Right st@(ACState _ _ trest targetCheck) -> do@@ -1553,13 +1579,13 @@ return (v, tc, NotCheckedTarget) -- | Throw 'AmbiguousOverloadedProjection' with additional explanation.-refuseProj :: List1 QName -> TCM Doc -> TCM a+refuseProj :: AmbiguousQName -> TCM Doc -> TCM a refuseProj ds reason = typeError . AmbiguousOverloadedProjection ds =<< reason -refuseProjNotApplied, refuseProjNoMatching :: List1 QName -> TCM a+refuseProjNotApplied, refuseProjNoMatching :: AmbiguousQName -> TCM a refuseProjNotApplied ds = refuseProj ds $ fwords "it is not applied to a visible argument" refuseProjNoMatching ds = refuseProj ds $ fwords "no matching candidate found"-refuseProjNotRecordType :: List1 QName -> Maybe Term -> Type -> TCM a+refuseProjNotRecordType :: AmbiguousQName -> Maybe Term -> Type -> TCM a refuseProjNotRecordType ds pValue pType = do let dType = prettyTCM pType let dValue = caseMaybe pValue (return empty) prettyTCM@@ -1635,7 +1661,7 @@ -- The name of the fresh function. i <- fresh :: TCM Int- let name = filter (/= '_') (prettyShow $ A.nameConcrete $ A.qnameName c) ++ "-" ++ show i+ let name = filter (/= '_') (prettyShow $ A.nameConcrete $ A.qnameName c) ++! "-" ++! show i kit <- coinductionKit' let flat = nameOfFlat kit@@ -1687,7 +1713,7 @@ (defaultDefn ai c' forcedType lang fun) { defMutual = i } - checkFunDef info c' [clause]+ checkFunDef info c' $ singleton clause reportSDoc "tc.term.expr.coind" 15 $ do def <- theDef <$> getConstInfo c'@@ -1701,7 +1727,7 @@ -- The application of the fresh function to the relevant -- arguments.- e' <- Def wrapper . map Apply <$> getContextArgs+ e' <- Def wrapper . map' Apply <$> getContextArgs reportSDoc "tc.term.expr.coind" 15 $ vcat $ [ "The coinductive constructor application"@@ -1727,7 +1753,7 @@ -- -- Check: @u i0 = (λ _ → a) : Partial φ (A i0)@. ---checkPrimComp :: QName -> MaybeRanges -> Args -> Type -> TCM Args+checkPrimComp :: QName -> ArgRanges -> Args -> Type -> TCM Args checkPrimComp c rs vs _ = do case vs of -- WAS: [l, a, phi, u, a0] -> do@@ -1748,7 +1774,7 @@ -- -- Check: @u i0 = (λ _ → a) : Partial φ A@. ---checkPrimHComp :: QName -> MaybeRanges -> Args -> Type -> TCM Args+checkPrimHComp :: QName -> ArgRanges -> Args -> Type -> TCM Args checkPrimHComp c rs vs _ = do case vs of -- WAS: [l, a, phi, u, a0] -> do@@ -1770,7 +1796,7 @@ -- -- Check: If φ, then @A i = A i0 : Set (ℓ i)@ must hold for all @i : I@. ---checkPrimTrans :: QName -> MaybeRanges -> Args -> Type -> TCM Args+checkPrimTrans :: QName -> ArgRanges -> Args -> Type -> TCM Args checkPrimTrans c rs vs _ = do case vs of -- Andreas, 2019-03-02, issue #3601, why exactly 4 arguments?@@ -1803,7 +1829,7 @@ -- ' → PartialP (φ₁ ∨ φ₂) A@ -- ' -- ' Checks: @u = v : PartialP (φ₁ ∨ φ₂) A@ whenever @IsOne (φ₁ ∧ φ₂)@.-checkPOr :: QName -> MaybeRanges -> Args -> Type -> TCM Args+checkPOr :: QName -> ArgRanges -> Args -> Type -> TCM Args checkPOr c rs vs _ = do case vs of l : phi1 : phi2 : a : u : v : rest -> do@@ -1831,7 +1857,7 @@ -- → (t : PartialP φ T) → (a : A) → primGlue A T e@ -- -- Check @φ ⊢ a = e 1=1 (t 1=1)@ or actually the equivalent: @(\ _ → a) = (\ o -> e o (t o)) : PartialP φ A@-check_glue :: QName -> MaybeRanges -> Args -> Type -> TCM Args+check_glue :: QName -> ArgRanges -> Args -> Type -> TCM Args check_glue c rs vs _ = do case vs of -- WAS: [la, lb, bA, phi, bT, e, t, a] -> do@@ -1864,7 +1890,7 @@ -- -- Check @φ ⊢ a = transp (\ i -> T 1=1 (~ i)) i0 (t 1=1)@ or actually the equivalent: -- @(\ _ → a) = (\o -> transp (\ i -> T o (~ i)) i0 (t o)) : PartialP φ (T i0)@-check_glueU :: QName -> MaybeRanges -> Args -> Type -> TCM Args+check_glueU :: QName -> ArgRanges -> Args -> Type -> TCM Args check_glueU c rs vs _ = do case vs of -- WAS: [la, lb, bA, phi, bT, e, t, a] -> do
src/full/Agda/TypeChecking/Rules/Application.hs-boot view
@@ -2,8 +2,6 @@ module Agda.TypeChecking.Rules.Application where -import Data.List.NonEmpty (NonEmpty)- import Agda.Syntax.Common (NamedArg, ProjOrigin) import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Internal@@ -35,7 +33,7 @@ Comparison -> A.Expr -> ProjOrigin- -> NonEmpty QName+ -> AmbiguousQName -> A.Expr -> A.Args -> Type
src/full/Agda/TypeChecking/Rules/Builtin.hs view
@@ -16,13 +16,14 @@ import Control.Monad.Except ( catchError ) import Control.Monad.Trans.Maybe -import Data.List (find, sortBy)-import Data.Function (on)+import Data.List (find) import Agda.Interaction.Options.Base -import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Abstract qualified as A import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty (prettyShow)+import Agda.Syntax.Concrete.Name qualified as C import Agda.Syntax.Internal import Agda.Syntax.Position import Agda.Syntax.Scope.Base@@ -34,7 +35,6 @@ import Agda.TypeChecking.Constraints ( noConstraints ) import Agda.TypeChecking.Functions import Agda.TypeChecking.Names-import Agda.TypeChecking.Pretty import Agda.TypeChecking.Primitive import Agda.TypeChecking.Positivity.Occurrence import Agda.TypeChecking.Reduce@@ -48,7 +48,8 @@ import Agda.Utils.Functor import Agda.Utils.List-import Agda.Utils.List1 (pattern (:|))+import Agda.Utils.List1 (List1, pattern (:|))+import Agda.Utils.List2 (List2(List2)) import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null@@ -111,27 +112,27 @@ , (builtinAgdaMeta |-> builtinPostulate tset) , (builtinIO |-> builtinPostulate (tset --> tset)) , (builtinPath |-> BuiltinUnknown- (Just $ requireCubical CErased >>+ (Just $ requireCubical CWithoutGlue >> hPi "a" (el primLevel) ( hPi "A" (return $ sort $ varSort 0) $ (El (varSort 1) <$> varM 0) --> (El (varSort 1) <$> varM 0) --> return (sort $ varSort 1))) verifyPath)- , (builtinPathP |-> builtinPostulateC CErased (hPi "a" (el primLevel) $+ , (builtinPathP |-> builtinPostulateC CWithoutGlue (hPi "a" (el primLevel) $ nPi "A" (tinterval --> return (sort $ varSort 0)) $ (El (varSort 1) <$> varM 0 <@> primIZero) --> (El (varSort 1) <$> varM 0 <@> primIOne) --> return (sort $ varSort 1))) , (builtinIntervalUniv |-> BuiltinSort SortIntervalUniv)- , (builtinInterval |-> BuiltinData (requireCubical CErased >>+ , (builtinInterval |-> BuiltinData (requireCubical CWithoutGlue >> return (sort IntervalUniv)) [builtinIZero,builtinIOne])- , (builtinSub |-> builtinPostulateC CErased (runNamesT [] $ hPi' "a" (el $ cl primLevel) $ \ a ->+ , (builtinSub |-> builtinPostulateC CWithoutGlue (runNamesT [] $ hPi' "a" (el $ cl primLevel) $ \ a -> nPi' "A" (el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA -> nPi' "φ" (cl tinterval) $ \ phi -> el's a (cl primPartial <#> a <@> phi <@> bA) --> (ssort . atomicLevel <$> a) ))- , (builtinSubIn |-> builtinPostulateC CErased (runNamesT [] $+ , (builtinSubIn |-> builtinPostulateC CWithoutGlue (runNamesT [] $ hPi' "a" (el $ cl primLevel) $ \ a -> hPi' "A" (el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA -> hPi' "φ" (cl tinterval) $ \ phi ->@@ -141,26 +142,26 @@ , (builtinIOne |-> BuiltinDataCons tinterval) , (builtinPartial |-> BuiltinPrim PrimPartial (const $ return ())) , (builtinPartialP |-> BuiltinPrim PrimPartialP (const $ return ()))- , (builtinIsOne |-> builtinPostulateC CErased (tinterval --> return (ssort $ ClosedLevel 0)))- , (builtinItIsOne |-> builtinPostulateC CErased (elSSet $ primIsOne <@> primIOne))- , (builtinIsOne1 |-> builtinPostulateC CErased (runNamesT [] $+ , (builtinIsOne |-> builtinPostulateC CWithoutGlue (tinterval --> return (ssort $ ClosedLevel 0)))+ , (builtinItIsOne |-> builtinPostulateC CWithoutGlue (elSSet $ primIsOne <@> primIOne))+ , (builtinIsOne1 |-> builtinPostulateC CWithoutGlue (runNamesT [] $ nPi' "i" (cl tinterval) $ \ i -> nPi' "j" (cl tinterval) $ \ j -> nPi' "i1" (elSSet $ cl primIsOne <@> i) $ \ i1 -> (elSSet $ cl primIsOne <@> (cl primIMax <@> i <@> j))))- , (builtinIsOne2 |-> builtinPostulateC CErased (runNamesT [] $+ , (builtinIsOne2 |-> builtinPostulateC CWithoutGlue (runNamesT [] $ nPi' "i" (cl tinterval) $ \ i -> nPi' "j" (cl tinterval) $ \ j -> nPi' "j1" (elSSet $ cl primIsOne <@> j) $ \ j1 -> (elSSet $ cl primIsOne <@> (cl primIMax <@> i <@> j))))- , (builtinIsOneEmpty |-> builtinPostulateC CErased (runNamesT [] $+ , (builtinIsOneEmpty |-> builtinPostulateC CWithoutGlue (runNamesT [] $ hPi' "l" (el $ cl primLevel) $ \ l -> hPi' "A" (pPi' "o" (cl primIZero) $ \ _ -> el' (cl primLevelSuc <@> l) (Sort . tmSort <$> l)) $ \ bA -> pPi' "o" (cl primIZero) (\ o -> el' l $ gApply' defaultIrrelevantArgInfo bA o))) - , (builtinEquiv |-> BuiltinUnknown (Just $ requireCubical CErased >> runNamesT [] (+ , (builtinEquiv |-> BuiltinUnknown (Just $ requireCubical CWithoutGlue >> runNamesT [] ( hPi' "l" (el $ cl primLevel) $ \ a -> hPi' "l'" (el $ cl primLevel) $ \ b -> nPi' "A" (sort . tmSort <$> a) $ \bA ->@@ -168,7 +169,7 @@ ((sort . tmSort) <$> (cl primLevelMax <@> a <@> b)) )) (const $ const $ return ()))- , (builtinEquivFun |-> BuiltinUnknown (Just $ requireCubical CErased >> runNamesT [] (+ , (builtinEquivFun |-> BuiltinUnknown (Just $ requireCubical CWithoutGlue >> runNamesT [] ( hPi' "l" (el $ cl primLevel) $ \ a -> hPi' "l'" (el $ cl primLevel) $ \ b -> hPi' "A" (sort . tmSort <$> a) $ \bA ->@@ -177,7 +178,7 @@ (el' a bA --> el' b bB) )) (const $ const $ return ()))- , (builtinEquivProof |-> BuiltinUnknown (Just $ requireCubical CErased >> runNamesT [] (+ , (builtinEquivProof |-> BuiltinUnknown (Just $ requireCubical CWithoutGlue >> runNamesT [] ( hPi' "l" (el $ cl primLevel) $ \ la -> hPi' "l'" (el $ cl primLevel) $ \ lb -> nPi' "A" (sort . tmSort <$> la) $ \ bA ->@@ -197,7 +198,7 @@ el' lub (cl primSub <#> lub <#> fmap unEl fiber <@> phi <@> pfib) )) (const $ const $ return ()))- , (builtinTranspProof |-> BuiltinUnknown (Just $ requireCubical CErased >> runNamesT [] (+ , (builtinTranspProof |-> BuiltinUnknown (Just $ requireCubical CWithoutGlue >> runNamesT [] ( hPi' "l" (el $ cl primLevel) $ \ la -> do nPi' "e" (cl tinterval --> (sort . tmSort <$> la)) $ \ e -> do let lb = la; bA = e <@> cl primIZero; bB = e <@> cl primIOne@@ -333,6 +334,10 @@ , (builtinPropOmega |-> BuiltinSort SortPropOmega) , (builtinSetOmega |-> BuiltinSort SortSetOmega) , (builtinSSetOmega |-> BuiltinSort SortStrictSetOmega)+ , (builtinQuotientConstructor |-> BuiltinUnknown Nothing+ (\_ _ ->+ unlessM currentModuleIsBuiltinModuleWithSafePostulates $+ typeError $ TrustedBuiltin BuiltinQuotientConstructor)) , (builtinAgdaClause |-> BuiltinData tset [builtinAgdaClauseClause, builtinAgdaClauseAbsurd]) , (builtinAgdaClauseClause |-> BuiltinDataCons (ttelescope --> tlist (targ tpat) --> tterm --> tclause)) , (builtinAgdaClauseAbsurd |-> BuiltinDataCons (ttelescope --> tlist (targ tpat) --> tclause))@@ -672,14 +677,13 @@ return a getBuiltinArity (BuiltinDataCons t) = arity <$> t getBuiltinArity _ = __IMPOSSIBLE__- sortByM f xs = map fst . sortBy (compare `on` snd) . zip xs <$> mapM f xs -- Order constructurs by arity- cs <- sortByM getArity cs+ cs <- sortOnM getArity cs -- Do the same for the builtins let bcis = fromMaybe __IMPOSSIBLE__ $ do BuiltinData _ bcs <- builtinDesc <$> findBuiltinInfo s mapM findBuiltinInfo bcs- bcis <- sortByM (getBuiltinArity . builtinDesc) bcis+ bcis <- sortOnM (getBuiltinArity . builtinDesc) bcis unless (length cs == length bcis) __IMPOSSIBLE__ -- we already checked this zipWithM_ (\ c bci -> bindBuiltinInfo bci (A.Con $ unambiguous $ setRange (getRange name) c)) cs bcis @@ -695,11 +699,20 @@ bindBuiltinSigma :: Term -> TCM () bindBuiltinSigma t = do- sigma <- fromMaybe __IMPOSSIBLE__ <$> getDef t- def <- theDef <$> getConstInfo sigma- case def of- Record { recFields = [fst,snd], recConHead = con } -> do- bindBuiltinName builtinSigma t+ def <- getConstInfo =<< fromMaybe __IMPOSSIBLE__ <$> getDef t+ case theDef def of+ Record { recFields = [_fst, _snd], recTel = tel } -> do+ -- The type of Sigma is @(a : Level) (b : Level) (A : Set a) (B : A -> Set b) -> Set _@. This is checked elsewhere.+ -- The type of the constructor should be @(a : Level) (b : Level) (A : Set a) (B : A -> Set b) (fst : A) (snd : B fst) -> _@.+ -- @fst@ should have type @A@.+ -- @snd@ should have type @B fst@.+ case map (snd . unDom) $ telToList tel of+ -- [@0:Level, @1:Level, @2:Set@0, @3:(_:@0)->Set@2, @4:@1, @5:(@1 @0)]+ [_lA, _lB, _sA, _sB, El _ (Var 1 []), El _ (Var 1 [Apply (Arg _ (Var 0 []))])] ->+ bindBuiltinName builtinSigma t+ tel' -> do+ reportSLn "tc.builtin.sigma" 60 $ "constructor telescope = " ++ prettyShow tel'+ typeError $ InvalidBuiltin $ "Builtin SIGMA: wrong field types" _ -> typeError $ InvalidBuiltin "Builtin SIGMA must be a record type with two fields" -- | Bind BUILTIN EQUALITY and BUILTIN REFL.@@ -721,7 +734,7 @@ -- The types of the last two arguments must be the third-last argument unless (natSize eqTel >= 3) no let (a, b) = fromMaybe __IMPOSSIBLE__ $ last2 $ telToList eqTel- [a,b] <- reduce $ map (unEl . snd . unDom) [a,b]+ [a,b] <- reduce $ map' (unEl . snd . unDom) [a,b] unless (deBruijnView a == Just 0) no unless (deBruijnView b == Just 1) no @@ -736,7 +749,7 @@ -- Check the arguments cdef <- getConstInfo c TelV conTel conCore <- telView $ defType cdef- ts <- reduce $ map (unEl . snd . unDom) $ drop (conPars $ theDef cdef) $ telToList conTel+ ts <- reduce $ map' (unEl . snd . unDom) $ drop (conPars $ theDef cdef) $ telToList conTel -- After dropping the parameters, there should be maximally one argument. unless (length ts <= 1) wrongRefl unless (all ((Just 0 ==) . deBruijnView) ts) wrongRefl@@ -744,11 +757,11 @@ -- Check the target case unEl conCore of Def _ es -> do- let vs = map unArg $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ let vs = map' unArg $ mustAllApplyElims es (a,b) <- reduce $ fromMaybe __IMPOSSIBLE__ $ last2 vs unless (deBruijnView a == Just 0) wrongRefl unless (deBruijnView b == Just 0) wrongRefl- bindBuiltinName builtinRefl (Con (ConHead c IsData Inductive []) ConOSystem [])+ bindBuiltinName builtinRefl (Con (ConHead c IsData Inductive NotHIT []) ConOSystem []) _ -> __IMPOSSIBLE__ _ -> typeError $ InvalidBuiltin "Builtin EQUALITY must be a data type with a single constructor" where@@ -906,12 +919,12 @@ isUntypedBuiltin :: BuiltinId -> Bool isUntypedBuiltin = hasElem [ builtinFromNat, builtinFromNeg, builtinFromString ] -bindUntypedBuiltin :: BuiltinId -> ResolvedName -> TCM ()-bindUntypedBuiltin b = \case+bindUntypedBuiltin :: BuiltinId -> C.QName -> ResolvedName -> TCM ()+bindUntypedBuiltin b qx = \case DefinedName _ x NoSuffix -> bind x DefinedName _ x Suffix{} -> wrong FieldName (x :| []) -> bind x- FieldName (x :| _) -> amb x+ FieldName xs -> err xs VarName _x _bnd -> wrong UnknownName -> wrong ConstructorName _ xs -> err xs@@ -919,10 +932,9 @@ where bind x = bindBuiltinName b (Def (anameName x) []) wrong = typeError $ BuiltinMustBeDef b- amb x = genericDocError =<< do text "Name " <+> prettyTCM x <+> text " is ambiguous"- err (x :| xs1)- | null xs1 = wrong- | otherwise = amb x+ err :: List1 AbstractName -> TCM ()+ err (x :| []) = wrong+ err (x :| y : zs) = typeError $ AmbiguousName qx $ AmbiguousDeclName $ List2 x y zs -- | Bind a builtin thing to a new name. --@@ -932,7 +944,7 @@ bindBuiltinNoDef :: BuiltinId -> A.QName -> TCM () bindBuiltinNoDef b q = inTopContext $ do when (b `elem` sizeBuiltins) $- requireOptionSizedTypes $ "to declare size BUILTIN " ++ getBuiltinId b+ requireOptionSizedTypes $ "to declare size BUILTIN " ++! getBuiltinId b case builtinDesc <$> findBuiltinInfo b of Just (BuiltinPostulate rel mt) -> do@@ -951,7 +963,7 @@ def fun | b == builtinSizeUniv = FunctionDefn $ fun { _funClauses = [ (empty :: Clause) { clauseBody = Just $ Sort sSizeUniv } ]- , _funCompiled = Just (CC.Done [] $ Sort sSizeUniv)+ , _funCompiled = Just (CC.Done 0 NotRecursive [] $ Sort sSizeUniv) , _funMutual = Just [] , _funTerminates = Just True }@@ -965,7 +977,7 @@ , primName = name , primClauses = [] , primInv = NotInjective- , primCompiled = Just (CC.Done [] $ Def q [])+ , primCompiled = Just (CC.Done 0 NotRecursive [] $ Def q []) , primOpaque = TransparentDef } lang <- getLanguage@@ -980,13 +992,14 @@ d <- return $! getPrimName $ unEl t erasure <- optErasure <$> pragmaOptions let- ch = ConHead q IsData Inductive []+ ch = ConHead q IsData Inductive NotHIT [] def = Constructor { conPars = 0 -- Andrea TODO: fix zeros , conArity = 0 , conSrcCon = ch , conData = d , conAbstr = ConcreteDef+ , conPathCons = PointCons , conComp = emptyCompKit , conProj = Nothing , conForced = []@@ -1012,7 +1025,8 @@ , dataSort = getSort t , dataAbstr = ConcreteDef , dataMutual = Nothing- , dataPathCons = []+ , dataPositivityCheck = NoPositivityCheck+ , dataHIT = NotHIT , dataTranspIx = Nothing -- Id has custom transp def. , dataTransp = Nothing }@@ -1026,7 +1040,7 @@ def = PrimitiveSort builtinSort s -- Check for the cubical flag if the sort requries it case builtinSort of- SortIntervalUniv -> requireCubical CErased+ SortIntervalUniv -> requireCubical CWithoutGlue _ -> return () addConstant' q defaultArgInfo (sort $ univSort s) def bindBuiltinName b $ Def q []
src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs view
@@ -26,7 +26,6 @@ import Agda.TypeChecking.Rules.Builtin import Agda.TypeChecking.Rules.Term -import Agda.Utils.Lens import Agda.Utils.Null -- | The type of @∞@.@@ -83,11 +82,12 @@ { recPars = 2 , recInduction = Just CoInductive , recClause = Nothing- , recConHead = ConHead sharp (IsRecord CopatternMatching) CoInductive [] -- flat is added later+ , recConHead = ConHead sharp (IsRecord CopatternMatching) CoInductive NotHIT [] -- flat is added later , recNamedCon = True , recFields = [] -- flat is added later , recTel = fieldTel- , recEtaEquality' = Inferred $ NoEta CopatternMatching+ , recPositivityCheck = NoPositivityCheck+ , recEtaEquality' = EtaEquality (NoEta CopatternMatching) EtaFromPragma , recPatternMatching= CopatternMatching , recMutual = Just [] , recTerminates = Just True -- not recursive@@ -99,9 +99,10 @@ sharpDefn { theDef = Constructor { conPars = 2 , conArity = 1- , conSrcCon = ConHead sharp (IsRecord CopatternMatching) CoInductive [] -- flat is added as field later+ , conSrcCon = ConHead sharp (IsRecord CopatternMatching) CoInductive NotHIT [] -- flat is added as field later , conData = defName infDefn , conAbstr = ConcreteDef+ , conPathCons = PointCons , conComp = emptyCompKit , conProj = Nothing , conForced = []@@ -126,7 +127,7 @@ Def sharp _ <- primSharp kit <- requireLevels Def inf _ <- primInf- let sharpCon = ConHead sharp (IsRecord CopatternMatching) CoInductive [defaultArg flat]+ let sharpCon = ConHead sharp (IsRecord CopatternMatching) CoInductive NotHIT [defaultArg flat] level = El (mkType 0) $ Def (typeName kit) [] tel :: Telescope tel = ExtendTel (domH $ level) $ Abs "a" $@@ -145,12 +146,12 @@ , clauseBody = Just $ var 0 , clauseType = Just $ defaultArg $ El (varSort 2) $ var 1 , clauseCatchall = empty- , clauseRecursive = Just False+ , clauseRecursive = NotRecursive , clauseUnreachable = Just False , clauseEllipsis = NoEllipsis , clauseWhereModule = Nothing }- cc = Case (defaultArg 0) $ conCase sharp False $ WithArity 1 $ Done [defaultArg "x"] $ var 0+ cc = Case (defaultArg 0) $ conCase sharp False $ WithArity 1 $ Done 0 NotRecursive [defaultArg "x"] $ var 0 projection = Projection { projProper = Just inf , projOrig = flat@@ -162,7 +163,7 @@ addConstant flat $ flatDefn { defPolarity = [] , defArgOccurrences = [StrictPos] -- changing that to [Mixed] destroys monotonicity of 'Rec' in test/succeed/GuardednessPreservingTypeConstructors- , defCopatternLHS = hasProjectionPatterns cc+ , defCopatternLHS' = hasProjectionPatterns cc , theDef = FunctionDefn fun { _funClauses = [clause] , _funCompiled = Just $ cc
src/full/Agda/TypeChecking/Rules/Data.hs view
@@ -50,12 +50,14 @@ import Agda.Utils.Either import Agda.Utils.Function (applyWhen) import Agda.Utils.Functor-import Agda.Utils.List+import Agda.Utils.List as List+import Agda.Utils.List1 (pattern (:|) ) import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null import qualified Agda.Utils.Set1 as Set1 import Agda.Utils.Size+import qualified Agda.Utils.VarSet as VarSet import Agda.Utils.Impossible @@ -65,8 +67,8 @@ -- | Type check a datatype definition. Assumes that the type has already been -- checked.-checkDataDef :: A.DefInfo -> QName -> UniverseCheck -> A.DataDefParams -> [A.Constructor] -> TCM ()-checkDataDef i name uc (A.DataDefParams gpars ps) cs =+checkDataDef :: A.DefInfo -> QName -> PositivityCheck -> UniverseCheck -> A.DataDefParams -> [A.Constructor] -> TCM ()+checkDataDef i name pc uc (A.DataDefParams gpars ps) cs = traceCall (CheckDataDef (getRange name) name ps cs) $ do -- Add the datatype module@@ -77,8 +79,8 @@ t <- instantiateFull $ defType def let npars = case theDef def of- DataOrRecSig n -> n- _ -> __IMPOSSIBLE__+ DataOrRecSig n IsData -> n+ _ -> __IMPOSSIBLE__ -- If the data type is erased, then hard compile-time mode is -- entered.@@ -150,7 +152,8 @@ , _dataSort = s , _dataAbstr = Info.defAbstract i , _dataMutual = Nothing- , _dataPathCons = [] -- Path constructors are added later+ , _dataPositivityCheck = pc+ , _dataHIT = NotHIT -- Computed later from the constructors , _dataTranspIx = Nothing -- Generated later if nofIxs > 0. , _dataTransp = Nothing -- Added later }@@ -159,11 +162,20 @@ addConstant' name defaultArgInfo t $ DatatypeDefn dataDef -- polarity and argOcc.s determined by the positivity checker - -- Check the types of the constructors- pathCons <- forM cs $ \ c -> do- isPathCons <- checkConstructor name uc tel' nofIxs s c- return $ if isPathCons == PathCons then Just (A.axiomName c) else Nothing+ -- Check the types of the constructors.+ -- The data type is a HIT if at least one of them is a path constructor.+ hit <- or <$> forM cs \ c ->+ (PathCons ==) <$> checkConstructor name uc tel' nofIxs s c + -- The constructor heads are needed before we know whether the+ -- datatype is a HIT. Update them now that all constructors have+ -- been checked.+ let isHIT = fromBool hit+ forM_ cs $ \ c ->+ modifySignature $ updateDefinition (A.axiomName c) $ updateTheDef $ \case+ con@Constructor{ conSrcCon = ch } ->+ con { conSrcCon = ch { conIsHIT = isHIT } }+ def -> def -- cubical: the interval universe does not contain datatypes -- similar: SizeUniv, ...@@ -181,18 +193,19 @@ checkIndexSorts s' ixTel -- Return the data definition- return dataDef{ _dataPathCons = catMaybes pathCons+ return dataDef{ _dataHIT = fromBool hit } - let cons = map A.axiomName cs -- get constructor names+ let cons = map' A.axiomName cs -- get constructor names (mtranspix, transpFun) <- ifM cubicalCompatibleOption- (do mtranspix <- inTopContext $ defineTranspIx name- transpFun <- inTopContext $- defineTranspFun name mtranspix cons- (_dataPathCons dataDef)- return (mtranspix, transpFun))+ (inTopContext $ do+ checkNoLocalRewrites name+ mtranspix <- defineTranspIx name+ transpFun <- defineTranspFun name mtranspix cons $+ _dataHIT dataDef+ return (mtranspix, transpFun)) (return (Nothing, Nothing)) -- Add the datatype to the signature with its constructors.@@ -224,7 +237,7 @@ LevelUniv -> no IntervalUniv -> no -- Blocked sorts.- PiSort _ _ _ -> __IMPOSSIBLE__+ PiSort{} -> __IMPOSSIBLE__ FunSort _ _ -> __IMPOSSIBLE__ UnivSort _ -> __IMPOSSIBLE__ MetaS _ _ -> __IMPOSSIBLE__@@ -254,7 +267,7 @@ -> Sort -- ^ Sort of the data type. -> A.Constructor -- ^ Constructor declaration (type signature). -> TCM IsPathCons-checkConstructor d uc tel nofIxs s (A.ScopedDecl scope [con]) = do+checkConstructor d uc tel nofIxs s (A.ScopedDecl scope (con :| [])) = do setScope scope checkConstructor d uc tel nofIxs s con checkConstructor d uc tel nofIxs s con@(A.Axiom _ i ai Nothing c e) =@@ -299,11 +312,11 @@ (con, comp, projNames) <- do -- Name for projection of ith field of constructor c is just c-i names <- forM [0 .. size fields - 1] $ \ i ->- freshAbstractQName'_ $ P.prettyShow (A.qnameName c) ++ "-" ++ show i+ freshAbstractQName'_ $ P.prettyShow (A.qnameName c) ++! "-" ++! show i -- nofIxs == 0 means the data type can be reconstructed -- by appling the QName d to the parameters.- let dataT = El s $ Def d $ map Apply $ teleArgs params+ let dataT = El s $ Def d $ map' Apply $ teleArgs params reportSDoc "tc.data.con.comp" 5 $ inTopContext $ vcat $ [ "params =" <+> pretty params@@ -312,11 +325,11 @@ , "names =" <+> pretty names ] - let con = ConHead c IsData Inductive $ zipWith (<$) names $ map argFromDom $ telToList fields+ let con = ConHead c IsData Inductive NotHIT $ zipWith' (<$) names $ map' argFromDom $ telToList fields defineProjections d con params names fields dataT -- Andreas, 2024-01-05 issue #7048:- -- Only define hcomp when --cubical-compatible.+ -- Only define hcomp when --cubical=compatible. cubicalCompatible <- cubicalCompatibleOption -- Cannot compose indexed inductive types yet. comp <- if cubicalCompatible && nofIxs == 0 && Info.defAbstract i == ConcreteDef@@ -333,6 +346,7 @@ , conSrcCon = con , conData = d , conAbstr = Info.defAbstract i+ , conPathCons = isPathCons , conComp = comp , conProj = projNames , conForced = forcedArgs@@ -343,13 +357,13 @@ -- Add the constructor to the instance table, if needed case Info.defInstance i of- InstanceDef _r -> setCurrentRange c $ do+ InstanceDef kwr -> setCurrentRange c $ do -- Including the range of the @instance@ keyword, like -- @(getRange (r,c))@, does not produce good results. -- Andreas, 2020-01-28, issue #4360: -- Use addTypedInstance instead of addNamedInstance -- to detect unusable instances.- addTypedInstance c t+ addTypedInstance kwr c t -- addNamedInstance c d NotInstanceDef -> pure () @@ -358,7 +372,7 @@ where -- Issue 3362: we need to do the `constructs` call inside the -- generalization, so unpack the A.Generalize- checkConstructorType (A.ScopedExpr s e) d = withScope_ s $ checkConstructorType e d+ checkConstructorType (A.ScopedExpr s e) d = evalWithScope s $ checkConstructorType e d checkConstructorType e d = do let check k e = do t <- workOnTypes $ isType_ e@@ -418,6 +432,7 @@ , someBuiltin builtinItIsOne ] if not (all isJust required) then return $ emptyCompKit else do+ checkNoLocalRewrites' d params hcomp <- whenDefined (null boundary) [builtinHComp,builtinTrans] (defineKanOperationD DoHComp d con params names fsT t boundary) transp <- whenDefined True [builtinTrans]@@ -429,20 +444,20 @@ where -- Δ^I, i : I |- sub Δ : Δ sub tel = [ var n `apply` [Arg defaultArgInfo $ var 0] | n <- [1..size tel] ] ++# EmptyS __IMPOSSIBLE__- withArgInfo tel = zipWith Arg (map domInfo . telToList $ tel)+ withArgInfo tel = zipWith' Arg (map' domInfo . telToList $ tel) defineKanOperationD cmd d con params names fsT t boundary = do let project = (\ t p -> apply (Def p []) [argN t]) stuff <- defineKanOperationForFields cmd (guard (not $ null boundary) >> Just (Con con ConOSystem $ teleElims fsT boundary))- project d params fsT (map argN names) t+ project d params fsT (map' argN names) t caseMaybe stuff (return Nothing) $ \ ((theName, gamma , ty, _cl_types , bodies), theSub) -> do iz <- primIZero body <- do case cmd of- DoHComp -> return $ Con con ConOSystem (map Apply $ withArgInfo fsT bodies)- DoTransp | null boundary {- && null ixs -} -> return $ Con con ConOSystem (map Apply $ withArgInfo fsT bodies)+ DoHComp -> 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@@ -489,7 +504,7 @@ -- Δ.Φ ⊢ [ (i=0) -> t_i; (i=1) -> u_i ] : R δ bs = fullBoundary fsT boundary- -- ψ = sigma `applySubst` map (\ i → i ∨ ~ i) . map fst $ boundary+ -- ψ = sigma `applySubst` map' (\ i → i ∨ ~ i) . map' fst $ boundary -- Γ ⊢ t : R (δ i1) w1' = Con con ConOSystem $ sigma `applySubst` teleElims fsT boundary -- (δ, φ, u0) : Γ ⊢@@ -540,7 +555,7 @@ ty <- open ty faces <- mapM (\ x -> liftM2 (,) (open . noabsApp __IMPOSSIBLE__ $ fmap fst x) (open $ fmap snd x)) faces let- thePsi = foldl1 imax (map fst faces)+ thePsi = foldl1 imax (map' fst faces) hcomp ty phi sys a0 = pure tHComp <#> (lvlOfType <$> ty) <#> (unEl <$> ty) <#> phi@@ -554,7 +569,7 @@ psi theOr (alpha `absAp` (ineg i)) (recurse xs) where- theOr = foldl1 imax (map fst xs)+ theOr = foldl1 imax (map' fst xs) recurse [] = __IMPOSSIBLE__ sys_alpha = recurse faces pOr ty@@ -573,9 +588,9 @@ -- Δ.Φ ⊢ u = Con con ConOSystem $ teleElims fsT boundary : R δ -- u = Con con ConOSystem $ teleElims fsT boundary- up = ConP con (ConPatternInfo defaultPatternInfo False False Nothing False) $+ up = ConP con (ConPatternInfo defaultPatternInfo False False Nothing False empty) $ telePatterns (d0 `applySubst` fsT) (liftS (size fsT) d0 `applySubst` boundary)--- gamma' = telFromList $ take (size gamma - 1) $ telToList gamma+-- gamma' = telFromList $ take' (size gamma - 1) $ telToList gamma -- (δ , φ , fs : Φ[d0]) ⊢ u[liftS Φ d0] -- (δ , φ, u) : Γ ⊢ body@@ -585,7 +600,7 @@ let pats | null boundary = teleNamedArgs gamma- | otherwise = take (size gamma - size fsT) (teleNamedArgs gamma) ++ [argN $ unnamed $ up]+ | otherwise = take' (size gamma - size fsT) (teleNamedArgs gamma) ++! [argN $ unnamed $ up] clause = Clause { clauseTel = gamma , clauseType = Just . argN $ ty@@ -594,9 +609,9 @@ , clauseLHSRange = noRange , clauseCatchall = empty , clauseBody = Just $ body- , clauseRecursive = Nothing+ , clauseRecursive = MaybeRecursive -- Andreas 2020-02-06 TODO- -- Or: Just False; is it known to be non-recursive?+ -- Or: NotRecursive; is it known to be non-recursive? , clauseUnreachable = Just False , clauseEllipsis = NoEllipsis , clauseWhereModule = Nothing@@ -606,7 +621,7 @@ (mst, _, cc) <- inTopContext (compileClauses Nothing cs) whenJust mst $ setSplitTree theName setCompiledClauses theName cc- setTerminates theName True+ setTerminates theName $ Just True return $ Just theName whenDefined False _ _ = return Nothing@@ -638,15 +653,15 @@ forM_ (zip3 (downFrom (size fieldTypes)) names fieldTypes) $ \ (i,projName,ty) -> do let projType = abstract projTel <$> ty- cpi = ConPatternInfo defaultPatternInfo False False (Just $ argN $ raise (size fsT) t) False+ cpi = ConPatternInfo defaultPatternInfo False False (Just $ argN $ raise (size fsT) t) False empty conp = defaultNamedArg $ ConP con cpi $ teleNamedArgs fsT- sigma = Con con ConOSystem (map Apply $ teleArgs fsT) `consS` raiseS (size fsT)+ sigma = Con con ConOSystem (map' Apply $ teleArgs fsT) `consS` raiseS (size fsT) clause = empty { clauseTel = abstract params fsT , namedClausePats = [ conp ] , clauseBody = Just $ var i , clauseType = Just $ argN $ applySubst sigma $ unDom ty- , clauseRecursive = Just False -- non-recursive+ , clauseRecursive = NotRecursive -- non-recursive , clauseUnreachable = Just False } @@ -669,7 +684,7 @@ , projOrig = projName , projFromType = Arg (getArgInfo ty) dataName , projIndex = np + 1- , projLams = ProjLams $ map (argFromDom . fmap fst) $ telToList projTel+ , projLams = ProjLams $ map' (argFromDom . fmap fst) $ telToList projTel } , _funMutual = Just [] , _funTerminates = Just True@@ -690,7 +705,27 @@ freshAbstractQName'_ :: String -> TCM QName freshAbstractQName'_ = freshAbstractQName noFixity' . C.simpleName +-- | I am not sure what the generated transport functions should look like+-- in the presence of local rewrite rule parameters.+-- The easiest solution is to just refuse to generate the transport function,+-- and throw a type error.+checkNoLocalRewrites :: QName -> TCM ()+checkNoLocalRewrites d = do+ def <- getConstInfo d+ case theDef def of+ Datatype { dataPars = npars+ , dataIxs = nixs+ , dataSort = s}+ -> do+ let t = defType def+ TelV params t' <- telViewUpTo npars t+ checkNoLocalRewrites' d params+ _ -> __IMPOSSIBLE__ +checkNoLocalRewrites' :: QName -> Tele (Dom Type) -> TCM ()+checkNoLocalRewrites' d tel = unless (VarSet.null $ theRewVars tel) $+ typeError $ CannotGenerateTransportLocalRewrite d+ -- | Defines and returns the name of the `transpIx` function. defineTranspIx :: QName -- ^ datatype name -> TCM (Maybe QName)@@ -709,7 +744,7 @@ , "nixs :" <+> pretty nixs ] if nixs == 0 then return Nothing else do- trIx <- freshAbstractQName'_ $ "transpX-" ++ P.prettyShow (A.qnameName d)+ trIx <- freshAbstractQName'_ $ "transpX-" ++! P.prettyShow (A.qnameName d) TelV params t' <- telViewUpTo npars t TelV ixs dT <- telViewUpTo nixs t' -- params ⊢ s@@ -736,9 +771,9 @@ -- reportSDoc "trans.rec" 10 $ text $ show fsT -- let thePrefix = "transp-"- -- theName <- freshAbstractQName'_ $ thePrefix ++ P.prettyShow (A.qnameName name)+ -- theName <- freshAbstractQName'_ $ thePrefix ++! P.prettyShow (A.qnameName name) - -- reportSLn "trans.rec" 5 $ ("Generated name: " ++ show theName ++ " " ++ showQNameId theName)+ -- reportSLn "trans.rec" 5 $ ("Generated name: " ++! show theName ++! " " ++! showQNameId theName) -- record type in 'exponentiated' context -- (params : Γ)(ixs : Δ^I), i : I |- T[params, ixs i]@@ -757,17 +792,17 @@ 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 empty+ (ps, p) = fromMaybe __IMPOSSIBLE__ $ List.initLast' $ telePatterns ctel empty 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]+ , namedClausePats = ps ++! [pat, p] , clauseBody = Just $ var 0 , clauseType = Just $ defaultArg $ raise 1 $ subst 0 io rect'- , clauseRecursive = Just False -- non-recursive+ , clauseRecursive = NotRecursive -- non-recursive , clauseUnreachable = Just False } @@ -803,7 +838,7 @@ -- 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])+ -- r <- reduce $ Def trIx (init es ++! [Apply $ argN io, last es]) -- reportSDoc "tc.data.ixs" 20 $ "reduced1:" <+> prettyTCM r return $ Just trIx _ -> __IMPOSSIBLE__@@ -816,9 +851,9 @@ defineTranspFun :: QName -- ^ datatype -> Maybe QName -- ^ transpX "constructor" -> [QName] -- ^ constructor names- -> [QName] -- ^ path cons+ -> IsHIT -- ^ is this a HIT, i.e., are there path constructors? -> TCM (Maybe QName) -- transp function for the datatype.-defineTranspFun d mtrX cons pathCons = do+defineTranspFun d mtrX cons isHIT = do def <- getConstInfo d case theDef def of Datatype { dataPars = npars@@ -834,7 +869,7 @@ , "npars:" <+> pretty npars , "nixs :" <+> pretty nixs ]- trD <- freshAbstractQName'_ $ "transp" ++ P.prettyShow (A.qnameName d)+ trD <- freshAbstractQName'_ $ "transp" ++! P.prettyShow (A.qnameName d) TelV params t' <- telViewUpTo npars t TelV ixs dT <- telViewUpTo nixs t' @@ -848,7 +883,7 @@ interval <- primIntervalType let telI = expTelescope interval tel sigma = sub tel- dTs = (sigma `applySubst` El s (Def d $ map Apply $ teleArgs tel))+ dTs = (sigma `applySubst` El s (Def d $ map' Apply $ teleArgs tel)) theType <- (abstract telI <$>) $ runNamesT [] $ do dT <- open $ Abs "i" $ dTs@@ -865,7 +900,7 @@ (defaultDefn defaultArgInfo trD theType (Cubical CErased) fun) let ctel = abstract telI $ ExtendTel (defaultDom $ subst 0 iz dTs) (Abs "t" EmptyTel)- ps = telePatterns ctel empty+ (ps, p) = fromMaybe __IMPOSSIBLE__ $ List.initLast' $ telePatterns ctel empty cpi = noConPatternInfo { conPType = Just (defaultArg interval) , conPFallThrough = True }@@ -873,18 +908,18 @@ pat = defaultNamedArg $ ConP io_c cpi [] clause = empty { clauseTel = ctel- , namedClausePats = init ps ++ [pat, last ps]+ , namedClausePats = ps ++! [pat, p] , clauseBody = Just $ var 0 , clauseType = Just $ defaultArg $ raise 1 $ subst 0 io dTs- , clauseRecursive = Just False -- non-recursive+ , clauseRecursive = NotRecursive -- 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+ ecs <- tryTranspError $ (clause:) <$> defineConClause trD (toBool isHIT) mtrX npars nixs ixs telI sigma dTs cons caseEitherM (pure ecs) (\ cl -> debugNoTransp cl >> return Nothing) $ \ cs -> do (mst, _, cc) <- compileClauses Nothing cs fun <- emptyFunctionData <&> \fun -> fun@@ -941,7 +976,7 @@ LEl l ty <- fromMaybe __IMPOSSIBLE__ <$> toLType ty l <- open $ Level l ty <- open $ ty- face <- (foldr max (pure iz) $ map fst $ sys)+ 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@@ -967,11 +1002,11 @@ let trD = bindNArg (teleArgNames parI) $ \ delta -> bindNArg (teleArgNames ixsI) $ \ x -> bindN ["phi","u0"] $ \ [phi,u0] ->- ((Def trD' [] `apply`) <$> sequence (delta ++ x)) <@> 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 dT = pure $ AbsN (teleNames parI ++! teleNames ixsI ++! ["i"]) dT' let hcompComputes = not $ isHIT || nixs > 0 c_HComp <- if hcompComputes then return [] else do@@ -983,32 +1018,32 @@ ixsI <- open $ AbsN (teleNames parI) ixsI parI <- open parI abstract_trD $ \ delta x _ -> do- LEl l ty <- fromMaybe __IMPOSSIBLE__ <.> toLType =<< (dT `applyN` (delta ++ x ++ [pure iz]))+ LEl l ty <- fromMaybe __IMPOSSIBLE__ <.> 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"]+ 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+ 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- LEl l t <- fromMaybe __IMPOSSIBLE__ <.> toLType =<< (dT `applyN` (delta ++ x ++ [pure iz]))- let ds = map (argH . unnamed . dotP) [Level l, t]+ LEl l t <- fromMaybe __IMPOSSIBLE__ <.> toLType =<< (dT `applyN` (delta ++! x ++! [pure iz]))+ let ds = map' (argH . unnamed . dotP) [Level l, t] sequence as0 >>= \case ps0@[_hphi,_u,_u0] ->- pure $ DefP defaultPatternInfo qHComp $ ds ++ ps0+ pure $! DefP defaultPatternInfo qHComp $! ds ++! ps0 _ -> __IMPOSSIBLE__- psHComp = sequence $ delta_ps ++ x_ps ++ phi_ps ++ [argN . unnamed <$> origPHComp]+ psHComp = sequence $ delta_ps ++! x_ps ++! phi_ps ++! [argN . unnamed <$> origPHComp] let- rhsTy = dT `applyN` (delta ++ x ++ [pure io])+ 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+ 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@@ -1029,42 +1064,42 @@ let delta0_refl = for 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])+ 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+ 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]+ 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+ 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+ 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)+ ds <- map' (setHiding Hidden . fmap (unnamed . dotP)) <$> deltaArg (pure iz) ps0 <- sequence as0 unless (length ps0 == 1) __IMPOSSIBLE__- pure $ DefP defaultPatternInfo trX $ ds ++ x'_ps ++ phi'_ps ++ ps0- psTrX = sequence $ delta_ps ++ x_ps ++ phi_ps ++ [argN . unnamed <$> origPTrX]+ 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])+ rhsTy = dT `applyN` (delta ++! x ++! [pure io]) -- trD δ x φ (trX x' φ' t) ↦ rhsTrx let rhsTrX = do- let [t] = map (fmap unArg) as0+ let [t] = map' (fmap unArg) as0 let [phi'] = phi's- let telXdeltai = bind "i" $ \ i -> applyN xTel (map (<@> i) delta)+ let telXdeltai = bind "i" $ \ i -> applyN xTel (map' (<@> i) delta) let reflx1 = for x $ \ q -> lam "i" $ \ _ -> q <@> pure io let symx' = for x' $ \ q' -> lam "i" $ \ i -> q' <@> neg i x_tr <- mapM (open . unArg) =<< transpPathTel' telXdeltai symx' reflx1 phi' x@@ -1076,8 +1111,8 @@ 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+ 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@@ -1088,7 +1123,7 @@ 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+ fmap ((c_HComp ++! c_trX) ++) $ forM cnames $ \ cname -> do def <- getConstInfo cname let Constructor@@ -1113,7 +1148,7 @@ Def _ es <- unEl <$> reduce ty -- Δ.aTel ⊢ con_ixs : X- let con_ixs = fromMaybe __IMPOSSIBLE__ $ allApplyElims $ drop npars es+ let con_ixs = mustAllApplyElims $ drop npars es reportSDoc "tc.data.transp.con" 20 $ addContext prm $ "aTel:" <+> prettyTCM aTel@@ -1127,18 +1162,18 @@ aTel <- open $ AbsN (teleNames prm) aTel parI <- open parI abstract_trD $ \ delta _ _ -> do- let args = aTel `applyN` map (<@> pure iz) delta+ 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) $ tmBoundary boundary- u <- open $ AbsN (teleNames prm ++ aTelNames) $ Con chead ConOSystem (teleElims aTel boundary)+ con_ixs <- open $ AbsN (teleNames prm ++! teleNames aTel) $ map' unArg con_ixs+ bndry <- open $ AbsN (teleNames prm ++! teleNames aTel) $ tmBoundary 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+ p <- bindN (teleNames prm ++! aTelNames) $ \ ts -> do LEl l ty <- fromMaybe __IMPOSSIBLE__ <$> toLType ty l <- open (Level l) ty <- open ty@@ -1150,33 +1185,33 @@ 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+ 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+ 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 <*> (varBoundary <$> applyN bndry (map (<@> pure iz) delta ++ map (fmap unArg) as0)))+ ps0 <- (open =<<) $ (telePatterns <$> aTel0 <*> (varBoundary <$> 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+ pure $ map' (fmap (`apply` [argN i])) xs let origP = ConP chead noConPatternInfo <$> ps0- ps = sequence $ delta_ps ++ x_ps ++ phi_ps ++ [argN . unnamed <$> origP]+ ps = sequence $ delta_ps ++! x_ps ++! phi_ps ++! [argN . unnamed <$> origP] let orig = patternToTerm <$> origP- rhsTy = dT `applyN` (delta ++ x ++ [pure io])+ rhsTy = dT `applyN` (delta ++! x ++! [pure io]) (,,) <$> ps <*> rhsTy <*> do -- Declared Constructors.- let aTelI = bind "i" $ \ i -> aTel `applyN` map (<@> i) delta+ let aTelI = bind "i" $ \ i -> aTel `applyN` map' (<@> i) delta eas1 <- (=<<) (lift . runExceptT) $ transpTel <$> aTelI <*> phi <*> sequence as0 @@ -1192,20 +1227,20 @@ let argLam :: Monad 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 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 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)+ 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)+ 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+ 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@@ -1216,21 +1251,21 @@ -- We have to correct the boundary for path constructors. -- bline : Abs I ([phi] → ty)- let blineFace = applyN bsysFace $ map (<@> pure io) delta ++ as1+ 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 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)+ 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+ 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+ applyN bsys $ map' (<@> i) delta ++! as01 let squeezedv0 = ilam "o" $ \ o -> do let delta_f :: [NamesT TCM Term]@@ -1241,7 +1276,7 @@ caseMaybe mtrX squeezedv0 $ \ trX -> ilam "o" $ \ o -> do q2 <- transpPathPTel' theTel x theRight phi theLeft- let args = liftM2 (++) (map (setHiding Hidden) <$> deltaArg (pure io))+ 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))@@ -1268,7 +1303,7 @@ , clauseLHSRange = noRange , clauseCatchall = empty , clauseBody = Just $ rhs- , clauseRecursive = Nothing+ , clauseRecursive = MaybeRecursive -- it is indirectly recursive through transp, does it count? , clauseUnreachable = Just False , clauseEllipsis = NoEllipsis@@ -1343,9 +1378,9 @@ reportSDoc "trans.rec" 10 $ pretty fsT let thePrefix = "transp-"- theName <- freshAbstractQName'_ $ thePrefix ++ P.prettyShow (A.qnameName name)+ theName <- freshAbstractQName'_ $ thePrefix ++! P.prettyShow (A.qnameName name) - reportSLn "trans.rec" 5 $ ("Generated name: " ++ show theName ++ " " ++ showQNameId theName)+ reportSLn "trans.rec" 5 $ ("Generated name: " ++! show theName ++! " " ++! showQNameId theName) theType <- (abstract deltaI <$>) $ runNamesT [] $ do rect' <- open (runNames [] $ bind "i" $ \ x -> let _ = x `asTypeOf` pure (undefined :: Term) in@@ -1354,7 +1389,7 @@ (absApp <$> rect' <*> pure iz) --> (absApp <$> rect' <*> pure io) reportSDoc "trans.rec" 20 $ prettyTCM theType- reportSDoc "trans.rec" 60 $ text $ "sort = " ++ show (getSort rect')+ reportSDoc "trans.rec" 60 $ text $ "sort = " ++! show (getSort rect') lang <- getLanguage fun <- emptyFunctionData@@ -1394,7 +1429,7 @@ -- the_u0 = var 0 -- Γ' = (δ : Δ^I, φ : I)- gamma' = telFromList $ take (size gamma - 1) $ telToList gamma+ gamma' = telFromList $ take' (size gamma - 1) $ telToList gamma -- δ : Δ^I, φ : F ⊢ [δ 0] : Δ d0 :: Substitution@@ -1410,8 +1445,8 @@ , (liftS (size fsT) d0 `applySubst` u) `consS` raiseS (size fsT) , raise (size fsT) (var 0) , (liftS (size fsT) d0 `applySubst` u)- , drop (size gamma') $ map unArg $ teleArgs tel)- Nothing -> (gamma, IdS, var 1, var 0, map (\ fname -> var 0 `applyProj` unArg fname) fns )+ , drop (size gamma') $ map' unArg $ teleArgs tel)+ Nothing -> (gamma, IdS, var 1, var 0, map' (\ fname -> var 0 `applyProj` unArg fname) fns ) fsT_tel = (liftS 1 (raiseS (size tel - size deltaI)) `composeS` sub params) `applySubst` fsT @@ -1442,11 +1477,11 @@ field let -- ' Ξ , i : I ⊢ τ = [(\ j → δ (i ∧ j)), φ ∨ ~ i, u] : Ξ- tau = parallelS $ us ++ (phi `iMax` iNeg (var 0))- : map (\ d -> Lam defaultArgInfo $ Abs "i" $ raise 1 d `apply` [argN $ (iMin (var 0) (var 1))]) ds+ tau = parallelS $ us ++! (phi `iMax` iNeg (var 0))+ : map' (\ d -> Lam defaultArgInfo $ Abs "i" $ raise 1 d `apply` [argN $ (iMin (var 0) (var 1))]) ds where -- Ξ, i : I- (us, phi:ds) = splitAt (size tel - size gamma') $ reverse (raise 1 (map unArg (teleArgs tel)))+ (us, phi:ds) = splitAt' (size tel - size gamma') $ reverse (raise 1 (map' unArg (teleArgs tel))) let go acc [] = return []@@ -1463,11 +1498,11 @@ bs <- go (b : acc) ps return $ b : bs - bodys <- go [] (zip the_fields (map (fmap snd) $ telToList fsT_tel)) -- ∀ f. Ξ, i : I, Φ[δ i]|_f ⊢ Φ[δ i]_f+ bodys <- go [] (zip' the_fields (map' (fmap snd) $ telToList fsT_tel)) -- ∀ f. Ξ, i : I, Φ[δ i]|_f ⊢ Φ[δ i]_f let -- Ξ, i : I ⊢ ... : Δ.Φ theSubst = reverse (tau `applySubst` bodys) ++# (liftS 1 (raiseS (size tel - size deltaI)) `composeS` sub params)- return $ ((theName, tel, theta `applySubst` rtype, map (fmap fromCType) clause_types, bodys), theSubst)+ return $ ((theName, tel, theta `applySubst` rtype, map' (fmap fromCType) clause_types, bodys), theSubst) where -- record type in 'exponentiated' context -- (params : Δ^I), i : I |- T[params i]@@ -1503,9 +1538,9 @@ reportSDoc "comp.rec" 10 $ text $ show fsT let thePrefix = "hcomp-"- theName <- freshAbstractQName'_ $ thePrefix ++ P.prettyShow (A.qnameName name)+ theName <- freshAbstractQName'_ $ thePrefix ++! P.prettyShow (A.qnameName name) - reportSLn "hcomp.rec" 5 $ ("Generated name: " ++ show theName ++ " " ++ showQNameId theName)+ reportSLn "hcomp.rec" 5 $ ("Generated name: " ++! show theName ++! " " ++! showQNameId theName) theType <- (abstract delta <$>) $ runNamesT [] $ do rect <- open $ fromLType rect@@ -1515,7 +1550,7 @@ rect --> rect reportSDoc "hcomp.rec" 20 $ prettyTCM theType- reportSDoc "hcomp.rec" 60 $ text $ "sort = " ++ show (lTypeLevel rect)+ reportSDoc "hcomp.rec" 60 $ text $ "sort = " ++! show (lTypeLevel rect) lang <- getLanguage fun <- emptyFunctionData@@ -1532,7 +1567,7 @@ let -- Γ ⊢ R δ drect_gamma = raiseS (size gamma - size delta) `applySubst` rect - reportSDoc "hcomp.rec" 60 $ text $ "sort = " ++ show (lTypeLevel drect_gamma)+ reportSDoc "hcomp.rec" 60 $ text $ "sort = " ++! show (lTypeLevel drect_gamma) let @@ -1550,7 +1585,7 @@ fillTerm = runNames [] $ do rect <- open . unEl . fromLType $ drect_gamma lvl <- open . Level . lTypeLevel $ drect_gamma- params <- mapM open $ take (size delta) $ teleArgs gamma+ params <- mapM open $ take' (size delta) $ teleArgs gamma phi <- open the_phi w <- open the_u w0 <- open the_u0@@ -1568,7 +1603,7 @@ <@> lam "_" (\ o -> w0) -- TODO wait for i = 0 ) u0 <- w0- pure $ Def theName [] `apply` (args ++ [argN psi, argN u, argN u0])+ pure $ Def theName [] `apply` (args ++! [argN psi, argN u, argN u0]) -- (γ : Γ) ⊢ (flatten Φ)[n ↦ f_n (compR γ)] clause_types = parallelS [compTerm `applyProj` (unArg fn)@@ -1617,10 +1652,10 @@ (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)+ reportSDoc "hcomp.rec" 60 $ text $ "filled_types sorts:" ++! show (map' (getSort . fromLType . unDom) filled_types) - bodys <- mapM mkBody (zip fns filled_types)- return $ ((theName, gamma, rtype, map (fmap fromLType) clause_types, bodys),IdS)+ bodys <- mapM mkBody (zip' fns filled_types)+ return $ ((theName, gamma, rtype, map' (fmap fromLType) clause_types, bodys),IdS) getGeneralizedParameters :: Set Name -> QName -> TCM [Maybe Name]@@ -1629,7 +1664,7 @@ -- Drop the named parameters that shouldn't be in scope (if the user -- wrote a split data type) let inscope x = x <$ guard (Set.member x gpars)- map (>>= inscope) . defGeneralizedParams <$> (instantiateDef =<< getConstInfo name)+ map' (>>= inscope) . defGeneralizedParams <$> (instantiateDef =<< getConstInfo name) -- | Bind the named generalized parameters. bindGeneralizedParameters :: [Maybe Name] -> Type -> (Telescope -> Type -> TCM a) -> TCM a@@ -1689,14 +1724,15 @@ let x = namedArg arg TelV tel _ = telView' t case insertImplicit arg $ telToList tel of- NoInsertNeeded -> continue ps $ A.unBind $ A.binderName x- ImpInsert _ -> continue ps0 =<< freshName_ (absName b)- BadImplicits -> setCurrentRange par $+ NoInsertNeeded -> continue ps $ A.unBind $ A.binderName x+ ImpInsert _ -> continue ps0 =<< freshName_ (absName b)+ BadImplicits -> setCurrentRange par $ typeError $ UnexpectedParameter par- NoSuchName x -> setCurrentRange par $- typeError $ NoParameterOfName x+ NoSuchName x xs -> setCurrentRange par $+ typeError $ NoParameterOfName x xs where- Pi dom@(Dom{domInfo = info', unDom = a}) b = unEl t -- TODO:: Defined but not used: info', a+ Pi dom@(unDom -> a) b = unEl t -- TODO:: Defined but not used: info', a+ info = dom ^. dInfo continue ps x = bindParameter npars ps x dom b ret bindParameter :: Int -> [A.LamBinding] -> Name -> Dom Type -> Abs Type -> (Telescope -> Type -> TCM a) -> TCM a@@ -1727,7 +1763,7 @@ -- noConstraints $ s' `leqSort` s whenM withoutKOption $ do- q <- viewTC eQuantity+ q <- viewTC eQuantityZeroHardCompile -- Don't want to check polarities for the constructor's type, -- only for its argument telescope! applyPolarityToContext (withStandardLock UnusedPolarity) $@@ -1773,13 +1809,11 @@ reportSDoc "tc.polarity" 40 $ sep [ "checking constructor domain" , prettyTCM (unEl $ unDom dom)- , "("- , prettyTCM (show arg)- , ")" , "against sort" , prettyTCM (getSort dom) ]- checkInternal arg CmpLeq (sort (getSort dom))+ applyCohesionToContext dom $+ checkInternal arg CmpLeq (sort (getSort dom)) let (forced, forceds') = nextIsForced forceds isf = isForced forced@@ -1814,9 +1848,6 @@ -- nonLinearParameters :: Int -> Type -> TCM [Int] -- nonLinearParameters nPars t = -data IsPathCons = PathCons | PointCons- deriving (Eq,Show)- -- | Check that a type constructs something of the given datatype. The first -- argument is the number of parameters to the datatype and the second the -- number of additional non-parameters in the context (1 when generalizing, 0@@ -1840,8 +1871,8 @@ b -> underAbstraction a b $ constrT (n + 1) return PathCons Def d es | d == q -> do- let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es- let (pars, ixs) = splitAt nofPars vs+ let vs = mustAllApplyElims es+ let (pars, ixs) = splitAt' nofPars vs -- check that the constructor parameters are the data parameters checkParams n pars return PointCons@@ -1852,11 +1883,11 @@ TelV tel core <- telView td -- Construct the parameter arguments -- The parameters are @n + nofPars - 1 .. n@- let us = zipWith (\ arg x -> var x <$ arg ) (telToArgs tel) $- take nofPars $ downFrom (nofPars + n)+ let us = zipWith' (\ arg x -> var x <$ arg ) (telToArgs tel) $+ take' nofPars $ downFrom (nofPars + n) -- The indices are fresh metas xs <- newArgsMeta =<< piApplyM td us- let t' = El (raise n $ dataSort $ theDef def) $ Def q $ map Apply $ us ++ xs+ let t' = El (raise n $ dataSort $ theDef def) $ Def q $ map' Apply $ us ++! xs -- Andreas, 2017-11-07, issue #2840 -- We should not postpone here, otherwise we might upset the positivity checker. ifM (tryConversion $ equalType t t')@@ -1867,7 +1898,7 @@ checkParams n vs = zipWithM_ sameVar vs ps where nvs = length vs- ps = reverse $ take nvs [n..]+ ps = reverse $ take' nvs [n..] sameVar arg i -- skip irrelevant parameters@@ -1907,4 +1938,4 @@ Sort {} -> return (Just False) MetaV {} -> return Nothing DontCare{} -> __IMPOSSIBLE__- Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s+ Dummy s _ -> __IMPOSSIBLE_VERBOSE__ (show s)
src/full/Agda/TypeChecking/Rules/Decl.hs view
@@ -1,13 +1,12 @@ {-# OPTIONS_GHC -Wunused-imports #-} {-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE RecordWildCards #-} module Agda.TypeChecking.Rules.Decl where import Prelude hiding ( null ) -import Control.Monad.Writer (tell)- import Data.Either (partitionEithers) import qualified Data.Foldable as Fold import qualified Data.Map.Strict as MapS@@ -27,7 +26,6 @@ import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Syntax.Concrete (pattern NoWhere_) import Agda.Syntax.Literal-import Agda.Syntax.Scope.Base ( KindOfName(..) ) import Agda.TypeChecking.Monad import Agda.TypeChecking.Monad.Benchmark (MonadBench, Phase)@@ -39,6 +37,7 @@ import Agda.TypeChecking.Generalize import Agda.TypeChecking.Injectivity import Agda.TypeChecking.InstanceArguments+import Agda.TypeChecking.Irrelevance import Agda.TypeChecking.Level.Solve import Agda.TypeChecking.Positivity import Agda.TypeChecking.Positivity.Occurrence@@ -47,7 +46,6 @@ import Agda.TypeChecking.Primitive import Agda.TypeChecking.ProjectionLike import Agda.TypeChecking.Unquote-import Agda.TypeChecking.Records import Agda.TypeChecking.RecordPatterns import Agda.TypeChecking.Reduce import Agda.TypeChecking.Rewriting@@ -68,8 +66,8 @@ import Agda.Utils.Function ( applyUnless, applyWhen ) import Agda.Utils.Functor-import Agda.Utils.Lens-import Agda.Utils.List1 ( pattern (:|) )+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@@ -87,7 +85,7 @@ checkDeclCached d@(A.Section _ erased mname (A.GeneralizeTel _ tbinds) _) = do e <- readFromCachedLog -- Can ignore the set of generalizable vars (they occur in the telescope)- reportSLn "cache.decl" 10 $ "checkDeclCached: " ++ show (isJust e)+ reportSLn "cache.decl" 10 $ "checkDeclCached: " ++! show (isJust e) case e of Just (EnterSection erased' mname' tbinds', _) | erased == erased' && mname == mname' && tbinds == tbinds' ->@@ -101,22 +99,32 @@ writeToCurrentLog $ LeaveSection mname checkDeclCached d = do- e <- readFromCachedLog+ e <- readFromCachedLog - reportSLn "cache.decl" 10 $ "checkDeclCached: " ++ show (isJust e)+ case e of+ Just (Decl d', s) | compareDecl d d' -> do+ restorePostScopeState s+ reportSLn "cache.decl" 50 $ "range: " ++! prettyShow (getRange d)+ printSyntaxInfo (getRange d)+ _ -> do+ cleanCachedLog+ checkDeclWrap d - case e of- (Just (Decl d',s)) | compareDecl d d' -> do- restorePostScopeState s- reportSLn "cache.decl" 50 $ "range: " ++ prettyShow (getRange d)- printSyntaxInfo (getRange d)- _ -> do- cleanCachedLog- checkDeclWrap d- writeToCurrentLog $ Decl d+ writeToCurrentLog $ Decl d where compareDecl A.Section{} A.Section{} = __IMPOSSIBLE__ compareDecl A.ScopedDecl{} A.ScopedDecl{} = __IMPOSSIBLE__+ -- Andreas, 2025-12-12:+ -- We could consider all A.UnfoldingDecl as equal for the sake of caching+ -- because it is supposed to be there only for highlighting purposes.+ -- However, I fixed the caching problem for opaque blocks+ -- by emitting A.UnfoldingDecl after the declaration in the opaque block,+ -- so changes in an opaque block do not invalidate the whole block.+ -- (See ConcreteToAbstract, case NiceOpaque.)+ -- Thus, the following line should not offer an improvement:+ -- compareDecl A.UnfoldingDecl{} A.UnfoldingDecl{} = True+ -- A.UnfoldingDecl exists only for highlighting purposes,+ -- so it should not affect the caching compareDecl x y = x == y -- changes to CS inside a RecDef or Mutual ought not happen, -- but they do happen, so we discard them.@@ -130,7 +138,7 @@ -- | Type check a sequence of declarations. checkDecls :: [A.Declaration] -> TCM () checkDecls ds = do- reportSLn "tc.decl" 45 $ "Checking " ++ show (length ds) ++ " declarations..."+ reportSLn "tc.decl" 45 $ "Checking " ++! show (length ds) ++! " declarations..." mapM_ checkDecl ds -- | Type check a single declaration.@@ -146,7 +154,7 @@ -- if we're not inside a mutual block? none m = m $> Nothing -- skip all checks meta m = m $> Just (return ()) -- do the usual checks- mutual i ds m = m <&> Just . uncurry (mutualChecks i d ds)+ mutual i m = m <&> Just . uncurry (mutualChecks i d) impossible m = m $> __IMPOSSIBLE__ -- We're definitely inside a mutual block. @@ -155,28 +163,28 @@ A.Generalize s i info x e -> meta $ inConcreteMode $ checkGeneralize s i info x e A.Field{} -> typeError FieldOutsideRecord A.Primitive i x e -> meta $ checkPrimitive i x e- A.Mutual i ds -> mutual i ds $ checkMutual i ds+ A.Mutual i ds -> mutual i $ checkMutual i ds A.Section _r er x tel ds -> meta $ checkSection er x tel ds A.Apply i er x mapp ci d -> meta $ checkSectionApplication i er x mapp ci d A.Import _ _ dir -> none $ checkImportDirective dir A.Pragma i p -> none $ checkPragma i p A.ScopedDecl scope ds -> none $ setScope scope >> mapM_ checkDeclCached ds- A.FunDef i x cs -> impossible $ check x i $ checkFunDef i x cs- A.DataDef i x uc ps cs -> impossible $ check x i $ checkDataDef i x uc ps cs- A.RecDef i x uc dir ps tel cs -> impossible $ check x i $ do- checkRecDef i x uc dir ps tel cs+ A.FunDef i x cs -> impossible $ check x i $ checkFunDef i x $ List1.toList cs+ A.DataDef i x pc uc ps cs -> impossible $ check x i $ checkDataDef i x pc uc ps cs+ A.RecDef i x pc uc eta dir ps tel cs -> impossible $ check x i $ do+ checkRecDef i x pc uc eta dir ps tel cs blockId <- defMutual <$> getConstInfo x -- Andreas, 2016-10-01 testing whether -- envMutualBlock is set correctly. -- Apparently not. verboseS "tc.decl.mutual" 70 $ do- current <- asksTC envMutualBlock+ current <- viewTC eMutualBlock unless (Just blockId == current) $ do reportS "" 0- [ "mutual block id discrepancy for " ++ prettyShow x- , " current mut. bl. = " ++ show current- , " calculated mut. bl. = " ++ show blockId+ [ "mutual block id discrepancy for " ++! prettyShow x+ , " current mut. bl. = " ++! show current+ , " calculated mut. bl. = " ++! show blockId ] return (blockId, Set.singleton x)@@ -202,11 +210,11 @@ -- 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+ 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+ whenNothingM (viewTC eMutualBlock) $ do -- Syntax highlighting. highlight_ DontHightlightModuleContents d@@ -221,7 +229,7 @@ locallyTCState stInstanceHack (const True) $ wakeupConstraints_ -- solve emptiness and instance constraints - checkingWhere <- asksTC envCheckingWhere+ checkingWhere <- viewTC eCheckingWhere solveSizeConstraints $ if checkingWhere /= NoWhere_ then DontDefaultToInfty else DefaultToInfty wakeupConstraints_ -- Size solver might have unblocked some constraints @@ -229,7 +237,7 @@ A.Generalize{} -> pure () _ -> do reportSLn "tc.decl" 20 $ "Freezing all open metas."- void $ freezeMetas (openMetas metas)+ void $ freezeMetas $ MapS.keys $ openMetas metas theMutualChecks @@ -237,7 +245,7 @@ -- Switch maybe to abstract mode, benchmark, and debug print bracket. check :: forall m i a- . ( MonadTCEnv m, MonadPretty m, MonadDebug m+ . ( MonadTCEnv m, MonadDebug m , MonadBench m, Bench.BenchPhase m ~ Phase , AnyIsAbstract i , AllAreOpaque i@@ -257,15 +265,15 @@ let k1 = localTC (set lensIsAbstract (anyIsAbstract abs)) k2 <- case jointOpacity abs of- UniqueOpaque i -> pure $ localTC $ \env -> env { envCurrentOpaqueId = Just i }+ UniqueOpaque i -> pure $ localTC (set eCurrentOpaqueId (Just i)) NoOpaque -> pure id DifferentOpaque hs -> __IMPOSSIBLE__ k1 (k2 cont) -- Some checks that should be run at the end of a mutual block. The -- set names contains the names defined in the mutual block.-mutualChecks :: Info.MutualInfo -> A.Declaration -> [A.Declaration] -> MutualId -> Set QName -> TCM ()-mutualChecks mi d ds mid names = do+mutualChecks :: Info.MutualInfo -> A.Declaration -> MutualId -> Set QName -> TCM ()+mutualChecks mi d mid names = do -- Andreas, 2014-04-11: instantiate metas in definition types let nameList = Set.toList names mapM_ instantiateDefinitionType nameList@@ -276,7 +284,7 @@ checkPositivity_ mi names -- Andreas, 2013-02-27: check termination before injectivity, -- to avoid making the injectivity checker loop.- localTC (\ e -> e { envMutualBlock = Just mid }) $+ localTC (set eMutualBlock (Just mid)) $ checkTermination_ d revisitRecordPatternTranslation nameList -- Andreas, 2016-11-19 issue #2308 @@ -326,7 +334,7 @@ -- and the set of function definitions in the mutual block classify q = inConcreteOrAbstractMode q $ \ def -> do case theDef def of- Record{ recEtaEquality' = Inferred YesEta } -> return $ Just $ Left q+ Record{ recEtaEquality' = EtaEquality YesEta _ } -> return $ Just $ Left q Function { funProjection = Left MaybeProjection -- Andreas, 2017-08-10, issue #2664:@@ -338,18 +346,20 @@ type FinalChecks = Maybe (TCM ()) checkUnquoteDecl :: Info.MutualInfo -> [A.DefInfo] -> [QName] -> A.Expr -> TCM FinalChecks-checkUnquoteDecl mi is xs e = do- reportSDoc "tc.unquote.decl" 20 $ "Checking unquoteDecl" <+> sep (map prettyTCM xs)+checkUnquoteDecl _mi _is xs e = do+ reportSDoc "tc.unquote.decl" 20 $ "Checking unquoteDecl" <+> sep (map' prettyTCM xs) Nothing <$ unquoteTop xs e checkUnquoteDef :: [A.DefInfo] -> [QName] -> A.Expr -> TCM () checkUnquoteDef _ xs e = do- reportSDoc "tc.unquote.decl" 20 $ "Checking unquoteDef" <+> sep (map prettyTCM xs)- () <$ unquoteTop xs e+ reportSDoc "tc.unquote.decl" 20 $ "Checking unquoteDef" <+> sep (map' prettyTCM xs)+ unquoteTop xs e -- | Run a reflected TCM computatation expected to define a given list of -- names.-unquoteTop :: [QName] -> A.Expr -> TCM [QName]+-- Throws an error if any of these names (or any name declared by the computation)+-- has not been defined in the end.+unquoteTop :: [QName] -> A.Expr -> TCM () unquoteTop xs e = do tcm <- primAgdaTCM unit <- primUnit@@ -358,10 +368,10 @@ hArg = setHiding Hidden . vArg m <- applyQuantityToJudgement zeroQuantity $ checkExpr e $ El (mkType 0) $ apply tcm [hArg lzero, vArg unit]- res <- runUnquoteM $ tell xs >> evalTCM m+ res <- runUnquoteM xs $ evalTCM m case res of- Left err -> typeError $ UnquoteFailed err- Right (_, xs) -> return xs+ Left err -> typeError $ UnquoteFailed err+ Right _ -> return () -- | Instantiate all metas in 'Definition' associated to 'QName'. -- Makes sense after freezing metas. Some checks, like free variable@@ -370,7 +380,7 @@ -- Precondition: name has been added to signature already. instantiateDefinitionType :: QName -> TCM () instantiateDefinitionType q = do- reportSLn "tc.decl.inst" 20 $ "instantiating type of " ++ prettyShow q+ reportSLn "tc.decl.inst" 20 $ "instantiating type of " ++! prettyShow q t <- defType . fromMaybe __IMPOSSIBLE__ . lookupDefinition q <$> getSignature t' <- instantiateFull t modifySignature $ updateDefinition q $ updateDefType $ const t'@@ -389,7 +399,7 @@ -- -- Precondition: name has been added to signature already. -- instantiateDefinition :: QName -> TCM () -- instantiateDefinition q = do--- reportSLn "tc.decl.inst" 20 $ "instantiating " ++ prettyShow q+-- reportSLn "tc.decl.inst" 20 $ "instantiating " ++! prettyShow q -- sig <- getSignature -- let def = fromMaybe __IMPOSSIBLE__ $ lookupDefinition q sig -- def <- instantiateFull def@@ -432,8 +442,8 @@ highlight (A.Section i er 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 ps dummy cs)+ A.RecDef i x pc uc eta dir ps tel cs ->+ highlight (A.RecDef i x pc uc eta dir ps dummy cs) -- The telescope has already been highlighted. where -- Andreas, 2016-01-22, issue 1790@@ -459,7 +469,7 @@ -- | Check a set of mutual names for positivity. checkPositivity_ :: Info.MutualInfo -> Set QName -> TCM ()-checkPositivity_ mi names = Bench.billTo [Bench.Positivity] $ do+checkPositivity_ mi names = do -- Positivity checking. reportSLn "tc.decl" 20 $ "checkDecl: checking positivity..." checkStrictlyPositive mi names@@ -492,10 +502,10 @@ | term /= Just True -> do -- Not terminating, thus, running the injectivity check could get us into a loop. reportSLn "tc.inj.check" 35 $- prettyShow q ++ " is not verified as terminating, thus, not considered for injectivity"+ prettyShow q ++! " is not verified as terminating, thus, not considered for injectivity" | isProperProjection d -> do reportSLn "tc.inj.check" 40 $- prettyShow q ++ " is a projection, thus, not considered for injectivity"+ prettyShow q ++! " is a projection, thus, not considered for injectivity" | otherwise -> do inv <- checkInjectivity q cs@@ -503,10 +513,10 @@ d { funInv = inv } _ -> do- abstr <- asksTC envAbstractMode+ abstr <- viewTC eAbstractMode reportSLn "tc.inj.check" 40 $- "we are in " ++ show abstr ++ " and " ++- prettyShow q ++ " is abstract or not a function, thus, not considered for injectivity"+ "we are in " ++! show abstr ++! " and " +++ prettyShow q ++! " is abstract or not a function, thus, not considered for injectivity" -- | Check a set of mutual names for projection likeness. --@@ -520,7 +530,7 @@ -- Non-mutual definitions can be considered for -- projection likeness let ds = Set.toList names- reportSLn "tc.proj.like" 20 $ "checkDecl: checking projection-likeness of " ++ prettyShow ds+ reportSLn "tc.proj.like" 20 $ "checkDecl: checking projection-likeness of " ++! prettyShow ds case ds of [d] -> do def <- getConstInfo d@@ -529,7 +539,7 @@ case theDef def of Function{} -> makeProjection (defName def) _ -> reportSLn "tc.proj.like" 25 $- prettyShow d ++ " is abstract or not a function, thus, not considered for projection-likeness"+ prettyShow d ++! " is abstract or not a function, thus, not considered for projection-likeness" _ -> reportSLn "tc.proj.like" 25 $ "mutual definitions are not considered for projection-likeness" @@ -542,13 +552,14 @@ reportSLn "tc.decl" 20 $ "Attempting to solve constraints before freezing." locallyTCState stInstanceHack (const True) $ wakeupConstraints_ -- solve emptiness and instance constraints- xs <- freezeMetas (openMetas ms)+ let oms = MapS.keys $ openMetas ms+ xs <- freezeMetas oms reportSDoc "tc.decl.ax" 20 $ vcat [ "Abstract type signature produced new open metas: " <+>- sep (map prettyTCM $ MapS.keys (openMetas ms))+ sep (map' prettyTCM oms) , "We froze the following ones of these: " <+>- sep (map prettyTCM $ Set.toList xs)+ sep (map' prettyTCM $ Set.toList xs) ] return a @@ -576,16 +587,13 @@ GeneralizableVar $ SomeGeneralizableArgs n -- | Type check an axiom.-checkAxiom :: KindOfName -> A.DefInfo -> ArgInfo ->- Maybe PragmaPolarities -> QName -> A.Expr -> TCM ()-checkAxiom = checkAxiom' Nothing---- | Data and record type signatures need to remember the generalized+--+-- Data and record type signatures need to remember the generalized -- parameters for when checking the corresponding definition, so for these we -- pass in the parameter telescope separately.-checkAxiom' :: Maybe A.GeneralizeTelescope -> KindOfName -> A.DefInfo -> ArgInfo ->- Maybe PragmaPolarities -> QName -> A.Expr -> TCM ()-checkAxiom' gentel kind i info0 mp x e = whenAbstractFreezeMetasAfter i $ defaultOpenLevelsToZero $ do+checkAxiom :: Maybe A.GeneralizeTelescope -> KindOfName -> A.DefInfo -> ArgInfo ->+ Maybe PragmaPolarities -> QName -> A.Expr -> TCM ()+checkAxiom gentel kind i info0 mp x e = whenAbstractFreezeMetasAfter i $ defaultOpenLevelsToZero $ do -- Andreas, 2016-07-19 issues #418 #2102: -- We freeze metas in type signatures of abstract definitions, to prevent -- leakage of implementation details.@@ -597,6 +605,8 @@ -- even if not declared as such (Issue 610). rel <- max (getRelevance info0) <$> viewTC eRelevance + checkIrrelevanceAllowed rel+ -- Andrea, 2019-07-16 Cohesion is purely based on left-division, it -- does not take envModality into account. let c = getCohesion info0@@ -617,12 +627,17 @@ , nest 2 $ caseMaybe gentel "(no gentel)" $ \ _ -> "(has gentel)" ] + let fromData = case kind of+ DataName -> ModTelData+ _ -> ModTelNotData+ (genParams, npars, t) <- workOnTypes $ case gentel of Nothing -> ([], 0,) <$> isType_ e Just gentel ->- checkGeneralizeTelescope Nothing gentel $ \ genParams ptel -> do- t <- workOnTypes $ isType_ e- return (genParams, size ptel, abstract ptel t)+ checkGeneralizeTelescope fromData Nothing gentel $+ \genParams ptel -> do+ t <- workOnTypes $ isType_ e+ return (genParams, size ptel, abstract ptel t) reportSDoc "tc.decl.ax" 10 $ sep [ text $ "checked type signature"@@ -631,7 +646,7 @@ ] unless (null genParams) $- reportSLn "tc.decl.ax" 40 $ " generalized params: " ++ show genParams+ reportSLn "tc.decl.ax" 40 $ " generalized params: " ++! show genParams -- Jesper, 2018-06-05: should be done AFTER generalizing --whenM (optDoubleCheck <$> pragmaOptions) $ workOnTypes $ do@@ -674,7 +689,7 @@ warning $ TooManyPolarities x $ List1.fromListSafe __IMPOSSIBLE__ $ drop n occs - return $ map rangedThing occs+ return $ map' rangedThing occs -- Set blocking tag to MissingClauses if we still expect clauses let blk = case kind of@@ -692,14 +707,14 @@ case kind of -- #4833: set abstract already here so it can be inherited by with functions FunName -> fun MacroName -> set funMacro True fun- DataName -> DataOrRecSig npars- RecName -> DataOrRecSig npars+ DataName -> DataOrRecSig npars IsData+ RecName -> DataOrRecSig npars (IsRecord empty) AxiomName -> defaultAxiom -- Old comment: NB: used also for data and record type sigs _ -> __IMPOSSIBLE__ where fun = FunctionDefn $ set funAbstr_ (Info.defAbstract i) funD{ _funOpaque = Info.defOpaque i } - let pols = map polFromOcc occs+ let pols = map' polFromOcc occs addConstant x =<< do useTerPragma $ defn@@ -710,12 +725,12 @@ } reportSLn "tc.polarity" 10 $- "Setting occurrences and polarity for " ++ prettyShow x ++ ":\n " ++- prettyShow occs ++ "\n " ++ prettyShow pols+ "Setting occurrences and polarity for " ++! prettyShow x ++! ":\n " +++ prettyShow occs ++! "\n " ++! prettyShow pols -- Add the definition to the instance table, if needed case Info.defInstance i of- InstanceDef _r -> setCurrentRange x $ addTypedInstance x t+ InstanceDef kwr -> setCurrentRange x $ addTypedInstance kwr x t -- Put highlighting on name only; including the instance keyword, -- like @(getRange (r,x))@, does not produce good results. NotInstanceDef -> pure ()@@ -723,14 +738,14 @@ traceCall (IsType_ e) $ do -- need Range for error message -- Andreas, 2016-06-21, issue #2054 -- Do not default size metas to ∞ in local type signatures- checkingWhere <- asksTC envCheckingWhere+ checkingWhere <- viewTC eCheckingWhere solveSizeConstraints $ if checkingWhere /= NoWhere_ then DontDefaultToInfty else DefaultToInfty -- | Type check a primitive function declaration. checkPrimitive :: A.DefInfo -> QName -> Arg A.Expr -> TCM () checkPrimitive i x (Arg info e) = traceCall (CheckPrimitive (getRange i) x e) $ do- (name, PrimImpl t' pf) <- lookupPrimitiveFunctionQ x+ (name, t', pf) <- lookupPrimitiveFunctionQ x -- Certain "primitive" functions are BUILTIN rather than -- primitive. let builtinPrimitives =@@ -748,8 +763,17 @@ when (name `elem` builtinPrimitives) $ do reportSDoc "tc.prim" 20 $ pretty name <+> "is a BUILTIN, not a primitive!" typeError $ NoSuchPrimitiveFunction (getBuiltinId name)- t <- isType_ e- noConstraints $ equalType t t'+ t <- case t' of+ Nothing -> do+ -- The primitive's type is "trusted", i.e. taken from the+ -- primitive declaration in the Agda file.+ unlessM currentModuleIsBuiltinModuleWithSafePostulates $+ typeError $ TrustedPrimitive x+ noConstraints $ isType_ e+ Just t' -> do+ t <- isType_ e+ noConstraints $ equalType t t'+ return t let s = prettyShow $ qnameName x -- Checking the ArgInfo. Currently all primitive definitions require default -- ArgInfos, and likely very few will have different ArgInfos in the@@ -797,7 +821,7 @@ {- then -} (addPragma (rangedThing b) x s) {- else -} $ uselessPragma "COMPILE pragmas must appear in the same module as their corresponding definitions,"-+ A.ForeignPragma rb s -> addForeignCode (rangedThing rb) s A.StaticPragma x -> do def <- ignoreAbstractMode $ getConstInfo x case theDef def of@@ -828,7 +852,7 @@ A.OverlapPragma q new -> do ifNotM ((q `isInModule`) <$> currentModule) (uselessPragma =<< fsep (- pwords "This" ++ [pretty new] +++ pwords "This" ++! [pretty new] ++ pwords "pragma must appear in the same module as the definition of" ++ [prettyTCM q])) @@ -841,25 +865,16 @@ Just InstanceInfo{ instanceOverlap = old } -> typeError $ DuplicateOverlapPragma q old new Nothing -> uselessPragma =<< pretty new <+> "pragma can only be applied to instances" - A.EtaPragma q -> isRecord q >>= \case- Nothing -> noRecord- Just RecordData{ _recInduction = ind, _recEtaEquality' = eta }- | ind /= Just CoInductive -> noRecord- | Specified NoEta{} <- eta -> uselessPragma "ETA pragma conflicts with no-eta-equality declaration"- | otherwise -> modifyRecEta q $ const $ Specified YesEta- where- noRecord = uselessPragma "ETA pragma is only applicable to coinductive records"- -- | Type check a bunch of mutual inductive recursive definitions. -- -- All definitions which have so far been assigned to the given mutual -- block are returned.-checkMutual :: Info.MutualInfo -> [A.Declaration] -> TCM (MutualId, Set QName)+checkMutual :: Info.MutualInfo -> List1 A.Declaration -> TCM (MutualId, Set QName) checkMutual i ds = inMutualBlock $ \ blockId -> defaultOpenLevelsToZero $ do reportSDoc "tc.decl.mutual" 20 $ vcat $- (("Checking mutual block" <+> text (show blockId)) <> ":") :- map (nest 2 . prettyA) ds+ (("Checking mutual block" <+> text (show blockId)) <> ":") <|+ fmap (nest 2 . prettyA) ds insertMutualBlockInfo blockId i localTC ( set eTerminationCheck (() <$ Info.mutualTerminationCheck i)@@ -895,7 +910,7 @@ -- Issue #418, #3744, in fact don't go to AbstractMode at all | otherwise -> inConcreteMode PublicAccess -> inConcreteMode- in abstr $ checkAxiom' gtel funSig i info mp x e+ in abstr $ checkAxiom gtel funSig i info mp x e checkTypeSignature' _ _ = __IMPOSSIBLE__ -- type signatures are always axioms @@ -934,7 +949,7 @@ check1 :: Telescope -> NamedArg A.Expr -> [NamedArg A.Expr] -> TCM Telescope check1 EmptyTel _ _ = bad- check1 (ExtendTel dom@Dom{domInfo = info} btel) arg0@(Arg info' arg) args = do+ check1 (ExtendTel dom@(view dInfo -> info) btel) arg0@(Arg info' arg) args = do let name = bareNameOf arg my = bareNameOf dom tel = absBody btel@@ -955,6 +970,17 @@ (NotHidden, Hidden, _) -> bad (NotHidden, Instance{}, _) -> bad +-- | Checks local rewrite rule constraints are satisfied definitionally+-- and returns the telescope with all local rewrite rules removed+addRewConstraints :: Telescope -> TCM Telescope+addRewConstraints EmptyTel = pure EmptyTel+addRewConstraints (ExtendTel a b) = do+ whenJust (rewDom a) $ \r -> do+ addRewConstraint $ rewDomEq r+ let a' = a & dRew .~ Nothing+ b' <- underAbstraction a' b addRewConstraints+ pure $ ExtendTel a' b { unAbs = b' }+ -- | Check an application of a section. checkSectionApplication :: Info.ModuleInfo@@ -984,7 +1010,9 @@ -> A.ScopeCopyInfo -- ^ Imported names and modules -> TCM () checkSectionApplication'- i er m1 (A.SectionApp ptel m2 args) copyInfo = do+ i er m1 (A.SectionApp ptel m2 args) copyInfo =+ Bench.billTo [Bench.Typing, Bench.ApplySection]+ do -- If the section application is erased, then hard compile-time mode -- is entered. warnForPlentyInHardCompileTimeMode er@@ -995,9 +1023,9 @@ mfv <- getCurrentModuleFreeVars fv <- getContextSize return (fv - mfv)- when (extraParams > 0) $ reportSLn "tc.mod.apply" 30 $ "Extra parameters to " ++ prettyShow m1 ++ ": " ++ show extraParams+ when (extraParams > 0) $ reportSLn "tc.mod.apply" 30 $ "Extra parameters to " ++! prettyShow m1 ++! ": " ++! show extraParams -- Type-check the LHS (ptel) of the module macro.- checkTelescope ptel $ \ ptel -> do+ checkTelescope ModTelNotData ptel $ \ ptel -> do -- We are now in the context @ptel@. -- Get the correct parameter telescope of @m2@. This is the fully lifted -- telescope obtained by `lookupSection` instantiated with the module@@ -1023,7 +1051,7 @@ reportSDoc "tc.mod.apply" 15 $ "applying section" <+> prettyTCM m2 reportSDoc "tc.mod.apply" 15 $- nest 2 $ "args =" <+> sep (map prettyA args)+ nest 2 $ "args =" <+> sep (map' prettyA args) reportSDoc "tc.mod.apply" 15 $ nest 2 $ "ptel =" <+> escapeContext impossible (size ptel) (prettyTCM ptel) reportSDoc "tc.mod.apply" 15 $@@ -1055,20 +1083,36 @@ ] -- Andreas, 2014-04-06, Issue 1094: -- Add the section with well-formed telescope.- addContext (KeepNames aTel) $ do- reportSDoc "tc.mod.apply" 80 $- "addSection" <+> prettyTCM m1 <+> (getContextTelescope >>= \ tel -> inTopContext (prettyTCM tel))- addSection m1+ -- Nathaniel, 2026-02-08:+ -- We build the telescope before entering addSection (in the presence of+ -- local rewrite rules, adding aTel to the context is unsafe)+ ctxTel <- getContextTelescope+ reportSDoc "tc.mod.apply" 80 $+ "addSection" <+> prettyTCM m1 <+>+ (inTopContext $ prettyTCM $ ctxTel `abstract` aTel)+ addSection' m1 $ ctxTel `abstract` aTel reportSDoc "tc.mod.apply" 20 $ vcat- [ sep [ "applySection", prettyTCM m1, "=", prettyTCM m2, fsep $ map prettyTCM (vs ++ ts) ]+ [ sep [ "applySection", prettyTCM m1, "=", prettyTCM m2, fsep $ map' prettyTCM (vs ++! ts) ] , nest 2 $ pretty copyInfo ]- args <- instantiateFull $ vs ++ ts++ args <- instantiateFull $ vs ++! ts++ -- Because we eta-expand module applications, we need to add aTel to the+ -- context, but aTel might contain invalidated local rewrite rules.+ -- We apply a sledgehammer fix for now, and check that all local rewrite+ -- rules are satisfied definitionally.+ aTel <- addRewConstraints aTel++ -- If we want to avoid eta-expanding modules (while supporting the current+ -- 'open public' behaviour) we should also change 'renName'/'renMod'+ -- in Agda.Syntax.Scope.Monad+ -- See #8443 let n = size aTel etaArgs <- inTopContext $ addContext aTel getContextArgs addContext (KeepNames aTel) $- applySection m1 (ptel `abstract` aTel) m2 (raise n args ++ etaArgs) copyInfo+ applySection m1 (ptel `abstract` aTel) m2 (raise n args ++! etaArgs) copyInfo checkSectionApplication' _ Erased{} _ A.RecordModuleInstance{} _ = __IMPOSSIBLE__@@ -1091,7 +1135,7 @@ -- Found last parameter: switch it to @Instance@. instFinal (ExtendTel dom (Abs n EmptyTel)) = ExtendTel do' (Abs n EmptyTel)- where do' = makeInstance dom { domName = Just $ WithOrigin Inserted $ unranged "r" }+ where do' = makeInstance (dom & dName .~ Just (WithOrigin Inserted $ unranged "r")) -- Otherwise, keep searchinf for last parameter: instFinal (ExtendTel arg (Abs n tel)) = ExtendTel arg (Abs n (instFinal tel))@@ -1104,8 +1148,8 @@ , nest 2 $ "name =" <+> prettyTCM name , nest 2 $ "tel =" <+> prettyTCM tel , nest 2 $ "telInst =" <+> prettyTCM telInst- , nest 2 $ "vs =" <+> sep (map prettyTCM vs)- -- , nest 2 $ "args =" <+> sep (map prettyTCM args)+ , nest 2 $ "vs =" <+> sep (map' prettyTCM vs)+ -- , nest 2 $ "args =" <+> sep (map' prettyTCM args) ] reportSDoc "tc.mod.apply" 60 $ vcat [ nest 2 $ "vs =" <+> text (show vs)@@ -1116,15 +1160,15 @@ addContext telInst $ do vs <- moduleParamsToApply x reportSDoc "tc.mod.apply" 20 $ vcat- [ nest 2 $ "vs =" <+> sep (map prettyTCM vs)- , nest 2 $ "args =" <+> sep (map (parens . prettyTCM) args)+ [ nest 2 $ "vs =" <+> sep (map' prettyTCM vs)+ , nest 2 $ "args =" <+> sep (map' (parens . prettyTCM) args) ] reportSDoc "tc.mod.apply" 60 $ vcat [ nest 2 $ "vs =" <+> text (show vs) , nest 2 $ "args =" <+> text (show args) ] addSection m1- applySection m1 telInst x (vs ++ args) copyInfo+ applySection m1 telInst x (vs ++! args) copyInfo -- | Checks that @open public@ is not used in hard compile-time mode. checkImportDirective :: A.ImportDirective -> TCM ()@@ -1169,13 +1213,13 @@ debugPrintDecl :: A.Declaration -> TCM () debugPrintDecl d = do verboseS "tc.decl" 45 $ do- reportSLn "tc.decl" 45 $ "checking a " ++ showHead d+ reportSLn "tc.decl" 45 $ "checking a " ++! showHead d case d of A.Section info erased mname tel ds -> do reportSLn "tc.decl" 45 $- "section " ++ prettyShow mname ++ " has "- ++ show (length $ A.generalizeTel tel) ++ " parameters and "- ++ show (length ds) ++ " declarations"+ "section " ++! prettyShow mname ++! " has "+ ++! show (length $ A.generalizeTel tel) ++! " parameters and "+ ++! show (length ds) ++! " declarations" reportSDoc "tc.decl" 45 $ prettyA $ A.Section info erased mname tel [] forM_ ds $ \ d -> do
src/full/Agda/TypeChecking/Rules/Decl.hs-boot view
@@ -5,7 +5,6 @@ import Agda.Syntax.Info (ModuleInfo) import Agda.Syntax.Abstract import Agda.Syntax.Common-import Agda.Syntax.Scope.Base import Agda.TypeChecking.Monad.Base (TCM) checkDecls :: [Declaration] -> TCM ()
src/full/Agda/TypeChecking/Rules/Def.hs view
@@ -52,14 +52,14 @@ import Agda.TypeChecking.InstanceArguments import Agda.TypeChecking.SizedTypes.Solve import Agda.TypeChecking.Rewriting.Confluence-import Agda.TypeChecking.CompiledClause (CompiledClauses'(..), hasProjectionPatterns)+import Agda.TypeChecking.CompiledClause (CompiledClauses', pattern Done, hasProjectionPatterns) import Agda.TypeChecking.CompiledClause.Compile import Agda.TypeChecking.Primitive hiding (Nat) import Agda.TypeChecking.RecordPatterns ( recordRHSToCopatterns ) import Agda.TypeChecking.Sort import Agda.TypeChecking.Rules.Term-import Agda.TypeChecking.Rules.LHS ( checkLeftHandSide, LHSResult(..), bindAsPatterns )+import Agda.TypeChecking.Rules.LHS ( checkLeftHandSide, LHSResult(..), bindAsPatterns, LetOrClause(ClauseLHS) ) import {-# SOURCE #-} Agda.TypeChecking.Rules.Decl ( checkDecls ) import Agda.Utils.Function ( applyWhen, applyWhenM )@@ -80,6 +80,7 @@ import Agda.Utils.Update import Agda.Utils.Impossible+import Agda.Utils.Tuple (snd3, fst3) --------------------------------------------------------------------------- -- * Definitions by pattern matching@@ -103,7 +104,7 @@ -- of an abstract function must not be informed by its definition. Just (e, mc, x) | Info.defAbstract i == ConcreteDef, Info.defOpaque i == TransparentDef ->- traceCall (CheckFunDefCall (getRange i) name cs True) $ do+ traceCall (CheckFunDefCall (getRange i) name True) $ do -- Andreas, 2012-11-22: if the alias is in an abstract block -- it has been frozen. We unfreeze it to enable type inference. -- See issue 729.@@ -120,8 +121,8 @@ -- happens. whenM (isOpenMeta <$> lookupMetaInstantiation x) $ setCurrentRange i $ warning $ MissingTypeSignatureForOpaque name (Info.defOpaque i)- checkFunDef' t info Nothing Nothing i name cs- _ -> checkFunDef' t info Nothing Nothing i name cs+ checkFunDef' t info Nothing i name cs+ _ -> checkFunDef' t info Nothing i name cs -- If it's a macro check that it ends in Term → TC ⊤ let ismacro = isMacro . theDef $ def@@ -166,7 +167,7 @@ , clauseRHS = A.RHS e mc , clauseWhereDecls = A.noWhereDecls , clauseCatchall = empty } in- atClause name 0 t Nothing clause $ do+ atClause name 0 t NoWithFunction clause $ do reportSDoc "tc.def.alias" 10 $ "checkAlias" <+> vcat [ text (prettyShow name) <+> colon <+> prettyTCM t , text (prettyShow name) <+> equals <+> prettyTCM e@@ -191,7 +192,8 @@ -- Add the definition fun <- emptyFunctionData- addConstant' name ai t $ FunctionDefn $+ applyWhenM (optPolarity <$> pragmaOptions) (applyPolarityToContext ai) $+ applyCohesionToContext ai $ addConstant' name ai t $ FunctionDefn $ set funMacro_ (Info.defMacro i == MacroDef) $ set funAbstr_ (Info.defAbstract i) $ fun { _funClauses = [ Clause -- trivial clause @name = v@@@ -202,12 +204,12 @@ , clauseBody = Just $ bodyMod v , clauseType = Just $ Arg ai t , clauseCatchall = empty- , clauseRecursive = Nothing -- we don't know yet+ , clauseRecursive = MaybeRecursive -- we don't know yet , clauseUnreachable = Just False , clauseEllipsis = NoEllipsis , clauseWhereModule = Nothing } ]- , _funCompiled = Just $ Done [] $ bodyMod v+ , _funCompiled = Just $ Done 0 MaybeRecursive [] $ bodyMod v , _funSplitTree = Just $ SplittingDone 0 , _funOpaque = Info.defOpaque i }@@ -215,7 +217,7 @@ -- Andreas, 2017-01-01, issue #2372: -- Add the definition to the instance table, if needed, to update its type. case Info.defInstance i of- InstanceDef _r -> setCurrentRange name $ readdTypedInstance name t+ InstanceDef kwr -> setCurrentRange name $ readdTypedInstance kwr name t -- Put highlighting on the name only; -- @(getRange (r, name))@ does not give good results. NotInstanceDef -> pure ()@@ -224,35 +226,35 @@ -- | Type check a definition by pattern matching.-checkFunDef' :: Type -- ^ the type we expect the function to have- -> ArgInfo -- ^ is it irrelevant (for instance)- -> Maybe ExtLamInfo -- ^ does the definition come from an extended lambda- -- (if so, we need to know some stuff about lambda-lifted args)- -> Maybe QName -- ^ is it a with function (if so, what's the name of the parent function)- -> A.DefInfo -- ^ range info- -> QName -- ^ the name of the function- -> [A.Clause] -- ^ the clauses to check- -> TCM ()-checkFunDef' t ai extlam with i name cs =- checkFunDefS t ai extlam with i name Nothing cs+checkFunDef' ::+ Type -- ^ The type we expect the function to have.+ -> ArgInfo -- ^ Is it irrelevant or erased etc.?+ -> Maybe ExtLamInfo -- ^ Does the definition come from an extended lambda?+ -- If so, we need to know some stuff about lambda-lifted args.+ -> A.DefInfo -- ^ 'Range' info.+ -> QName -- ^ The name of the function.+ -> [A.Clause] -- ^ The clauses to check.+ -> TCM ()+checkFunDef' t ai extlam i name cs =+ checkFunDefS t ai extlam NoWithFunction i name cs -- | Type check a definition by pattern matching.-checkFunDefS :: Type -- ^ the type we expect the function to have- -> ArgInfo -- ^ is it irrelevant (for instance)- -> Maybe ExtLamInfo -- ^ does the definition come from an extended lambda- -- (if so, we need to know some stuff about lambda-lifted args)- -> Maybe QName -- ^ is it a with function (if so, what's the name of the parent function)- -> A.DefInfo -- ^ range info- -> QName -- ^ the name of the function- -> Maybe (Substitution, Map Name LetBinding)- -- ^ substitution (from with abstraction) that needs to be applied- -- to module parameters, and let-bindings inherited from parent- -- clause- -> [A.Clause] -- ^ the clauses to check- -> TCM ()-checkFunDefS t ai extlam with i name withSubAndLets cs = do+checkFunDefS ::+ Type -- ^ The type we expect the function to have.+ -> ArgInfo -- ^ Is it irrelevant or erased etc.?+ -> Maybe ExtLamInfo -- ^ Does the definition come from an extended lambda?+ -- If so, we need to know some stuff about lambda-lifted args.+ -> IsWithFunction (QName, Substitution, Map Name LetBinding)+ -- ^ Is it a with function (if so, what's the name of the parent function)?+ -- ^ In that case, also substitution (from with abstraction) that needs to be applied+ -- to module parameters, and let-bindings inherited from parent clause.+ -> A.DefInfo -- ^ 'Range' info.+ -> QName -- ^ The name of the function.+ -> [A.Clause] -- ^ The clauses to check.+ -> TCM ()+checkFunDefS t ai extlam with i name cs = do - traceCall (CheckFunDefCall (getRange i) name cs True) $ do+ traceCall (CheckFunDefCall (getRange i) name True) $ do reportSDoc "tc.def.fun" 10 $ sep [ "checking body of" <+> prettyTCM name , nest 2 $ ":" <+> prettyTCM t@@ -260,12 +262,12 @@ ] reportSDoc "tc.def.fun" 70 $- sep $ "clauses:" : map (nest 2 . text . show . A.deepUnscope) cs+ sep $ "clauses:" : fmap (nest 2 . text . show . A.deepUnscope) cs - cs <- return $ map A.lhsToSpine cs+ cs <- return $! fmap A.lhsToSpine cs reportSDoc "tc.def.fun" 70 $- sep $ "spine clauses:" : map (nest 2 . text . show . A.deepUnscope) cs+ sep $ "spine clauses:" : fmap (nest 2 . text . show . A.deepUnscope) cs -- Ensure that all clauses have the same number of trailing hidden patterns -- This is necessary since trailing implicits are no longer eagerly inserted.@@ -276,10 +278,10 @@ -- Check the clauses cs <- traceCall NoHighlighting $ do -- To avoid flicker.- forM (zip cs [0..]) $ \ (c, clauseNo) -> do- atClause name clauseNo t (fst <$> withSubAndLets) c $ do+ forM (zip' cs [0..]) $ \ (c, clauseNo) -> do+ atClause name clauseNo t (snd3 <$> with) c $ do (c,b) <- applyModalityToContextFunBody ai $ do- checkClause t withSubAndLets c+ checkClause t with c -- Andreas, 2013-11-23 do not solve size constraints here yet -- in case we are checking the body of an extended lambda. -- 2014-04-24: The size solver requires each clause to be@@ -291,13 +293,13 @@ inTopContext $ addClauses name [c] return (c,b) - (cs, CPC isOneIxs) <- return $ (second mconcat . unzip) cs+ (cs, CPC isOneIxs) <- return $! (second mconcat . unzip) cs -- If there is a partial match ("system"), no proper (co)pattern matching is allowed. let isSystem = not . null $ isOneIxs when isSystem do -- allow VarP and ConP i0/i1 fallThrough = yes, DotP- let pss = map namedClausePats cs+ let pss = fmap namedClausePats cs allowed = \case VarP{} -> True -- pattern inserted by splitPartial@@ -308,15 +310,15 @@ typeError PatternInSystem reportSDoc "tc.def.fun" 70 $ inTopContext $ do- sep $ "checked clauses:" : map (nest 2 . text . show) cs+ sep $ "checked clauses:" : fmap (nest 2 . text . show) cs reportSDoc "tc.cc" 25 $ inTopContext $ do sep [ "clauses before injectivity test"- , nest 2 $ prettyTCM $ map (QNamed name) cs -- broken, reify (QNamed n cl) expect cl to live at top level+ , nest 2 $ prettyTCM $ fmap (QNamed name) cs -- broken, reify (QNamed n cl) expect cl to live at top level ]- reportSDoc "tc.cc" 60 $ inTopContext $ do+ reportSDoc "tc.cc" 90 $ inTopContext $ do sep [ "raw clauses: "- , nest 2 $ sep $ map (text . show . QNamed name) cs+ , nest 2 $ sep $ fmap (text . show . QNamed name) cs ] -- Needed to calculate the proper fullType below.@@ -337,12 +339,12 @@ , clauseBody = Nothing , clauseType = Just (defaultArg t) , clauseCatchall = empty- , clauseRecursive = Just False+ , clauseRecursive = NotRecursive , clauseUnreachable = Just False , clauseEllipsis = NoEllipsis , clauseWhereModule = Nothing }- return (cs ++ [c], pure sys)+ return (cs ++! [c], pure sys) -- The macro or inline tags might be on the type signature info <- getConstInfo name@@ -365,9 +367,10 @@ forM cs $ \ cl -> do (cls, nonExactSplit) <- runChangeT $ recordRHSToCopatterns cl when nonExactSplit do- -- If we inlined a non-eta constructor,- -- issue a warning that the clause does not hold as definitional equality.- warning $ InlineNoExactSplit name cl+ -- If we inlined a non-eta constructor, issue a warning+ -- (pointing at the clause lhs) that the clause does not+ -- hold as definitional equality.+ setCurrentRange (clauseLHSRange cl) . warning $ InlineNoExactSplit name cl return cls -- After checking, remove the clauses again.@@ -389,12 +392,12 @@ reportSDoc "tc.cc" 15 $ inTopContext $ do sep [ "clauses before compilation"- , nest 2 $ sep $ map (prettyTCM . QNamed name) cs+ , nest 2 $ sep $ fmap (prettyTCM . QNamed name) cs ] reportSDoc "tc.cc.raw" 65 $ do sep [ "clauses before compilation"- , nest 2 $ sep $ map (text . show) cs+ , nest 2 $ sep $ fmap (text . show) cs ] -- add clauses for the coverage (& confluence) checker (needs to reduce)@@ -403,14 +406,9 @@ reportSDoc "tc.cc.type" 60 $ " type : " <+> (text . prettyShow) t reportSDoc "tc.cc.type" 60 $ " context: " <+> (text . prettyShow =<< getContextTelescope) - fullType <- flip telePi t <$> getContextTelescope-- reportSLn "tc.cc.type" 80 $ show fullType- -- Coverage check and compile the clauses (mst, _recordExpressionBecameCopatternLHS, cc) <- Bench.billTo [Bench.Coverage] $- unsafeInTopContext $ compileClauses (if isSystem then Nothing else (Just (name, fullType)))- cs+ compileClauses (if isSystem then Nothing else (Just (name, t))) cs -- Andreas, 2019-10-21 (see also issue #4142): -- We ignore whether the clause compilation turned some -- record expressions into copatterns@@ -430,12 +428,16 @@ covering <- funCovering . theDef <$> getConstInfo name + cxt <- getContextTelescope+ let fullType = telePi cxt t+ reportSLn "tc.cc.type" 80 $ show fullType+ -- 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+ , nest 2 $ vcat $ map' (prettyTCM . QNamed name) cs ] -- If there was a pragma for this definition, we can set the@@ -454,7 +456,7 @@ , _funInv = inv , _funOpaque = Info.defOpaque i , _funExtLam = (\ e -> e { extLamSys = sys }) <$> extlam- , _funWith = with+ , _funWith = fmap fst3 with , _funCovering = covering } lang <- getLanguage@@ -483,28 +485,33 @@ Terminating -> Just True _ -> Nothing reportS "tc.fundef" 30 $- [ "funTerminates of " ++ prettyShow name ++ " set to " ++ show terminates- , " tc = " ++ show tc+ [ "funTerminates of " ++! prettyShow name ++! " set to " ++! show terminates+ , " tc = " ++! show tc ]- return $ def { theDef = fun { funTerminates = terminates }}+ return $! def { theDef = fun { funTerminates = terminates }} useTerPragma def = return def --- | Modify all the LHSCore of the given RHS.+-- | Modify all the @LHSCore@s of the given piece of syntax. -- (Used to insert patterns for @rewrite@ or the inspect idiom)-mapLHSCores :: (A.LHSCore -> A.LHSCore) -> (A.RHS -> A.RHS)-mapLHSCores f = \case- A.WithRHS aux es cs -> A.WithRHS aux es $ for cs $- \ (A.Clause (A.LHS info core) spats rhs ds catchall) ->- A.Clause (A.LHS info (f core)) spats (mapLHSCores f rhs) ds catchall- A.RewriteRHS qes spats rhs wh -> A.RewriteRHS qes spats (mapLHSCores f rhs) wh- rhs@A.AbsurdRHS -> rhs- rhs@A.RHS{} -> rhs+class HasLHSCores a where+ mapLHSCores :: (A.LHSCore -> A.LHSCore) -> (a -> a) +instance HasLHSCores A.RHS where+ mapLHSCores f = \case+ A.WithRHS aux es cs -> A.WithRHS aux es $ for cs $ mapLHSCores f+ A.RewriteRHS qes spats rhs wh -> A.RewriteRHS qes spats (mapLHSCores f rhs) wh+ rhs@A.AbsurdRHS -> rhs+ rhs@A.RHS{} -> rhs++instance HasLHSCores A.LHS where+ mapLHSCores f (A.LHS info core) = A.LHS info (f core)++instance HasLHSCores A.Clause where+ mapLHSCores f (A.Clause lhs spats rhs ds catchall) =+ A.Clause (mapLHSCores f lhs) spats (mapLHSCores f rhs) ds catchall+ -- | Insert some names into the with-clauses LHS of the given RHS. -- (Used for the inspect idiom)-insertNames :: List1 (Arg (Maybe A.BindName)) -> A.RHS -> A.RHS-insertNames = mapLHSCores . insertInspects- insertInspects :: List1 (Arg (Maybe A.BindName)) -> A.LHSCore -> A.LHSCore insertInspects ps = \case A.LHSWith core wps [] ->@@ -524,9 +531,9 @@ -> [Arg a] -> [Arg a] insertIn [] wps = wps insertIn (Arg info nm : ps) (w : wps) | visible info =- w : maybeToList nm ++ insertIn ps wps+ w : maybeToList nm ++! insertIn ps wps insertIn (Arg info nm : ps) wps | notVisible info =- maybeToList nm ++ insertIn ps wps+ maybeToList nm ++! insertIn ps wps insertIn _ _ = __IMPOSSIBLE__ @@ -543,9 +550,9 @@ core -> A.LHSWith core pats [] -- | Parameters for creating a @with@-function.-data WithFunctionProblem- = NoWithFunction- | WithFunction+type WithFunctionProblem = IsWithFunction WithFunctionProblemData++data WithFunctionProblemData = WithFunctionProblemData { wfParentName :: QName -- ^ Parent function name. , wfName :: QName -- ^ With function name. , wfParentType :: Type -- ^ Type of the parent function.@@ -611,15 +618,15 @@ orI (t:ts) = imax `apply` [argN t, argN (orI ts)] let- pats = map (take n . map (namedThing . unArg) . namedClausePats) cs+ pats = map' (take' n . map' (namedThing . unArg) . namedClausePats) cs alphas :: [[(Int,Bool)]] -- the face maps corresponding to each clause- alphas = map (collectDirs (downFrom n)) pats+ alphas = map' (collectDirs (downFrom n)) pats phis :: [Term] -- the φ terms for each clause (i.e. the alphas as terms)- phis = map (andI . (map dir)) alphas+ phis = map' (andI . (map' dir)) alphas psi = orI $ phis- pcs = zip phis cs+ pcs = zip' phis cs - reportSDoc "tc.sys.cover" 20 $ fsep $ map prettyTCM pats+ reportSDoc "tc.sys.cover" 20 $ fsep $ map' prettyTCM pats interval <- primIntervalType reportSDoc "tc.sys.cover" 10 $ "equalTerm " <+> prettyTCM (unArg phi) <+> prettyTCM psi equalTerm interval (unArg phi) psi@@ -638,12 +645,12 @@ TelV delta _ <- telViewUpTo extra t' fmap (abstract delta) $ addContext delta $ do fmap fromReduced $ runReduceM $- appDef' f (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 - sys <- forM (zip alphas cs) $ \ (alpha,cl) -> do+ sys <- forM (zip' alphas cs) $ \ (alpha,cl) -> do let -- Δ = Γ_α , Δ'α@@ -661,11 +668,11 @@ weak [] = idS weak (i:is) = weak is `composeS` liftS i (raiseS 1) tel = telFromList (takeLast extra (telToList delta))- u = abstract tel (liftS extra (weak $ List.sort $ map fst alpha) `applySubst` b)- return (map (first var) alpha,u)+ u = abstract tel (liftS extra (weak $ List.sort $ map' fst alpha) `applySubst` b)+ return (map' (first var) alpha,u) - reportSDoc "tc.sys.cover.sys" 20 $ fsep $ prettyTCM gamma : map prettyTCM sys- reportSDoc "tc.sys.cover.sys" 40 $ fsep $ (text . show) gamma : map (text . show) sys+ reportSDoc "tc.sys.cover.sys" 20 $ fsep $ prettyTCM gamma : map' prettyTCM sys+ reportSDoc "tc.sys.cover.sys" 40 $ fsep $ (text . show) gamma : map' (text . show) sys return (System gamma sys) -- gamma uses names from the type, not the patterns, could we do better? _ -> __IMPOSSIBLE__ checkSystemCoverage _ _ t cs = __IMPOSSIBLE__@@ -685,9 +692,9 @@ mempty = CPC empty mappend = (<>) --- | The LHS part of checkClause.-checkClauseLHS :: Type -> Maybe Substitution -> A.SpineClause -> (LHSResult -> TCM a) -> TCM a-checkClauseLHS t withSub c@(A.Clause lhs@(A.SpineLHS i x aps) strippedPats rhs0 wh catchall) ret = do+-- | The LHS part of 'checkClause'.+checkClauseLHS :: Type -> IsWithFunction Substitution -> A.SpineClause -> (LHSResult -> TCM a) -> TCM a+checkClauseLHS t withSub c@(A.Clause lhs@(A.SpineLHS i x aps) strippedPats _rhs0 _wh _catchall) ret = do reportSDoc "tc.lhs.top" 30 $ "Checking clause" $$ prettyA c () <- List1.unlessNull (trailingWithPatterns aps) $ \ withPats -> do typeError $ UnexpectedWithPatterns $ fmap namedArg withPats@@ -696,23 +703,27 @@ unless (null strippedPats) $ reportSDoc "tc.lhs.top" 50 $ "strippedPats:" <+> vcat [ prettyA p <+> "=" <+> prettyTCM v <+> ":" <+> prettyTCM a | A.ProblemEq p v a <- strippedPats ] closed_t <- flip abstract t <$> getContextTelescope- checkLeftHandSide (CheckLHS lhs) (getRange lhs) (Just x) aps t withSub strippedPats ret+ checkLeftHandSide (CheckLHS lhs) (getRange lhs) (ClauseLHS x) aps t withSub strippedPats ret -- | Type check a function clause. checkClause- :: Type -- ^ Type of function defined by this clause.- -> Maybe (Substitution, Map Name LetBinding) -- ^ Module parameter substitution arising from with-abstraction, and inherited let-bindings.- -> A.SpineClause -- ^ Clause.- -> TCM (Clause, ClausesPostChecks) -- ^ Type-checked clause+ :: Type+ -- ^ Type of function defined by this clause.+ -> IsWithFunction (QName, Substitution, Map Name LetBinding)+ -- ^ Parent function, module parameter substitution arising from with-abstraction, and inherited let-bindings.+ -> A.SpineClause+ -- ^ Clause.+ -> TCM (Clause, ClausesPostChecks)+ -- ^ Type-checked clause checkClause t withSubAndLets c@(A.Clause lhs@(A.SpineLHS i x aps) strippedPats rhs0 wh catchall) = do- let withSub = fst <$> withSubAndLets+ let withSub = snd3 <$> withSubAndLets cxtNames <- getContextNames checkClauseLHS t withSub c $ \ lhsResult@(LHSResult npars delta ps absurdPat trhs patSubst asb psplit ixsplit) -> do let installInheritedLets k- | Just (withSub, lets) <- withSubAndLets = do+ | WithFunction (_f, withSub, lets) <- withSubAndLets = do lets' <- traverse makeOpen $ applySubst (patSubst `composeS` withSub) lets locallyTC eLetBindings (lets' <>) k | otherwise = k@@ -725,10 +736,10 @@ -- type. If we're checking a with-function that's already the case, -- otherwise we need to abstract over the module telescope. t' <- case withSub of- Just{} -> return t- Nothing -> do+ WithFunction{} -> return t+ NoWithFunction -> do theta <- lookupSection (qnameModule x)- return $ abstract theta t+ return $! abstract theta t -- At this point we should update the named dots potential with-clauses -- in the right-hand side. When checking a clause we expect the named@@ -754,7 +765,7 @@ wbody <- unsafeInTopContext $ Bench.billTo [Bench.Typing, Bench.With] $ checkWithFunction cxtNames with - body <- return $ body `mplus` wbody+ body <- return $! body `mplus` wbody whenM (optDoubleCheck <$> pragmaOptions) $ case body of Just v -> do@@ -768,14 +779,14 @@ reportSDoc "tc.lhs.top" 10 $ vcat [ "Clause before translation:" , nest 2 $ vcat- [ "delta =" <+> do escapeContext impossible (size delta) $ prettyTCM delta+ [ "delta =" <+> prettyTCM delta , "ps =" <+> do P.fsep <$> prettyTCMPatterns ps , "body =" <+> maybe "_|_" prettyTCM body , "type =" <+> prettyTCM t ] ] - reportSDoc "tc.lhs.top" 60 $ escapeContext impossible (size delta) $ vcat+ reportSDoc "tc.lhs.top" 90 $ vcat [ "Clause before translation (raw):" , nest 2 $ vcat [ "ps =" <+> text (show ps)@@ -792,7 +803,7 @@ -- treat them as catchalls. let catchall' = if isNothing body then YesCatchall empty else catchall - return $ (, CPC psplit)+ return $! (, CPC psplit) Clause { clauseLHSRange = getRange i , clauseFullRange = getRange c , clauseTel = killRange delta@@ -800,7 +811,7 @@ , clauseBody = bodyMod body , clauseType = Just trhs , clauseCatchall = catchall'- , clauseRecursive = Nothing -- we don't know yet+ , clauseRecursive = MaybeRecursive -- we don't know yet , clauseUnreachable = Nothing -- we don't know yet , clauseEllipsis = lhsEllipsis i , clauseWhereModule = A.whereModule wh@@ -876,8 +887,8 @@ nfv <- getCurrentModuleFreeVars m <- currentModule sep [ "with function module:" <+>- prettyList (map prettyTCM $ mnameToList m)- , text $ "free variables: " ++ show nfv+ prettyList (map' prettyTCM $ mnameToList m)+ , text $ "free variables: " ++! show nfv ] -- Infer the types of the with expressions@@ -889,10 +900,7 @@ Just{} -> IdiomType ty let names = fmap (\ (Named nm e) -> nm <$ e) es- cs <- forM cs $ \ c@(A.Clause (A.LHS i core) eqs rhs wh b) -> do- let rhs' = insertNames names rhs- let core' = insertInspects names core- pure $ A.Clause (A.LHS i core') eqs rhs' wh b+ cs <- pure $ for cs $ mapLHSCores (insertInspects names) -- Andreas, 2016-01-23, Issue #1796 -- Run the size constraint solver to improve with-abstraction@@ -926,7 +934,7 @@ -- @using@ clauses usingEqnRHS :: List1 (A.Pattern, A.Expr) -> [A.RewriteEqn] -> TCM (Maybe Term, WithFunctionProblem) usingEqnRHS pes rs = do- let letBindings = for (List1.toList pes) $ \(p, e) -> A.LetPatBind (LetRange (getRange e)) p e+ let letBindings = for (List1.toList pes) $ \(p, e) -> A.LetPatBind (LetRange (getRange e)) defaultArgInfo p e checkLetBindings' letBindings $ rewriteEqnsRHS rs strippedPats rhs wh -- @invert@ clauses@@ -1074,7 +1082,7 @@ -- Andreas, 2012-09-17: for printing delta, -- we should remove it from the context first- reportSDoc "tc.with.top" 25 $ escapeContext impossible (size delta) $ vcat+ reportSDoc "tc.with.top" 25 $ unsafeEscapeContext (size delta) $ vcat [ "delta =" <+> prettyTCM delta ] reportSDoc "tc.with.top" 25 $ vcat $@@ -1090,11 +1098,11 @@ let (delta1, delta2, perm', t', vtys) = splitTelForWith delta (unArg trhs) vtys0 let finalPerm = composeP perm' perm - reportSLn "tc.with.top" 75 $ "delta = " ++ show delta+ reportSLn "tc.with.top" 75 $ "delta = " ++! show delta -- Andreas, 2012-09-17: for printing delta, -- we should remove it from the context first- reportSDoc "tc.with.top" 25 $ escapeContext impossible (size delta) $ vcat+ reportSDoc "tc.with.top" 25 $ unsafeEscapeContext (size delta) $ vcat [ "delta1 =" <+> prettyTCM delta1 , "delta2 =" <+> addContext delta1 (prettyTCM delta2) ]@@ -1110,11 +1118,11 @@ let n = size us m = size delta -- First the variables bound outside this definition- (us0, us1') = splitAt (n - m) us+ (us0, us1') = splitAt' (n - m) us -- Then permute the rest and grab those needed to for the with arguments- (us1, us2) = splitAt (size delta1) $ permute perm' us1'+ (us1, us2) = splitAt' (size delta1) $ permute perm' us1' -- Now stuff the with arguments in between and finish with the remaining variables- argsS = parallelS $ reverse $ us0 ++ us1 ++ map unArg (List1.toList withArgs) ++ us2+ argsS = parallelS $ reverse $ us0 ++! us1 ++! map' unArg (List1.toList withArgs) ++! us2 v = Nothing -- generated by checkWithFunction -- Andreas, 2013-02-26 add with-name to signature for printing purposes addConstant aux =<< do@@ -1127,24 +1135,25 @@ let (vs, as) = List1.unzipWith unArg vtys in -- Andreas, 2025-04-07, escapeContext impossible Δ leads to crash if e.g. vs has metas defined in Δ. -- Thus, we use unsafeEscapeContext instead.+ -- 2026-08-30 See also issue #8582 whose OP triggers such crashes. [ " with arguments" <+> do unsafeEscapeContext (size delta) $ addContext delta1 $ prettyList (fmap prettyTCM vs) , " types" <+> do unsafeEscapeContext (size delta) $ addContext delta1 $ prettyList (fmap prettyTCM as) , " context" <+> (prettyTCM =<< getContextTelescope)- , " delta" <+> do escapeContext impossible (size delta) $ prettyTCM delta- , " delta1" <+> do escapeContext impossible (size delta) $ prettyTCM delta1- , " delta2" <+> do escapeContext impossible (size delta) $ addContext delta1 $ prettyTCM delta2+ , " delta" <+> do unsafeEscapeContext (size delta) $ prettyTCM delta+ , " delta1" <+> do unsafeEscapeContext (size delta) $ prettyTCM delta1+ , " delta2" <+> do unsafeEscapeContext (size delta) $ addContext delta1 $ prettyTCM delta2 ] -- Only inherit user-written let bindings from parent clauses. Others, like @-patterns, -- should not be carried over. lets <- Map.filter ((== UserWritten) . letOrigin) <$> (traverse getOpen =<< viewTC eLetBindings) - return (v, WithFunction x aux t delta delta1 delta2 vtys t' ps npars perm' perm finalPerm cs argsS lets)+ return (v, WithFunction (WithFunctionProblemData x aux t delta delta1 delta2 vtys t' ps npars perm' perm finalPerm cs argsS lets)) -- | Invoked in empty context. checkWithFunction :: [Name] -> WithFunctionProblem -> TCM (Maybe Term) checkWithFunction _ NoWithFunction = return Nothing-checkWithFunction cxtNames (WithFunction f aux t delta delta1 delta2 vtys b qs npars perm' perm finalPerm cs argsS lets) = do+checkWithFunction cxtNames (WithFunction (WithFunctionProblemData f aux t delta delta1 delta2 vtys b qs npars perm' perm finalPerm cs argsS lets)) = do let -- Δ₁ ws Δ₂ ⊢ withSub : Δ′ (where Δ′ is the context of the parent lhs) withSub :: Substitution withSub = let as = fmap (snd . unArg) vtys in@@ -1191,7 +1200,7 @@ iz <- primIZero io <- primIOne let tm = Def f (patternsToElims ps)- return $ Boundary [(i,(inplaceS i iz `applySubst` tm, inplaceS i io `applySubst` tm)) | i <- vs]+ return $! Boundary [(i,(inplaceS i iz `applySubst` tm, inplaceS i io `applySubst` tm)) | i <- vs] reportSDoc "tc.with.bndry" 40 $ addContext delta1 $ addContext delta2 $ text "bndry =" <+> pretty bndry withFunctionType delta1 vtys delta2 b bndry@@ -1225,7 +1234,7 @@ Display n ts dt -> reportSDoc "tc.with.top" 20 $ "Display" <+> fsep [ text (show n)- , prettyList $ map prettyTCM ts+ , prettyList $ map' prettyTCM ts , prettyTCM dt ] addConstant aux =<< do@@ -1242,14 +1251,14 @@ , nest 2 $ "-|" <+> (prettyTCM =<< getContextTelescope) ] reportSDoc "tc.with.top" 70 $ vcat- [ nest 2 $ text $ "raw with func. type = " ++ show withFunType+ [ nest 2 $ text $ "raw with func. type = " ++! show withFunType ] -- Construct the body for the with function- cs <- return $ fmap (A.lhsToSpine) cs+ cs <- return $! fmap (A.lhsToSpine) cs cs <- buildWithFunction cxtNames f aux t delta qs npars withSub finalPerm (size delta1) nwithpats cs- cs <- return $ fmap (A.spineToLhs) cs+ cs <- return $! fmap (A.spineToLhs) cs -- #4833: inherit abstract mode from parent abstr <- defAbstract <$> ignoreAbstractMode (getConstInfo f)@@ -1257,7 +1266,7 @@ -- Check the with function let info = Info.mkDefInfo (nameConcrete $ qnameName aux) noFixity' PublicAccess abstr (getRange cs) ai <- defArgInfo <$> getConstInfo f- checkFunDefS withFunType ai Nothing (Just f) info aux (Just (withSub, lets)) $ List1.toList cs+ checkFunDefS withFunType ai Nothing (WithFunction (f, withSub, lets)) info aux $ List1.toList cs return $ Just $ call_in_parent -- | Type check a where clause.@@ -1275,7 +1284,7 @@ -- If we are in erased context, mark the module as erased. e <- case e of NotErased oo -> do- asksTC envQuantity >>= \case+ viewTC eQuantity >>= \case Quantity0 o -> do unless (oo == QωInferred) $ setCurrentRange oo $ warning $ PlentyInHardCompileTimeMode oo@@ -1290,15 +1299,14 @@ withCurrentModule m ret _ -> __IMPOSSIBLE__ where- whereEnv e = e- { envCheckingWhere = if whNamed then C.SomeWhere_ else C.AnyWhere_- }+ whereEnv = set' eCheckingWhere (if whNamed then C.SomeWhere_ else C.AnyWhere_)+ -- #2897: We can't handle named where-modules in refined contexts. ensureNoNamedWhereInRefinedContext Nothing = return () ensureNoNamedWhereInRefinedContext (Just m) = traceCall (CheckNamedWhere m) $ do- args <- map unArg <$> (moduleParamsToApply =<< currentModule)+ args <- map' unArg <$> (moduleParamsToApply =<< currentModule) unless (isWeakening args) $ do -- weakened contexts are fine- names <- map (argNameToString . fst . unDom) . telToList <$>+ names <- map' (argNameToString . fst . unDom) . telToList <$> (lookupSection =<< currentModule) typeError $ NamedWhereModuleInRefinedContext args names where@@ -1321,9 +1329,9 @@ setHardCompileTimeModeIfErased e $ do reportSDoc "tc.section" 10 $ "checking section" <+> (prettyErased e <$> prettyTCM m) <+>- fsep (map prettyA tel)+ fsep (map' prettyA tel) - checkGeneralizeTelescope (Just m) gtel $ \ _ tel' -> do+ checkGeneralizeTelescope ModTelNotData (Just m) gtel $ \ _ tel' -> do reportSDoc "tc.section" 10 $ "adding section:" <+> prettyTCM m <+> text (show (size tel')) @@ -1336,7 +1344,7 @@ -- | Set the current clause number. -atClause :: QName -> Int -> Type -> Maybe Substitution -> A.SpineClause -> TCM a -> TCM a+atClause :: QName -> Int -> Type -> IsWithFunction Substitution -> A.SpineClause -> TCM a -> TCM a atClause name i t sub cl ret = do clo <- buildClosure ()- localTC (\ e -> e { envClause = IPClause name i t sub cl clo }) ret+ localTC (set eClause (IPClause name i t sub cl clo)) ret
src/full/Agda/TypeChecking/Rules/Def.hs-boot view
@@ -9,7 +9,7 @@ checkFunDef :: DefInfo -> QName -> [Clause] -> TCM () -checkFunDef' :: I.Type -> ArgInfo -> Maybe ExtLamInfo -> Maybe QName -> DefInfo -> QName -> [Clause] -> TCM ()+checkFunDef' :: I.Type -> ArgInfo -> Maybe ExtLamInfo -> DefInfo -> QName -> [Clause] -> TCM () newSection :: Erased -> ModuleName -> A.GeneralizeTelescope -> TCM a -> TCM a
src/full/Agda/TypeChecking/Rules/Display.hs view
@@ -92,7 +92,7 @@ case p of A.VarP A.BindName{unBind = x} -> bindVar x $ ret 1 var0 A.ConP _ cs ps- | Just c <- getUnambiguous cs -> pappToTerm c (Con (ConHead c IsData Inductive []) ConOCon) ps \ n t -> ret n (IsApp t)+ | Just c <- getUnambiguous cs -> pappToTerm c (Con (ConHead c IsData Inductive NotHIT []) ConOCon) ps \ n t -> ret n (IsApp t) | otherwise -> ambigErr "constructor" cs A.ProjP _ _ ds | Just d <- getUnambiguous ds -> ret 0 $ IsProj d@@ -112,10 +112,10 @@ where fail = throwError . ("its left-hand side contains " ++) failP s = fail . (s ++) . (": " ++) . render =<< prettyA p- ambigErr thing (AmbQ xs) =+ ambigErr thing x = fail . render =<< do text ("an ambiguous " ++ thing ++ ":") <?>- fsep (punctuate comma (fmap pretty xs))+ fsep (punctuate ";" (fmap pretty (getAmbiguous x))) bindWild :: M a -> M a bindWild ret = do@@ -128,10 +128,17 @@ exprToTerm :: A.Expr -> M Term exprToTerm e = case unScope e of+ -- removed by 'unScope'+ A.ScopedExpr{} -> __IMPOSSIBLE__++ -- preserved by 'unScope', but only matters for highlighting+ A.Qualified _ e -> exprToTerm e+ A.Highlighted _ e -> exprToTerm e+ A.Var x -> fst <$> getVarInfo x A.Def' f NoSuffix-> pure $ Def f [] A.Def'{} -> fail "suffix"- A.Con c -> pure $ Con (ConHead (headAmbQ c) IsData Inductive []) ConOCon [] -- Don't care too much about ambiguity here+ A.Con c -> pure $ Con (ConHead (headAmbQ c) IsData Inductive NotHIT []) ConOCon [] -- Don't care too much about ambiguity here A.Lit _ l -> pure $ Lit l A.App _ e arg -> applyE <$> exprToTerm e <*> ((:[]) . inheritHiding arg . IsApp <$> exprToTerm (namedArg arg)) @@ -139,24 +146,23 @@ A.PatternSyn f -> pure $ Def (headAmbQ f) [] A.Macro f -> pure $ Def f [] - A.WithApp{} -> fail "with application"- A.QuestionMark{} -> fail "hole"- A.Underscore{} -> fail "metavariable"- A.Dot{} -> fail "dotted expression"- A.Lam{} -> fail "lambda"- A.AbsurdLam{} -> fail "lambda"- A.ExtendedLam{} -> fail "lambda"- A.Fun{} -> fail "function type"- A.Pi{} -> fail "function type"- A.Generalized{} -> __IMPOSSIBLE__- A.Let{} -> fail "let"- A.Rec{} -> fail "record"- A.RecUpdate{} -> fail "record update"- A.ScopedExpr{} -> __IMPOSSIBLE__- A.Quote{} -> fail "quotation"- A.QuoteTerm{} -> fail "quotation"- A.Unquote{} -> fail "unquote"- A.DontCare{} -> __IMPOSSIBLE__+ A.WithApp{} -> fail "with application"+ A.QuestionMark{} -> fail "hole"+ A.Underscore{} -> fail "metavariable"+ A.Dot{} -> fail "dotted expression"+ A.Lam{} -> fail "lambda"+ A.AbsurdLam{} -> fail "lambda"+ A.ExtendedLam{} -> fail "lambda"+ A.Fun{} -> fail "function type"+ A.Pi{} -> fail "function type"+ A.Generalized{} -> __IMPOSSIBLE__+ A.Let{} -> fail "let"+ A.Rec{} -> fail "record"+ A.RecUpdate{} -> fail "record update"+ A.Quote{} -> fail "quotation"+ A.QuoteTerm{} -> fail "quotation"+ A.Unquote{} -> fail "unquote"+ A.DontCare{} -> __IMPOSSIBLE__ where fail = throwError . ("its right-hand side contains a " ++)
src/full/Agda/TypeChecking/Rules/LHS.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE NondecreasingIndentation #-}+-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-all -dno-suppress-type-signatures -ddump-to-file -dno-typeable-binds #-} module Agda.TypeChecking.Rules.LHS ( checkLeftHandSide@@ -7,6 +8,9 @@ , IsFlexiblePattern(..) , DataOrRecord , checkSortOfSplitVar+ , LetOrClause(LetLHS, ClauseLHS)+ , buildLHSSubstitutions+ , checkAbsurdPattern ) where import Prelude hiding ( null )@@ -14,18 +18,13 @@ import Data.Function (on) import Data.Maybe -import Control.Arrow (left) import Control.Monad.Except ( MonadError(..), ExceptT(..), runExceptT )-import Control.Monad.Reader ( MonadReader(..), asks, runReaderT )-import Control.Monad.Writer ( MonadWriter(..), runWriterT ) import Control.Monad.Trans.Maybe import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import Data.List (findIndex) import qualified Data.List as List-import Data.Semigroup ( Semigroup )-import qualified Data.Semigroup as Semigroup import Data.Map (Map) import qualified Data.Map as Map @@ -34,12 +33,12 @@ import Agda.Interaction.Options import Agda.Interaction.Options.Lenses -import Agda.Syntax.Internal as I hiding (DataOrRecord)+import Agda.Syntax.Internal as I import Agda.Syntax.Internal.Pattern import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Abstract.Views (asView, deepUnscope) import Agda.Syntax.Concrete (FieldAssignment'(..),LensInScope(..))-import Agda.Syntax.Common as Common+import Agda.Syntax.Common hiding (DataOrRecord) import qualified Agda.Syntax.Info as A import Agda.Syntax.Literal import Agda.Syntax.Position@@ -84,6 +83,7 @@ import Agda.Utils.List2 (pattern List2) import qualified Agda.Utils.List1 as List1 import qualified Agda.Utils.List2 as List2+import Agda.Utils.Either import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null@@ -92,10 +92,19 @@ import Agda.Utils.Singleton import Agda.Utils.Size import Agda.Utils.Tuple+import Agda.Utils.StrictReader+import Agda.Utils.StrictWriter import Agda.Utils.Impossible-import Agda.TypeChecking.Free (freeIn)+import Agda.TypeChecking.Free (anyFreeVar, freeIn) +-- | Are we checking the LHS of a let-pattern binding or a function clause?+data LetOrClause+ = LetLHS+ -- ^ Checking a pattern bound by a let.+ | ClauseLHS QName+ -- ^ Checking the LHS of a clause of the function with the given 'QName'.+ -- | Extra read-only state for the LHS checker. -- data LHSContext = LHSContext@@ -106,9 +115,9 @@ -- | A pattern is flexible if it is dotted or implicit, or a record pattern -- with only flexible subpatterns. class IsFlexiblePattern a where- maybeFlexiblePattern :: (HasConstInfo m, MonadDebug m) => a -> MaybeT m FlexibleVarKind+ maybeFlexiblePattern :: (HasConstInfo m) => a -> MaybeT m FlexibleVarKind - isFlexiblePattern :: (HasConstInfo m, MonadDebug m) => a -> m Bool+ isFlexiblePattern :: (HasConstInfo m) => a -> m Bool isFlexiblePattern p = maybe False notOtherFlex <$> runMaybeT (maybeFlexiblePattern p) where@@ -154,7 +163,7 @@ instance IsFlexiblePattern a => IsFlexiblePattern (Arg a) where maybeFlexiblePattern = maybeFlexiblePattern . unArg -instance IsFlexiblePattern a => IsFlexiblePattern (Common.Named name a) where+instance IsFlexiblePattern a => IsFlexiblePattern (Named name a) where maybeFlexiblePattern = maybeFlexiblePattern . namedThing -- | Update the given LHS state:@@ -176,14 +185,14 @@ updateProblemEqs eqs = do reportSDoc "tc.lhs.top" 20 $ vcat [ "updateProblem: equations to update"- , nest 2 $ if null eqs then "(none)" else vcat $ map prettyTCM eqs+ , nest 2 $ if null eqs then "(none)" else vcat $ map' prettyTCM eqs ] eqs' <- updates eqs reportSDoc "tc.lhs.top" 20 $ vcat [ "updateProblem: new equations"- , nest 2 $ if null eqs' then "(none)" else vcat $ map prettyTCM eqs'+ , nest 2 $ if null eqs' then "(none)" else vcat $ map' prettyTCM eqs' ] return eqs'@@ -201,7 +210,7 @@ update eq@(ProblemEq p v a) = reduce v >>= constructorForm >>= \case Con c ci es -> do- let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ let vs = mustAllApplyElims es -- we should only simplify equations between fully applied constructors contype <- getFullyAppliedConType c =<< reduce (unDom a) caseMaybe contype (return [eq]) $ \((d,_,pars),b) -> do@@ -211,7 +220,7 @@ let updMod = composeModality (getModality a) ctel <- return $ mapModality updMod <$> ctel - let bs = instTel ctel (map unArg vs)+ let bs = instTel ctel (map' unArg vs) p <- expandLitPattern p case p of@@ -227,7 +236,7 @@ -- Insert implicit patterns ps <- insertImplicitPatterns ExpandLast ps ctel reportSDoc "tc.lhs.imp" 20 $- "insertImplicitPatternsT returned" <+> fsep (map prettyA ps)+ "insertImplicitPatternsT returned" <+> fsep (map' prettyA ps) -- Check argument count and hiding (not just count: #3074) let checkArgs [] [] _ _ = return ()@@ -241,17 +250,17 @@ checkArgs ps vs 0 0 - updates $ zipWith3 ProblemEq (map namedArg ps) (map unArg vs) bs+ updates $ zipWith3 ProblemEq (map' namedArg ps) (map' unArg vs) bs A.RecP _ _ fs -> do- axs <- map argFromDom . recFields . theDef <$> getConstInfo d+ axs <- map' argFromDom . recFields . theDef <$> getConstInfo d -- Andreas, 2018-09-06, issue #3122. -- Associate the concrete record field names used in the record pattern -- to their counterpart in the record type definition.- disambiguateRecordFields (map _nameFieldA fs) (map unArg axs)+ disambiguateRecordFields (map' _nameFieldA fs) (map' unArg axs) - let cxs = map (fmap (nameConcrete . qnameName)) axs+ let cxs = map' (fmap (nameConcrete . qnameName)) axs -- In fs omitted explicit fields are replaced by underscores, -- and the fields are put in the correct order.@@ -260,7 +269,7 @@ -- We also need to insert missing implicit or instance fields. ps <- insertImplicitPatterns ExpandLast ps ctel - let eqs = zipWith3 ProblemEq (map namedArg ps) (map unArg vs) bs+ let eqs = zipWith3 ProblemEq (map' namedArg ps) (map' unArg vs) bs updates eqs _ -> return [eq]@@ -291,7 +300,7 @@ problemAllVariables :: Problem a -> Bool problemAllVariables problem = all isSolved $- map namedArg (problem ^. problemRestPats) ++ problemInPats problem+ map' namedArg (problem ^. problemRestPats) ++! problemInPats problem where -- need further splitting: isSolved A.ConP{} = False@@ -319,7 +328,8 @@ -- Precondition: The problem has to be solved. noShadowingOfConstructors :: ProblemEq -> TCM ()-noShadowingOfConstructors problem@(ProblemEq p _ (Dom{domInfo = info, unDom = El _ a})) =+noShadowingOfConstructors problem@(ProblemEq p _ dom@(unDom -> El _ a)) = do+ let info = dom ^. dInfo case p of A.WildP {} -> return () A.AbsurdP {} -> return ()@@ -339,9 +349,9 @@ -- Thus, only complain about user written variable that shadow constructors. A.VarP A.BindName{unBind = x} -> when (getOrigin info == UserWritten) $ do reportSDoc "tc.lhs.shadow" 30 $ vcat- [ text $ "checking whether pattern variable " ++ prettyShow x ++ " shadows a constructor"+ [ text $ "checking whether pattern variable " ++! prettyShow x ++! " shadows a constructor" , nest 2 $ "type of variable =" <+> prettyTCM a- , nest 2 $ "position of variable =" <+> (text . show) (getRange x)+ , nest 2 $ "position of variable =" <+> pretty (getRange x) ] reportSDoc "tc.lhs.shadow" 70 $ nest 2 $ "a =" <+> pretty a @@ -384,7 +394,7 @@ -- | Check that a dot pattern matches it's instantiation. checkDotPattern :: DotPattern -> TCM ()-checkDotPattern (Dot e v (Dom{domInfo = info, unDom = a})) =+checkDotPattern (Dot e v dom@(unDom -> a)) = traceCall (CheckDotPattern e v) $ do reportSDoc "tc.lhs.dot" 15 $ sep [ "checking dot pattern"@@ -392,18 +402,26 @@ , nest 2 $ "=" <+> prettyTCM v , nest 2 $ ":" <+> prettyTCM a ]- applyModalityToContext info $ do+ applyDomToContext dom $ do u <- checkExpr e a- reportSDoc "tc.lhs.dot" 50 $- sep [ "equalTerm"- , nest 2 $ pretty a- , nest 2 $ pretty u- , nest 2 $ pretty v- ]- equalTerm a u v+ unless (isIrrelevant dom) do+ reportSDoc "tc.lhs.dot" 50 $+ sep [ "equalTerm"+ , nest 2 $ pretty a+ , nest 2 $ pretty u+ , nest 2 $ pretty v+ ]+ equalTerm a u v checkAbsurdPattern :: AbsurdPattern -> TCM ()-checkAbsurdPattern (Absurd r a) = ensureEmptyType r a+checkAbsurdPattern (Absurd r a) = do+ ensureEmptyType r a+ erased <- hasQuantity0 <$> viewTC eQuantity+ erasedMatches <- optErasedMatches <$> pragmaOptions+ when (not erased && not (emEmpty erasedMatches) && hasQuantity0 a) $+ typeError . SplitError .+ ErasedDatatype ErasedMatchesDisabledEmpty =<<+ buildClosure (unDom a) checkAnnotationPattern :: AnnotationPattern -> TCM () checkAnnotationPattern (Ann t a) = do@@ -436,7 +454,7 @@ -> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern] transfers [] qs- | all notVisible qs = return $ map (setOrigin Inserted) qs+ | all notVisible qs = return $ map' (setOrigin Inserted) qs | otherwise = __IMPOSSIBLE__ transfers (p : ps) [] = __IMPOSSIBLE__ transfers (p : ps) (q : qs)@@ -450,26 +468,27 @@ transfer :: A.Pattern -> DeBruijnPattern -> TCM DeBruijnPattern transfer p q = case (asView p , q) of - ((asB , A.ConP pi _ ps) , ConP c (ConPatternInfo i r ft mb l) qs) -> do- let cpi = ConPatternInfo (PatternInfo PatOCon asB) r ft mb l+ ((asB , A.ConP pi _ ps) , ConP c (ConPatternInfo i r ft mb l prio) qs) -> do+ let cpi = ConPatternInfo (PatternInfo PatOCon asB) r ft mb l prio ConP c cpi <$> transfers ps qs - ((asB , A.RecP _kwr pi fs) , ConP c (ConPatternInfo i r ft mb l) qs) -> do+ ((asB , A.RecP _kwr pi fs) , ConP c (ConPatternInfo i r ft mb l prio) qs) -> do let Def d _ = unEl $ unArg $ fromMaybe __IMPOSSIBLE__ mb- axs = map (nameConcrete . qnameName . unArg) (conFields c) `withArgsFrom` qs- cpi = ConPatternInfo (PatternInfo PatORec asB) r ft mb l+ axs = map' (nameConcrete . qnameName . unArg) (conFields c) `withArgsFrom` qs+ cpi = ConPatternInfo (PatternInfo PatORec asB) r ft mb l prio ps <- insertMissingFieldsFail d (const $ A.WildP empty) fs axs ConP c cpi <$> transfers ps qs - ((asB , p) , ConP c (ConPatternInfo i r ft mb l) qs) -> do- let cpi = ConPatternInfo (PatternInfo (patOrig p) asB) r ft mb l+ ((asB , p) , ConP c (ConPatternInfo i r ft mb l prio) qs) -> do+ let cpi = ConPatternInfo (PatternInfo (patOrig p) asB) r ft mb l prio return $ ConP c cpi qs - ((asB , p) , VarP _ x) -> return $ VarP (PatternInfo (patOrig p) asB) x+ ((asB , p) , VarP _ x) -> return $! VarP (PatternInfo (patOrig p) asB) x - ((asB , p) , DotP _ u) -> return $ DotP (PatternInfo (patOrig p) asB) u+ ((asB , p) , DotP _ u) -> return $! DotP (PatternInfo (patOrig p) asB) u - ((asB , p) , LitP _ l) -> return $ LitP (PatternInfo (patOrig p) asB) l+ ((asB , p) , LitP (LitPatternInfo _ prio) l) ->+ return $! LitP (LitPatternInfo (PatternInfo (patOrig p) asB) prio) l _ -> return q @@ -526,7 +545,7 @@ A.VarP x -> do let y = A.unBind x reportSLn "tc.lhs.linear" 60 $- "pattern variable " ++ prettyShow (A.nameConcrete y) ++ " with id " ++ show (A.nameId y)+ "pattern variable " ++! prettyShow (A.nameConcrete y) ++! " with id " ++! show (A.nameId y) case Map.lookup x vars of Just (v , b) -> do traceCall (CheckPatternLinearityType $ A.nameConcrete y) $@@ -537,7 +556,7 @@ Nothing -> (eq:) <$> do check (Map.insert x (u,unDom a) vars) eqs A.AsP _ x p ->- check vars $ [ProblemEq (A.VarP x) u a, ProblemEq p u a] ++ eqs+ check vars $ [ProblemEq (A.VarP x) u a, ProblemEq p u a] ++! eqs A.WildP{} -> continue A.DotP{} -> continue A.AbsurdP{} -> continue@@ -555,7 +574,7 @@ -- | Construct the context for a left hand side, making up out-of-scope names -- for unnamed variables. computeLHSContext :: [Maybe A.Name] -> Telescope -> TCM Context-computeLHSContext = go [] []+computeLHSContext = go CxEmpty [] where go cxt _ [] tel@ExtendTel{} = do reportSDoc "impossible" 10 $@@ -565,8 +584,7 @@ go cxt _ [] EmptyTel = return cxt go cxt taken (x : xs) tel0@(ExtendTel a tel) = do name <- maybe (dummyName taken $ absName tel) return x- let e = CtxVar name a- go (e : cxt) (name : taken) xs (absBody tel)+ go (CxExtendVar name a cxt) (name : taken) xs (absBody tel) dummyName taken s = if isUnderscore s then freshNoName_@@ -580,7 +598,7 @@ sep [ ":" <+> prettyTCM a , "=" <+> prettyTCM v ]- addLetBinding' Inserted x v a $ bindAsPatterns asb ret+ addLetBinding' NoAxiom Inserted x v a $ bindAsPatterns asb ret -- | Since with-abstraction can change the type of a variable, we have to -- recheck the stripped with patterns when checking a with function.@@ -598,6 +616,9 @@ , lhsVarTele :: Telescope -- ^ Δ : The types of the pattern variables, in internal dependency order. -- Corresponds to 'clauseTel'.+ -- Like the other components (e.g. `lhsBodyType`), this telescope lives+ -- in the ambient context.+ -- To print it, we need /not/ drop Δ from the ambient context. , lhsPatterns :: [NamedArg DeBruijnPattern] -- ^ The patterns in internal syntax. , lhsHasAbsurd :: Bool@@ -631,6 +652,55 @@ <*> pure psplit <*> pure ixsplit +-- | Compute substitution from the out patterns @ps@+--+--- We have two slightly different cases here: normal function and+-- with-function. In both cases the goal is to build a substitution+-- from the context Γ of the previous checkpoint to the current lhs+-- context Δ:+--+-- Δ ⊢ paramSub : Γ+--+-- * Normal function, f+--+-- Γ = cxt = module parameter telescope of f+-- Ψ = non-parameter arguments of f (we have f : Γ Ψ → A)+-- Δ ⊢ patSub : Γ Ψ+-- Γ Ψ ⊢ weakSub : Γ+-- paramSub = patSub ∘ weakSub+--+-- * With-function+--+-- Γ = lhs context of the parent clause (cxt = [])+-- Ψ = argument telescope of with-function+-- Θ = inserted implicit patterns not in Ψ (#2827)+-- (this happens if the goal computes to an implicit+-- function type after some matching in the with-clause)+--+-- Ψ ⊢ withSub : Γ+-- Δ ⊢ patSub : Ψ Θ+-- Ψ Θ ⊢ weakSub : Ψ+-- paramSub = patSub ∘ weakSub ∘ withSub+--+-- To compute Θ we can look at the arity of the with-function+-- and compare it to numPats. This works since the with-function+-- type is fully reduced.+buildLHSSubstitutions :: Context -> NAPs -> IsWithFunction (Arity, Substitution)+ -> (Substitution, Substitution)+buildLHSSubstitutions cxt ps isWithFun = do+ let notProjPats = takeWhile (isNothing . isProjP) ps+ numPats = length notProjPats+ patSub = map' (patternToTerm . namedArg) (reverse notProjPats) ++#+ EmptyS impossible+ (weakSub, withSub) = case isWithFun of+ NoWithFunction ->+ (wkS (numPats - length cxt) idS, idS)+ WithFunction (arity, withSub) ->+ -- if numPats < arity, Θ is empty+ (wkS (max 0 $ numPats - arity) idS, withSub)+ paramSub = patSub `composeS` weakSub `composeS` withSub+ (patSub, paramSub)+ -- | Check a LHS. Main function. -- -- @checkLeftHandSide a ps a ret@ checks that user patterns @ps@ eliminate@@ -642,19 +712,21 @@ -- ^ Trace, e.g. 'CheckLHS' or 'CheckPattern'. -> Range -- ^ 'Range' of the entire left hand side, for error reporting.- -> Maybe QName- -- ^ The name of the definition we are checking.+ -> LetOrClause+ -- ^ Are we checking a let-pattern or a function clause? -> [NamedArg A.Pattern] -- ^ The patterns. -> Type -- ^ The expected type @a = Γ → b@.- -> Maybe Substitution+ -> IsWithFunction Substitution -- ^ Module parameter substitution from with-abstraction. -> [ProblemEq] -- ^ Patterns that have been stripped away by with-desugaring. -- ^ These should not contain any proper matches. -> (LHSResult -> TCM a)- -- ^ Continuation.+ -- ^ Continuation, called in the context constructed from+ -- the 'lhsVarTele' via 'computeLHSContext'.+ -- All components of 'LHSResult' live in this context, including 'lhsVarTele'. -> TCM a checkLeftHandSide call lhsRng f ps a withSub' strippedPats = Bench.billToCPS [Bench.Typing, Bench.CheckLHS] $@@ -663,18 +735,22 @@ -- To allow module parameters to be refined by matching, we're adding the -- context arguments as wildcard patterns and extending the type with the -- context telescope.- cxt <- map (setOrigin Inserted) <$> getContext+ --+ -- To pick up instances from {{}}-fields in a record module, we have+ -- to preserve which variable is the 'self' variable of that record.+ cxt <- fmap (mapOrigin \case{ RecordSelf -> RecordSelf ; _ -> Inserted }) <$>+ getContext let tel = contextToTel cxt cps = [ argFromDom dom $> unnamed (A.VarP $ A.mkBindName $ unDom dom) | (_,dom) <- contextVars cxt ]- eqs0 = zipWith3 ProblemEq (map namedArg cps) (map var $ downFrom $ size tel) (flattenTel tel)+ 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 ixsplit) = do+ finalChecks (LHSState delta qs0 (Problem eqs rps _) b psplit ixsplit _prio) = do reportSDoc "tc.lhs.top" 20 $ vcat [ "lhs: final checks with remaining equations"- , nest 4 $ if null eqs then "(none)" else addContext delta $ vcat $ map prettyTCM eqs+ , nest 4 $ if null eqs then "(none)" else addContext delta $ vcat $ map' prettyTCM eqs , nest 2 $ "qs0 =" <+> addContext delta (prettyTCMPatternList qs0) ] @@ -683,9 +759,9 @@ addContext delta $ do mapM_ noShadowingOfConstructors eqs - -- When working --without-K or --cubical-compatible, we have+ -- 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+ -- 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.@@ -707,49 +783,8 @@ , nest 2 $ "withSub' =" <+> prettyTCM withSub' ] - -- Compute substitution from the out patterns @qs0@- let notProj ProjP{} = False- notProj _ = True- numPats = length $ takeWhile (notProj . namedArg) qs0-- -- We have two slightly different cases here: normal function and- -- with-function. In both cases the goal is to build a substitution- -- from the context Γ of the previous checkpoint to the current lhs- -- context Δ:- --- -- Δ ⊢ paramSub : Γ- --- -- * Normal function, f- --- -- Γ = cxt = module parameter telescope of f- -- Ψ = non-parameter arguments of f (we have f : Γ Ψ → A)- -- Δ ⊢ patSub : Γ Ψ- -- Γ Ψ ⊢ weakSub : Γ- -- paramSub = patSub ∘ weakSub- --- -- * With-function- --- -- Γ = lhs context of the parent clause (cxt = [])- -- Ψ = argument telescope of with-function- -- Θ = inserted implicit patterns not in Ψ (#2827)- -- (this happens if the goal computes to an implicit- -- function type after some matching in the with-clause)- --- -- Ψ ⊢ withSub : Γ- -- Δ ⊢ patSub : Ψ Θ- -- Ψ Θ ⊢ weakSub : Ψ- -- paramSub = patSub ∘ weakSub ∘ withSub- --- -- To compute Θ we can look at the arity of the with-function- -- and compare it to numPats. This works since the with-function- -- type is fully reduced.-- weakSub :: Substitution- weakSub | isJust withSub' = wkS (max 0 $ numPats - arity_a) idS -- if numPats < arity, Θ is empty- | otherwise = wkS (numPats - length cxt) idS- withSub = fromMaybe idS withSub'- patSub = map (patternToTerm . namedArg) (reverse $ take numPats qs0) ++# EmptyS impossible- paramSub = patSub `composeS` weakSub `composeS` withSub+ let (patSub, paramSub) = buildLHSSubstitutions cxt qs0 $+ fmap (arity_a,) withSub' eqs <- addContext delta $ checkPatternLinearity eqs @@ -763,13 +798,13 @@ -- Get the user-written names for the pattern variables let (vars, asb1) = getUserVariableNames delta patVars- asb = asb0 ++ asb1+ asb = asb0 ++! asb1 -- Rename internal patterns with these names let makeVar = maybe deBruijnVar $ deBruijnNamedVar . nameToArgName- ren = parallelS $ zipWith makeVar (reverse vars) [0..]+ ren = parallelS $ zipWith' makeVar (reverse vars) [0..] - qs <- transferOrigins (cps ++ ps) $ applySubst ren qs0+ qs <- transferOrigins (cps ++! ps) $ applySubst ren qs0 let hasAbsurd = not . null $ absurds @@ -780,10 +815,10 @@ vcat [ "checked lhs:" , nest 2 $ vcat [ "delta = " <+> prettyTCM delta- , "dots = " <+> addContext delta (brackets $ fsep $ punctuate comma $ map prettyTCM dots)- , "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)+ , "dots = " <+> addContext delta (brackets $ fsep $ punctuate comma $ map' prettyTCM dots)+ , "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) ] ]@@ -792,8 +827,6 @@ [ "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 reportSDoc "tc.lhs.top" 20 $ nest 2 $ "patSub = " <+> pretty patSub reportSDoc "tc.lhs.top" 20 $ nest 2 $ "paramSub = " <+> pretty paramSub @@ -820,13 +853,15 @@ -- after we have introduced variables, we can add the patterns stripped by -- with-desugaring to the state.- let withSub = fromMaybe __IMPOSSIBLE__ withSub'+ let withSub = case withSub' of+ NoWithFunction -> __IMPOSSIBLE__+ WithFunction sub -> sub withEqs <- updateProblemEqs $ applySubst withSub strippedPats -- Jesper, 2017-05-13: re-check the stripped patterns here! inTopContext $ addContext (st0 ^. lhsTel) $ forM_ withEqs recheckStrippedWithPattern - let st = over (lhsProblem . problemEqs) (++ withEqs) st0+ let st = over (lhsProblem . problemEqs) (++! withEqs) st0 -- doing the splits: let initLHSContext = LHSContext { lhsRange = lhsRng, lhsContextSize = size cxt }@@ -834,7 +869,7 @@ return result -- | Check that this split will generate a modality-correct internal--- clause when --cubical-compatible is used. This means that the type of+-- 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@@ -879,7 +914,7 @@ , "after: " <+> inTopContext (addContext gamma0 (prettyTCM delta)) ] forced <- name ix- forM_ (zip [ix - 1, ix - 2 ..] (telToList delta)) $ \(arg, d) -> do+ 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.Δ@@ -959,24 +994,24 @@ A.PatternSynP{} -> __IMPOSSIBLE__ A.WithP{} -> __IMPOSSIBLE__ +type CheckLHSM = ReaderT LHSContext (WriterT Blocked_ TCM) -- | The loop (tail-recursive): split at a variable in the problem until problem is solved-checkLHS :: forall tcm a. (MonadTCM tcm, PureTCM tcm, MonadWriter Blocked_ tcm, MonadError TCErr tcm, MonadTrace tcm, MonadReader LHSContext tcm)- => Maybe QName -- ^ The name of the definition we are checking.+checkLHS ::+ forall a.+ LetOrClause -- ^ Are we checking a let-pattern or a function clause? -> LHSState a -- ^ The current state.- -> tcm a+ -> CheckLHSM a checkLHS mf = updateModality checkLHS_ where++ {-# INLINE updateModality #-} -- 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 _ _prio) -> do let m = getModality target- applyModalityToContext m $ do- cont $ over (lhsTel . listTel)- (map $ inverseApplyModalityButNotQuantity m) st- -- Andreas, 2018-10-23, issue #3309- -- the modalities in the clause telescope also need updating.+ applyModalityToContext m $ cont st - checkLHS_ st@(LHSState tel ip problem target psplit ixsplit) = do+ checkLHS_ st@(LHSState tel ip problem target psplit ixsplit prio) = 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)@@ -1004,21 +1039,21 @@ where trySplit :: ProblemEq- -> tcm (Either [TCErr] (LHSState a))- -> tcm (Either [TCErr] (LHSState a))+ -> CheckLHSM (Either [TCErr] (LHSState a))+ -> CheckLHSM (Either [TCErr] (LHSState a)) trySplit eq tryNextSplit = runExceptT (splitArg eq) >>= \case Right st' -> return $ Right st'- Left err -> left (err:) <$> tryNextSplit+ Left err -> first (err:) <$> tryNextSplit -- If there are any remaining user patterns, try to split on them- trySplitRest :: tcm (Either [TCErr] (LHSState a))+ trySplitRest :: CheckLHSM (Either [TCErr] (LHSState a)) trySplitRest = case problem ^. problemRestPats of [] -> return $ Left []- (p:_) -> left singleton <$> runExceptT (splitRest p)+ (p:_) -> first singleton <$> runExceptT (splitRest p) - splitArg :: ProblemEq -> ExceptT TCErr tcm (LHSState a)+ splitArg :: ProblemEq -> ExceptT TCErr CheckLHSM (LHSState a) -- Split on constructor/literal pattern- splitArg (ProblemEq p v Dom{unDom = a}) = traceCall (CheckPattern p tel a) $ do+ splitArg (ProblemEq p v (unDom -> a)) = traceCall (CheckPattern p tel a) $ do reportSDoc "tc.lhs.split" 30 $ sep [ "split looking at pattern"@@ -1033,11 +1068,20 @@ (delta1, tel'@(ExtendTel dom adelta2)) = splitTelescopeAt pos tel -- TODO:: tel' defined but not used p <- expandLitPattern p++ -- Andreas, 2026-01-20, issue #8327+ -- Exit early when we are checking a let-pattern and encounter a non-record pattern.+ -- This is mainly to serve the correct error message to the user.+ let notRecPat cont = case mf of+ -- We are checking a let-pattern which only admits record constructors+ LetLHS -> typeError ShouldBeRecordPattern+ -- We are checking a clause which allows any kind of pattern.+ ClauseLHS{} -> cont let splitOnPat = \case- (A.LitP _ l) -> splitLit delta1 dom adelta2 l+ (A.LitP _ l) -> notRecPat $ splitLit delta1 dom adelta2 l p@A.RecP{} -> splitCon delta1 dom adelta2 p Nothing p@(A.ConP _ c ps) -> splitCon delta1 dom adelta2 p $ Just c- p@(A.EqualP _ ts) -> splitPartial delta1 dom adelta2 ts+ p@(A.EqualP _ ts) -> notRecPat $ splitPartial delta1 dom adelta2 ts A.AsP _ _ p -> splitOnPat p A.VarP{} -> __IMPOSSIBLE__@@ -1051,7 +1095,7 @@ splitOnPat p - splitRest :: NamedArg A.Pattern -> ExceptT TCErr tcm (LHSState a)+ splitRest :: NamedArg A.Pattern -> ExceptT TCErr CheckLHSM (LHSState a) splitRest p = setCurrentRange p $ do reportSDoc "tc.lhs.split" 20 $ sep [ "splitting problem rest"@@ -1059,7 +1103,7 @@ , nest 2 $ "eliminates type =" <+> prettyTCM target ] reportSDoc "tc.lhs.split" 80 $ sep- [ nest 2 $ text $ "projection pattern (raw) = " ++ show p+ [ nest 2 $ text $ "projection pattern (raw) = " ++! show p ] -- @p@ should be a projection pattern projection from @target@@@ -1078,17 +1122,23 @@ -- Compute the new rest type by applying the projection type to 'self'. -- Note: we cannot be in a let binding.- let f = fromMaybe __IMPOSSIBLE__ mf+ let f = case mf of+ LetLHS -> __IMPOSSIBLE__+ ClauseLHS x -> x let self = Def f $ patternsToElims ip target' <- traverse (`piApplyM` self) projType -- Compute the new state let projP = applyWhen (orig == ProjPostfix) (setHiding NotHidden) $ Arg ai $ Named Nothing (ProjP orig projName)- ip' = ip ++ [projP]+ ip' = ip ++! [projP] -- drop the projection pattern (already splitted) problem' = over problemRestPats (drop 1) problem- liftTCM $ updateLHSState (LHSState tel ip' problem' target' psplit ixsplit)+ -- Update the modalities of telescope variables,+ -- resurrecting irrelevant variables in case of an irrelevant copattern+ m = getModality target'+ tel' = over listTel (map' $ inverseApplyModalityButNotQuantity m) tel+ liftTCM $ updateLHSState (LHSState tel' ip' problem' target' psplit ixsplit prio) -- Split a Partial.@@ -1150,7 +1200,7 @@ -- The types of arguments after the one we split on. -> List1 (A.Expr, A.Expr) -- [(φ₁ = b1),..,(φn = bn)]- -> ExceptT TCErr tcm (LHSState a)+ -> ExceptT TCErr CheckLHSM (LHSState a) splitPartial delta1 dom adelta2 ts = do @@ -1161,7 +1211,7 @@ names <- liftTCM $ addContext tel $ do LeftoverPatterns{patternVariables = vars} <- getLeftoverPatterns $ problem ^. problemEqs- return $ take (size delta1) $ fst $ getUserVariableNames tel vars+ return $! take' (size delta1) $ fst $ getUserVariableNames tel vars -- Problem: The context does not match the checkpoints in checkLHS, -- however we still need a proper checkpoint substitution@@ -1241,23 +1291,24 @@ -- 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]) ixsplit)+ liftTCM $ updateLHSState (LHSState delta' ip' problem' target' (psplit ++! [Just o_n]) ixsplit prio) splitLit :: Telescope -- The types of arguments before the one we split on -> Dom Type -- The type of the literal we split on -> Abs Telescope -- The types of arguments after the one we split on -> Literal -- The literal written by the user- -> ExceptT TCErr tcm (LHSState a)- splitLit delta1 dom@Dom{domInfo = info, unDom = a} adelta2 lit = do+ -> ExceptT TCErr CheckLHSM (LHSState a)+ splitLit delta1 dom@(unDom -> a) adelta2 lit = do+ let info = dom ^. dInfo let delta2 = absApp adelta2 (Lit lit) delta' = abstract delta1 delta2 rho = singletonS (size delta2) (litP lit) -- Andreas, 2015-06-13 Literals are closed, so no need to raise them! -- rho = liftS (size delta2) $ singletonS 0 (Lit lit) -- rho = [ var i | i <- [0..size delta2 - 1] ]- -- ++ [ raise (size delta2) $ Lit lit ]- -- ++ [ var i | i <- [size delta2 ..] ]+ -- ++! [ raise (size delta2) $ Lit lit ]+ -- ++! [ var i | i <- [size delta2 ..] ] eqs' = applyPatSubst rho $ problem ^. problemEqs ip' = applySubst rho ip target' = applyPatSubst rho target@@ -1283,7 +1334,7 @@ -- Compute the new state let problem' = set problemEqs eqs' problem- liftTCM $ updateLHSState (LHSState delta' ip' problem' target' psplit ixsplit)+ liftTCM $ updateLHSState (LHSState delta' ip' problem' target' psplit ixsplit prio) splitCon :: Telescope -- The types of arguments before the one we split on@@ -1292,8 +1343,9 @@ -> A.Pattern -- The pattern written by the user -> Maybe AmbiguousQName -- @Just c@ for a (possibly ambiguous) constructor @c@, or -- @Nothing@ for a record pattern- -> ExceptT TCErr tcm (LHSState a)- splitCon delta1 dom@Dom{domInfo = info, unDom = a} adelta2 focusPat ambC = do+ -> ExceptT TCErr CheckLHSM (LHSState a)+ splitCon delta1 dom@(unDom -> a) adelta2 focusPat ambC = do+ let info = dom ^. dInfo let delta2 = absBody adelta2 reportSDoc "tc.lhs.split" 10 $ vcat@@ -1314,7 +1366,7 @@ ] -- We cannot split on (shape-)irrelevant arguments.- reportSLn "tc.lhs.split" 30 $ "split ConP: relevance is " ++ show (getRelevance info)+ reportSLn "tc.lhs.split" 30 $ "split ConP: relevance is " ++! show (getRelevance info) unless (usableRelevance info) $ addContext delta1 $ softTypeError $ SplitOnIrrelevant dom @@ -1330,7 +1382,7 @@ addContext delta1 $ softTypeError $ SplitOnUnusablePolarity dom -- Should we attempt to compute a left inverse for this clause? When- -- --cubical-compatible --flat-split is given, we don't generate a+ -- --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.@@ -1344,7 +1396,7 @@ IsData{} -> False IsRecord{} -> True - checkMatchingAllowed d dr -- No splitting on coinductive constructors.+ checkMatchingAllowed mf d dr -- No splitting on e.g. coinductive constructors. -- Issue #7503: use principal sort for checking if split is ok let a' = set lensSort s a@@ -1369,7 +1421,7 @@ -- The type of the constructor will end in an application of the datatype (TelV gamma (El _ ctarget), boundary) <- liftTCM $ telViewPathBoundary b let Def d' es' = ctarget- cixs = drop (size pars) $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es'+ cixs = drop (size pars) $ mustAllApplyElims es' -- Δ₁Γ ⊢ boundary reportSDoc "tc.lhs.split.con" 50 $ text " boundary = " <+> prettyTCM boundary@@ -1383,7 +1435,7 @@ return $ useNamesFromPattern ps gamma A.RecP _ _ fs -> do RecordDefn def <- theDef <$> getConstInfo d- let axs = map argFromDom $ recordFieldNames def+ let axs = map' argFromDom $ recordFieldNames def ps <- insertMissingFieldsFail d (const $ A.WildP empty) fs axs ps <- insertImplicitPatterns ExpandLast ps gamma return $ useNamesFromPattern ps gamma@@ -1391,7 +1443,11 @@ -- Andreas 2010-09-07 propagate relevance info to new vars -- Andreas 2018-10-17 propagate modality- let updMod = composeModality (getModality info)+ -- Issue #8888: this only concerns the new variables in the context.+ -- The constructor pattern keeps the modalities of the constructor's+ -- type, see @gamma0@ in the construction of @crho@ below.+ let gamma0 = gamma+ updMod = composeModality (getModality info) gamma <- return $ mapModality updMod <$> gamma -- Get the type of the datatype.@@ -1402,12 +1458,12 @@ sep [ "preparing to unify" , nest 2 $ vcat [ "c =" <+> prettyTCM c <+> ":" <+> prettyTCM b- , "d =" <+> prettyTCM (Def d (map Apply pars)) <+> ":" <+> prettyTCM da+ , "d =" <+> prettyTCM (Def d (map' Apply pars)) <+> ":" <+> prettyTCM da , "isRec =" <+> (text . show) isRec , "gamma =" <+> prettyTCM gamma- , "pars =" <+> brackets (fsep $ punctuate comma $ map prettyTCM pars)- , "ixs =" <+> brackets (fsep $ punctuate comma $ map prettyTCM ixs)- , "cixs =" <+> addContext gamma (brackets (fsep $ punctuate comma $ map prettyTCM cixs))+ , "pars =" <+> brackets (fsep $ punctuate comma $ map' prettyTCM pars)+ , "ixs =" <+> brackets (fsep $ punctuate comma $ map' prettyTCM ixs)+ , "cixs =" <+> addContext gamma (brackets (fsep $ punctuate comma $ map' prettyTCM cixs)) ] ] -- We ignore forcing for make-case@@ -1419,7 +1475,7 @@ ixs' = raise (size gamma) ixs -- Variables in Δ₁ are not forced, since the unifier takes care to not introduce forced -- variables.- forced = replicate (size delta1) NotForced ++ cforced+ forced = replicate (size delta1) NotForced ++! cforced -- All variables are flexible. let flex = allFlexVars forced $ delta1Gamma@@ -1456,7 +1512,7 @@ da' <- addContext delta1Gamma $ do let updCoh = composeCohesion (getCohesion info) TelV tel dt <- telView da'- return $ abstract (mapCohesion updCoh <$> tel) a+ return $ abstract (mapCohesion updCoh <$> tel) dt let stuck b errs = softTypeError $ SplitError $ UnificationStuck b (conName c) (delta1 `abstract` gamma) cixs ixs' errs@@ -1498,10 +1554,12 @@ , conPRecord = isRec , conPFallThrough = False , conPType = Just $ Arg info a'- , conPLazy = False } -- Don't mark eta-record matches as lazy (#4254)+ , conPLazy = False -- Don't mark eta-record matches as lazy (#4254)+ , conPPrio = prio+ } -- compute final context and substitution- let crho = ConP c cpi $ applySubst rho0 $ (telePatterns gamma boundary)+ let crho = ConP c cpi $ applySubst rho0 $ (telePatterns gamma0 boundary) rho3 = consS crho rho1 delta2' = applyPatSubst rho3 delta2 delta' = delta1' `abstract` delta2'@@ -1560,7 +1618,7 @@ -- if rest type reduces, -- extend the split problem by previously not considered patterns- st' <- liftTCM $ updateLHSState $ LHSState delta' ip' problem' target'' psplit (ixsplit || not (null ixs))+ st' <- liftTCM $ updateLHSState $ LHSState delta' ip' problem' target'' psplit (ixsplit || not (null ixs)) prio reportSDoc "tc.lhs.top" 12 $ sep [ "new problem from rest"@@ -1576,15 +1634,21 @@ -- | Ensures that we are not performing pattern matching on coinductive constructors. checkMatchingAllowed :: (MonadTCError m)- => QName -- ^ The name of the data or record type the constructor belongs to.+ => LetOrClause -- ^ Are we checking a clause lhs or a let-pattern?+ -> QName -- ^ The name of the data or record type the constructor belongs to. -> DataOrRecord -- ^ Information about data or (co)inductive (no-)eta-equality record. -> m ()-checkMatchingAllowed d = \case+checkMatchingAllowed mf d = \case IsRecord InductionAndEta { recordInduction=ind, recordEtaEquality=eta } | Just CoInductive <- ind -> typeError SplitOnCoinductive | not $ patternMatchingAllowed eta -> typeError $ SplitOnNonEtaRecord d | otherwise -> return ()- IsData -> return ()+ IsData -> case mf of+ -- Andreas, 2026-01-20, issue #8327+ -- Exit early when we are checking a let-pattern and encounter a non-record pattern.+ -- This is mainly to serve the correct error message to the user.+ LetLHS -> typeError ShouldBeRecordPattern+ ClauseLHS{} -> return () -- | When working with a monad @m@ implementing @MonadTCM@ and @MonadError TCErr@, -- @suspendErrors f@ performs the TCM action @f@ but catches any errors and throws@@ -1628,11 +1692,11 @@ whenM (isInterval a) $ hardTypeError =<< notData - let (pars, ixs) = splitAt np $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ let (pars, ixs) = splitAt' np $ mustAllApplyElims es return (IsData, d, s, pars, ixs) Record{ recInduction, recEtaEquality' } -> do- let pars = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ let pars = mustAllApplyElims es s <- shouldBeSort =<< defType def `piApplyM` pars return (IsRecord InductionAndEta {recordInduction=recInduction, recordEtaEquality=recEtaEquality' }, d, s, pars, []) @@ -1672,7 +1736,7 @@ Con{} -> __IMPOSSIBLE__ Level{} -> __IMPOSSIBLE__ DontCare{} -> __IMPOSSIBLE__- Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s+ Dummy s _ -> __IMPOSSIBLE_VERBOSE__ (show s) -- neutral type: fail softly StuckOn{} -> \ _a -> softTypeError =<< notData@@ -1715,15 +1779,15 @@ -> TCM (QName, Bool, QName, Arg Type, ArgInfo) -- ^ @Bool@ signifies whether copattern matching is allowed at -- the inferred record type.-disambiguateProjection h ambD@(AmbQ ds) b = do+disambiguateProjection h ambD b = do -- If the target is not a record type, that's an error. -- It could be a meta, but since we cannot postpone lhs checking, we crash here.- caseMaybeM (liftTCM $ isRecordType $ unArg b) notRecord+ caseEitherM (liftTCM $ tryRecordType $ unArg b) notRecord \ (r, vs, RecordData{ _recFields = fs, _recInduction = ind, _recEtaEquality' = eta }) -> do reportSDoc "tc.lhs.split" 20 $ sep [ "we are of record type r = " <> pure (P.pretty r) , "applied to parameters vs = " <> prettyTCM vs- , "and have fields fs = " <> pure (P.pretty $ map argFromDom fs)+ , "and have fields fs = " <> pure (P.pretty $ map' argFromDom fs) ] let comatching = ind == Just CoInductive || copatternMatchingAllowed eta@@ -1738,8 +1802,9 @@ ([] , [] ) -> __IMPOSSIBLE__ (_ , [_]) -> __IMPOSSIBLE__ (_ , (d,_) : (d1,_) : disambs) ->- typeError $ AmbiguousProjection d $ d1 :| map fst disambs+ typeError $ AmbiguousProjection d $ d1 :| map' fst disambs where+ ds = getAmbiguous ambD tryDisambiguate constraintsOk fs r vs comatching failure = do -- Note that tryProj wraps TCM in an ExceptT, collecting errors -- instead of throwing them to the user immediately.@@ -1756,12 +1821,12 @@ return (d, comatching, r, a, ai) other -> failure other - notRecord = wrongProj $ List1.head ds+ notRecord blk = wrongProj (Just (getBlocker blk)) $ List1.head ds - wrongProj :: (MonadTCM m, MonadError TCErr m, ReadTCState m) => QName -> m a- wrongProj d = softTypeError =<< do- liftTCM $ if isAmbiguous ambD then CannotEliminateWithProjection b True <$> dropTopLevelModule d- else pure $ CannotEliminateWithProjection b False d+ wrongProj :: (MonadTCM m, MonadError TCErr m, ReadTCState m) => Maybe Blocker -> QName -> m a+ wrongProj blk d = softTypeError =<< do+ liftTCM $ if isAmbiguous ambD then CannotEliminateWithProjection blk b True <$> dropTopLevelModule d+ else pure $ CannotEliminateWithProjection blk b False d tryProj :: Bool -- Are we allowed to create new constraints?@@ -1773,29 +1838,29 @@ -- TCState contains possibly new constraints/meta solutions. tryProj constraintsOk fs r vs d0 = isProjection d0 >>= \case -- Not a projection- Nothing -> wrongProj d0+ Nothing -> wrongProj Nothing d0 Just proj -> do let d = projOrig proj -- Andreas, 2015-05-06 issue 1413 projProper=Nothing is not impossible- qr <- maybe (wrongProj d) return $ projProper proj+ qr <- maybe (wrongProj Nothing d) return $ projProper proj -- If projIndex==0, then the projection is already applied -- to the record value (like in @open R r@), and then it -- is no longer a projection but a record field.- when (null $ projLams proj) $ wrongProj d+ when (null $ projLams proj) $ wrongProj Nothing d reportSLn "tc.lhs.split" 90 "we are a projection pattern" -- If the target is not a record type, that's an error. -- It could be a meta, but since we cannot postpone lhs checking, we crash here. reportSDoc "tc.lhs.split" 20 $ sep- [ text $ "proj d0 = " ++ prettyShow d0- , text $ "original proj d = " ++ prettyShow d+ [ text $ "proj d0 = " ++! prettyShow d0+ , text $ "original proj d = " ++! prettyShow d ] -- Get the field decoration. -- If the projection pattern name @d@ is not a field name, -- we have to try the next projection name. -- If this was not an ambiguous projection, that's an error.- argd <- maybe (wrongProj d) return $ List.find ((d ==) . unDom) fs+ argd <- maybe (wrongProj Nothing d) return $ List.find ((d ==) . unDom) fs -- Issue4998: This used to use the hiding from the principal argument, but this is not -- relevant for the ArgInfo of the clause rhs. We return that separately so we can set the@@ -1803,8 +1868,8 @@ let ai = getArgInfo argd reportSDoc "tc.lhs.split" 20 $ vcat- [ text $ "original proj relevance = " ++ show (getRelevance argd)- , text $ "original proj quantity = " ++ show (getQuantity argd)+ [ text $ "original proj relevance = " ++! show (getRelevance argd)+ , text $ "original proj quantity = " ++! show (getQuantity argd) ] -- Andreas, 2016-12-31, issue #2374: -- We can also disambiguate by hiding info.@@ -1834,17 +1899,31 @@ -> QName -- ^ Name of the datatype. -> Args -- ^ Parameters of the datatype -> TCM (ConHead, Type)-disambiguateConstructor ambC@(AmbQ cs) d pars = do- d <- canonicalName d- cons <- theDef <$> getConstInfo d >>= \case- def@Datatype{} -> return $ dataCons def- def@Record{} -> return $ [conName $ recConHead def]- _ -> __IMPOSSIBLE__+disambiguateConstructor ambC d0 pars = do+ reduce (Def d0 $ map Apply pars) >>= \case+ Def d es | Just vs <- allApplyElims es -> do+ def <- theDef <$> getConstInfo d+ uncurry (disambiguateConstructor' ambC d vs) case def of+ Datatype{} -> (IsData, dataCons def)+ Record {} -> (IsRecord_, [conName $ recConHead def])+ _ -> __IMPOSSIBLE__+ _ -> __IMPOSSIBLE__ +-- | Disambiguate a constructor based on the data type it is supposed to be+-- constructing. Returns the unambiguous constructor name and its type.+-- Precondition: type should be a data/record type.+disambiguateConstructor'+ :: AmbiguousQName -- ^ The name of the constructor to be disambiguated.+ -> QName -- ^ Name of the datatype.+ -> Args -- ^ Parameters of the datatype+ -> DataOrRecord_ -- ^ Whether it is really a datatype or rather a record type.+ -> [QName] -- ^ The constructor(s) of the data/record type.+ -> TCM (ConHead, Type)+disambiguateConstructor' ambC d pars dataOrRec cons = do -- First, try do disambiguate with nonConstraining, -- if that fails, try again allowing constraint/solution generation.- tryDisambiguate False d cons $ \ _ ->- tryDisambiguate True d cons $ \case+ tryDisambiguate False \ _ ->+ tryDisambiguate True \case ([] , [] ) -> __IMPOSSIBLE__ (err:_, [] ) -> throwError err -- If all disambiguations point to the same original constructor@@ -1855,27 +1934,27 @@ AmbiguousConstructor c $ fmap (conName . snd3) $ List2.concat21 $ List2 d0 d1 ds where+ cs = getAmbiguous ambC tryDisambiguate- :: Bool -- May we constrain/solve metas to arrive at unique disambiguation?- -> QName -- Data/record type.- -> [QName] -- Its constructor(s).+ :: Bool+ -- May we constrain/solve metas to arrive at unique disambiguation? -> ( ( [TCErr] , [List1 (QName, ConHead, (Type, Maybe TCState))] )- -> TCM (ConHead, Type) ) -- Failure continuation, taking- -- possible disambiguations- -- grouped by the original- -- constructor name in 'ConHead'.- -> TCM (ConHead, Type) -- Unique disambiguation and its type.- tryDisambiguate constraintsOk d cons failure = do+ -> TCM (ConHead, Type) )+ -- Failure continuation, taking possible disambiguations+ -- grouped by the original constructor name in 'ConHead'.+ -> TCM (ConHead, Type)+ -- Unique disambiguation and its type.+ tryDisambiguate constraintsOk failure = do reportSDoc "tc.lhs.disamb" 30 $ sep $ List.concat $ [ [ "tryDisambiguate" ] , if constraintsOk then [ "(allowing new constraints)" ] else empty- , map (nest 2 . pretty) $ List1.toList cs+ , map' (nest 2 . pretty) $ List1.toList cs , [ "against" ]- , map (nest 2 . pretty) cons+ , map' (nest 2 . pretty) cons ]- disambiguations <- mapM (runExceptT . tryCon constraintsOk cons d pars) cs+ disambiguations <- mapM (runExceptT . tryCon constraintsOk) cs -- Q: can we be more lazy, like using the ListT monad? -- Andreas, 2020-06-17: Not really, since we need to make sure -- that only a single candidate remains, and if not,@@ -1883,7 +1962,7 @@ let (errs, fits0) = List1.partitionEithers disambiguations reportSDoc "tc.lhs.disamb" 40 $ vcat $ do let hideSt (c0,c,(a,mst)) = (c0, c, (a, ("(state change)" :: String) <$ mst))- "remaining candidates: " : map (nest 2 . prettyTCM . hideSt) fits0+ "remaining candidates: " : map' (nest 2 . prettyTCM . hideSt) fits0 dedupCons fits0 >>= \case -- Single candidate remains.@@ -1911,26 +1990,23 @@ abstractConstructor c = softTypeError $ AbstractConstructorNotInScope c - wrongDatatype c d = softTypeError $- ConstructorPatternInWrongDatatype c d+ wrongDatatype c = softTypeError $+ ConstructorPatternInWrongDatatype c d dataOrRec tryCon :: Bool -- Are we allowed to constrain metas?- -> [QName] -- Constructors of data type under consideration.- -> QName -- Name of data/record type we are eliminating.- -> Args -- Parameters of data/record type we are eliminating. -> QName -- Candidate constructor. -> ExceptT TCErr TCM (QName, ConHead, (Type, Maybe TCState)) -- If this candidate succeeds, return its disambiguation -- its type, and maybe the state obtained after checking it -- (which may contain new constraints/solutions).- tryCon constraintsOk cons d pars c = getConstInfo' c >>= \case- Left (SigUnknown err) -> __IMPOSSIBLE__+ tryCon constraintsOk c = getConstInfo' c >>= \case+ Left (SigUnknown err) -> __IMPOSSIBLE_VERBOSE__ err Left SigCubicalNotErasure -> __IMPOSSIBLE__ Left SigAbstract -> abstractConstructor c Right def -> do let con = conSrcCon (theDef def) `withRangeOf` c- unless (conName con `elem` cons) $ wrongDatatype c d+ unless (conName con `elem` cons) $ wrongDatatype c -- Andreas, 2013-03-22 fixing issue 279 -- To resolve ambiguous constructors, Agda always looks up@@ -2003,30 +2079,65 @@ checkParameters dc d pars -- | Check that given parameters match the parameters of the inferred--- constructor/projection.+-- constructor or projection. checkParameters :: MonadTCM tcm- => QName -- ^ The record/data type name of the chosen constructor/projection.- -> QName -- ^ The record/data type name as supplied by the type signature.+ => QName -- ^ The record or data type name of the chosen constructor or projection.+ -> QName -- ^ The record or data type name as supplied by the type signature. -> Args -- ^ The parameters. -> tcm () checkParameters dc d pars = liftTCM $ do- a <- reduce (Def dc [])- case a of- Def d0 es -> do -- compare parameters- let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es- reportSDoc "tc.lhs.split" 40 $ vcat $- [ "checkParameters"- , nest 2 $ "d =" <+> (text . prettyShow) d- , nest 2 $ "d0 (should be == d) =" <+> (text . prettyShow) d0- , nest 2 $ "dc =" <+> (text . prettyShow) dc- , nest 2 $ "vs =" <+> prettyTCM vs- , nest 2 $ "pars =" <+> prettyTCM pars- ]- -- when (d0 /= d) __IMPOSSIBLE__ -- d could have extra qualification- t <- typeOfConst d- compareArgs [] [] t (Def d []) vs (take (length vs) pars)- _ -> __IMPOSSIBLE__+ def <- getConstInfo dc+ -- Only a copy stemming from a module instantiation can have parameters+ -- that are already fixed; for anything else there is nothing to check.+ -- (This also avoids the context churn below in the common case.)+ when (defCopy def) $ do+ -- Andreas, 2026-09-25, issue #7664:+ -- Saturate @dc@ with fresh parameters before reducing.+ -- Reducing @Def dc []@ is not enough: a copy does unfold when underapplied+ -- (issue #8545), but reduction stops at the leading lambdas it produces,+ -- so a /chain/ of copies would not be unfolded all the way down to @d@.+ TelV tel _ <- telView $ defType def+ let n = size tel+ addContext tel $ do+ a <- reduce $ Def dc $ map Apply $ teleArgs tel+ case a of+ Def d0 es -> do+ let pars' = raise n pars+ vs0 = mustAllApplyElims es+ -- Andreas, 2026-09-25, issue #7664:+ -- A parameter of @d@ that still mentions one of the fresh+ -- variables is not fixed by the module instantiation: the caller+ -- may choose it freely, but consistently.+ -- To ensure consistency of the choices, we would need full-blown+ -- unification. We abstain from implementing this here.+ -- Rather, we simply overwrite the constructor parameters+ -- that still contain fresh variables with the respective+ -- data parameter so that the subsequent 'compareArgs'+ -- never fails at these positions.+ -- This means that 'checkParameters' still lets through+ -- some constructors with the wrong parameter instantiation.+ -- That we actually need to jump through hoops here lies in+ -- our handling of module applications that do not make+ -- proper copies of the module, but just fake them using 'defCopy'.+ vs | n == 0 = vs0 -- Nothing supplied by us, nothing to neutralize.+ | otherwise = zipWith (\ v p -> if anyFreeVar (< n) v then p else v)+ vs0 pars'+ reportSDoc "tc.lhs.split" 40 $ vcat $+ [ "checkParameters"+ , nest 2 $ "d =" <+> (text . prettyShow) d+ , nest 2 $ "d0 (should be == d) =" <+> (text . prettyShow) d0+ , nest 2 $ "dc =" <+> (text . prettyShow) dc+ , nest 2 $ "vs0 =" <+> prettyTCM vs0+ , nest 2 $ "vs =" <+> prettyTCM vs+ , nest 2 $ "pars =" <+> prettyTCM pars+ ]+ unless (d0 == d) __IMPOSSIBLE__+ -- @pars@ include the module parameters of @d@,+ -- so we need the uninstantiated type of @d@ here (not @typeOfConst d@).+ t <- defType <$> getConstInfo d+ compareArgs [] [] t (Def d []) vs (take' (length vs) pars')+ _ -> return () checkSortOfSplitVar :: (MonadTCM m, PureTCM m, MonadError TCErr m, LensSort a, PrettyTCM a, LensSort ty, PrettyTCM ty)@@ -2060,11 +2171,14 @@ checkFibrantSplit | IsRecord _ <- dr = return () | Just target <- mtarget = do- reportSDoc "tc.sort.check" 20 $ "target:" <+> prettyTCM target- checkIsFibrant target- forM_ (telToList tel) $ \ d -> do- let ty = snd $ unDom d- checkIsCoFibrant ty+ reportSDoc "tc.sort.check" 20 $ "target:" <+> prettyTCM target+ checkIsFibrant target+ let+ loop EmptyTel = pure ()+ loop (ExtendTel a tel) = do+ checkIsCoFibrant (unDom a)+ underAbstractionAbs a tel loop+ loop tel | otherwise = do reportSDoc "tc.sort.check" 20 $ "no target" splitOnFibrantError Nothing
src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs view
@@ -99,8 +99,8 @@ insImp p EmptyTel = return [] insImp p tel = case insertImplicit p $ telToList tel of- BadImplicits -> typeError WrongHidingInLHS- NoSuchName x -> typeError WrongHidingInLHS- ImpInsert n -> return $ map implicitArg n+ BadImplicits -> typeError WrongHidingInLHS+ NoSuchName x xs -> typeError $ WrongNamedArgumentInLHS (getHiding p) x xs+ ImpInsert n -> return $ map implicitArg n implicitArg d = implicitP $ getArgInfo d
src/full/Agda/TypeChecking/Rules/LHS/Problem.hs view
@@ -18,7 +18,6 @@ import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.List ( sortOn )-import Data.Semigroup ( Semigroup, (<>) ) import qualified Data.Set as Set import Agda.Syntax.Common@@ -215,7 +214,7 @@ data AsBinding = AsB Name Term (Dom Type) data DotPattern = Dot A.Expr Term (Dom Type)-data AbsurdPattern = Absurd Range Type+data AbsurdPattern = Absurd Range (Dom Type) data AnnotationPattern = Ann A.Expr Type -- | State worked on during the main loop of checking a lhs.@@ -238,6 +237,14 @@ -- ^ have we splitted with a PartialFocus? , _lhsIndexedSplit :: !Bool -- ^ Have we split on any indexed inductive types?+ , _lhsMatchPrio :: !MatchPrio+ -- ^ The match priority attached to the next split.+ -- The priority approximates causality, i.e. some splits (higher prio value) become available+ -- only after certain splits (lower prio value) have already been made.+ -- This information is used in the matcher for the non-compiled clauses+ -- to determine whether a 'DontKnow' dominates a 'No' (mismatch).+ -- The lower prio value is dominant in case of conflict.+ -- See issues #2964 and #3054, #8559. } lhsTel :: Lens' (LHSState a) Telescope@@ -252,6 +259,9 @@ lhsTarget :: Lens' (LHSState a) (Arg Type) lhsTarget f p = f (_lhsTarget p) <&> \x -> p {_lhsTarget = x} +lhsMatchPrio :: Lens' (LHSState a) MatchPrio+lhsMatchPrio f p = f (_lhsMatchPrio p) <&> \ x -> p{ _lhsMatchPrio = x }+ data PatVarPosition = PVLocal | PVParam deriving (Show, Eq) @@ -332,7 +342,7 @@ (A.AsP info A.BindName{unBind = x} p) -> (asPattern x v a `mappend`) <$> do getLeftoverPattern isParamName $ ProblemEq p v a (A.DotP info e) -> return $ dotPattern e v a- (A.AbsurdP info) -> return $ absurdPattern (getRange info) (unDom a)+ (A.AbsurdP info) -> return $ absurdPattern (getRange info) a _ -> return $ otherPattern p where@@ -420,10 +430,14 @@ instantiateFull' (AsB x v a) = AsB x <$> instantiateFull' v <*> instantiateFull' a instance PrettyTCM (LHSState a) where- prettyTCM (LHSState tel outPat (Problem eqs rps _) target _ _) = vcat+ prettyTCM (LHSState tel outPat (Problem eqs rps _) target _ _ prio) = vcat [ "tel = " <+> prettyTCM tel , "outPat = " <+> addContext tel (prettyTCMPatternList outPat) , "problemEqs = " <+> addContext tel (prettyList_ $ map prettyTCM eqs) , "problemRestPats = " <+> prettyList_ (map prettyA rps) , "target = " <+> addContext tel (prettyTCM target)+ , "matchPrio = " <+> prettyTCM prio ]++instance PrettyTCM MatchPrio where+ prettyTCM (MatchPrio prio) = (text . show) prio
src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs view
@@ -2,6 +2,8 @@ module Agda.TypeChecking.Rules.LHS.ProblemRest where +import Prelude hiding (null)+ import Control.Monad import Control.Monad.Except @@ -21,6 +23,7 @@ import Agda.TypeChecking.Rules.LHS.Implicit import Agda.Utils.Functor+import Agda.Utils.Null import Agda.Utils.Size import Agda.Utils.Impossible@@ -36,7 +39,7 @@ where telList = telToList tel telRemaining = drop (length ps) telList -- telescope entries beyond patterns- ren (Arg ai (Named nm p)) dom@Dom{ unDom = (y, a) } =+ ren (Arg ai (Named nm p)) dom@(unDom -> (y, a)) = case p of -- Andreas, 2017-10-12, issue #2803, also preserve user-written hidden names. -- However, not if the argument is named, because then the name in the telescope@@ -105,14 +108,14 @@ let problem = Problem eqs ps ret qs0 = teleNamedArgs delta - updateProblemRest $ LHSState delta qs0 problem (Arg (defaultArgInfo { argInfoModality = unitModality }) a) [] False+ updateProblemRest $ LHSState delta qs0 problem (Arg (defaultArgInfo { argInfoModality = unitModality }) a) [] False empty -- | 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 ixsplit) = addContext tel0 $ do+updateProblemRest st@(LHSState tel0 qs0 p@(Problem oldEqs ps ret) a psplit ixsplit prio) = addContext tel0 $ do ps <- insertImplicitPatternsT ExpandLast ps $ unArg a reportSDoc "tc.lhs.imp" 20 $ "insertImplicitPatternsT returned" <+> fsep (map prettyA ps)@@ -142,7 +145,7 @@ , "b =" <+> addContext tel1 (prettyTCM b) ] ]- reportSDoc "tc.lhs.problem" 60 $ addContext tel0 $ vcat+ reportSDoc "tc.lhs.problem" 90 $ addContext tel0 $ vcat [ nest 2 $ vcat [ "ps =" <+> (text . show) ps , "a =" <+> (text . show) a@@ -164,4 +167,12 @@ , _lhsTarget = a $> b , _lhsPartialSplit = psplit , _lhsIndexedSplit = ixsplit+ , _lhsMatchPrio = succ prio+ -- Andreas, 2026-05-09, issue #8559+ -- We approximate the split causality by simply increasing the prio+ -- at each call to 'updateProblemRest'.+ -- This is somewhat crude but sufficient to pass #3054 and #8559 and fail #2964+ -- as intended.+ -- Should there be examples where this simply heuristics is not adequate,+ -- it needs to be refined. }
src/full/Agda/TypeChecking/Rules/LHS/Unify.hs view
@@ -126,17 +126,14 @@ import Prelude hiding (null) -import Control.Monad.State ( gets, modify, evalStateT )-import Control.Monad.Writer ( WriterT(..), MonadWriter(..) ) import Control.Monad.Except ( runExceptT ) -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.Semigroup ( All(..) )+import Data.List qualified as List+import Data.IntMap qualified as IntMap import Data.IntMap (IntMap) -import qualified Agda.Benchmarking as Bench+import Agda.Benchmarking qualified as Bench import Agda.Interaction.Options (optInjectiveTypeConstructors) @@ -144,13 +141,13 @@ import Agda.Syntax.Internal import Agda.TypeChecking.Monad-import qualified Agda.TypeChecking.Monad.Benchmark as Bench-import Agda.TypeChecking.Conversion.Pure (pureEqualTermB, pureEqualTypeB)+import Agda.TypeChecking.Monad.Benchmark qualified as Bench+import Agda.TypeChecking.Conversion.Pure (pureBlockOrEqualTerm, pureBlockOrEqualType) import Agda.TypeChecking.Constraints () import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Irrelevance import Agda.TypeChecking.Reduce-import qualified Agda.TypeChecking.Patterns.Match as Match+import Agda.TypeChecking.Patterns.Match qualified as Match import Agda.TypeChecking.Pretty import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope@@ -172,8 +169,11 @@ import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.PartialOrd-import Agda.Utils.Singleton import Agda.Utils.Size+import Agda.Utils.Singleton+import Agda.Utils.VarSet qualified as VarSet+import Agda.Utils.StrictWriter+import Agda.Utils.StrictState import Agda.Utils.Impossible @@ -189,7 +189,7 @@ ( Telescope -- @tel@ , PatternSubstitution -- @sigma@ s.t. @tel ⊢ sigma : varTel@ , [NamedArg DeBruijnPattern] -- @ps@ s.t. @tel ⊢ ps : eqTel @- , Either NoLeftInv (Substitution, Substitution) -- (τ,leftInv)+ , TCM (Either NoLeftInv (Substitution, Substitution)) -- (τ,leftInv) ) data UnificationResult' a@@ -207,7 +207,7 @@ -- -- * @gamma@ is the telescope of free variables in @us@ and @vs@. ----- * @flex@ is the set of flexible (instantiable) variabes in @us@ and @vs@.+-- * @flex@ is the set of flexible (instantiable) variables in @us@ and @vs@. -- -- The result is the most general unifier of @us@ and @vs@. unifyIndices@@ -219,7 +219,6 @@ -> Args -- ^ @vs@ -> TCM UnificationResult unifyIndices linv tel flex a us vs =- Bench.billTo [Bench.Typing, Bench.CheckLHS, Bench.UnifyIndices] $ fmap (\(a,b,c,_) -> (a,b,c)) <$> unifyIndices' linv tel flex a us vs unifyIndices'@@ -230,41 +229,41 @@ -> Args -- ^ @us@ -> Args -- ^ @vs@ -> TCM FullUnificationResult-unifyIndices' linv tel flex a [] [] = return $ Unifies (tel, idS, [], Right (idS, raiseS 1))-unifyIndices' linv tel flex a us vs = do+unifyIndices' linv tel flex a us vs = Bench.billTo [Bench.UnifyIndices] $ case (us, vs) of+ ([], []) -> pure $ Unifies (tel, idS, [], pure $ Right (idS, raiseS 1))+ _ -> do reportSDoc "tc.lhs.unify" 10 $ sep [ "unifyIndices" , ("tel =" <+>) $ nest 2 $ prettyTCM tel- , ("flex =" <+>) $ nest 2 $ addContext tel $ text $ show $ map flexVar flex+ , ("flex =" <+>) $ nest 2 $ addContext tel $ text $ show $ map' flexVar flex , ("a =" <+>) $ nest 2 $ addContext tel $ parens (prettyTCM a)- , ("us =" <+>) $ nest 2 $ addContext tel $ prettyList $ map prettyTCM us- , ("vs =" <+>) $ nest 2 $ addContext tel $ prettyList $ map prettyTCM vs+ , ("us =" <+>) $ nest 2 $ addContext tel $ prettyList $ map' prettyTCM us+ , ("vs =" <+>) $ nest 2 $ addContext tel $ prettyList $ map' prettyTCM vs ] initialState <- initUnifyState tel flex a us vs reportSDoc "tc.lhs.unify" 20 $ "initial unifyState:" <+> prettyTCM initialState (result,log) <- runUnifyLogT $ unify initialState rightToLeftStrategy+ reportSDoc "tc.lhs.unify" 20 $ "unification done" 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)+ let getTauInv = do+ strict <- viewTC eSplitOnStrict+ 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)-+ return (varTel s, unifySubst output, ps, getTauInv) type UnifyStrategy = UnifyState -> ListT TCM UnifyStep - --UNUSED Liang-Ting Chen 2019-07-16 --leftToRightStrategy :: UnifyStrategy --leftToRightStrategy s =@@ -277,7 +276,7 @@ where n = size $ eqTel s completeStrategyAt :: Int -> UnifyStrategy-completeStrategyAt k s = msum $ map (\strat -> strat k s) $+completeStrategyAt k s = msum $ map' (\strat -> strat k s) $ -- ASR (2021-02-07). The below eta-expansions are required by GHC >= -- 9.0.1 (see Issue #4955). [ (\n -> skipIrrelevantStrategy n)@@ -297,7 +296,7 @@ -- This is naturally sensitive to normalization. isHom :: (Free a, Subst a) => Int -> a -> Maybe a isHom n x = do- guard $ getAll $ runFree (All . (>= n)) IgnoreNot x+ guard $ allFreeVar (>= n) x return $ raise (-n) x findFlexible :: Int -> FlexibleVars -> Maybe (FlexibleVar Nat)@@ -305,7 +304,8 @@ basicUnifyStrategy :: Int -> UnifyStrategy basicUnifyStrategy k s = do- Equal dom@Dom{unDom = a} u v <- eqUnLevel (getEquality k s)+ reportSDoc "tc.lhs.unify" 40 $ "trying basicUnifyStrategy"+ Equal dom@(unDom -> a) u v <- eqUnLevel (getEquality k s) -- Andreas, 2019-02-23: reduce equality for the sake of isHom? ha <- fromMaybeMP $ isHom n a (mi, mj) <- addContext (varTel s) $ (,) <$> isEtaVar u ha <*> isEtaVar v ha@@ -341,7 +341,8 @@ dataStrategy :: Int -> UnifyStrategy dataStrategy k s = do- Equal Dom{unDom = a} u v <- eqConstructorForm =<< eqUnLevel =<< getReducedEqualityUnraised k s+ reportSDoc "tc.lhs.unify" 40 $ "trying dataStrategy"+ Equal (unDom -> a) u v <- eqConstructorForm =<< eqUnLevel =<< getReducedEqualityUnraised k s sortOk <- reduce (getSort a) <&> \case Type{} -> True Inf{} -> True@@ -350,7 +351,7 @@ case unEl a of Def d es | sortOk -> do npars <- catMaybesMP $ getNumberOfParameters d- let (pars,ixs) = splitAt npars $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ let (!pars, !ixs) = splitAt' npars $ mustAllApplyElims es reportSDoc "tc.lhs.unify" 40 $ addContext (varTel s `abstract` eqTel s) $ "Found equation at datatype " <+> prettyTCM d <+> " with parameters " <+> prettyTCM (raise (size (eqTel s) - k) pars)@@ -365,24 +366,26 @@ ifOccursStronglyRigid i u ret = do -- Call forceNotFree to reduce u as far as possible -- around any occurrences of i- (_ , u) <- forceNotFree (singleton i) u- case flexRigOccurrenceIn i u of- Just StronglyRigid -> ret+ (_ , u) <- liftReduce $ forceNotFree (singleton i) u+ case varOccurrenceIn i u of+ Just (VarOcc StronglyRigid mod) | isRelevant mod -> ret _ -> mzero checkEqualityStrategy :: Int -> UnifyStrategy checkEqualityStrategy k s = do- let Equal Dom{unDom = a} u v = getEquality k s+ reportSDoc "tc.lhs.unify" 40 $ "trying checkEqualityStrategy"+ let Equal (unDom -> a) u v = getEquality k s n = eqCount s ha <- fromMaybeMP $ isHom n a return $ Deletion k ha u v literalStrategy :: Int -> UnifyStrategy literalStrategy k s = do+ reportSDoc "tc.lhs.unify" 40 $ "trying literalStrategy" let n = eqCount s- Equal Dom{unDom = a} u v <- eqUnLevel $ getEquality k s+ Equal (unDom -> a) u v <- eqUnLevel $ getEquality k s ha <- fromMaybeMP $ isHom n a- (u, v) <- reduce (u, v)+ (u, v) <- addContext (varTel s) $ reduce (u, v) case (u , v) of (Lit l1 , Lit l2) | l1 == l2 -> return $ Deletion k ha u v@@ -391,7 +394,8 @@ etaExpandVarStrategy :: Int -> UnifyStrategy etaExpandVarStrategy k s = do- Equal Dom{unDom = a} u v <- eqUnLevel =<< getReducedEquality k s+ reportSDoc "tc.lhs.unify" 40 $ "trying etaExpandVarStrategy"+ Equal (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@@ -406,7 +410,7 @@ -- forcing translation is unhappy. 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+ b <- addContext (telFromList $ take' k $ telToList $ varTel s) $ reduce b0 (d, pars) <- catMaybesMP $ isEtaRecordType b ps <- fromMaybeMP $ allProjElims es guard =<< orM@@ -415,7 +419,7 @@ , (Right True ==) <$> runBlocked (isSingletonRecord d pars) ] reportSDoc "tc.lhs.unify" 50 $- "with projections " <+> prettyTCM (map snd ps)+ "with projections " <+> prettyTCM (map' snd ps) reportSDoc "tc.lhs.unify" 50 $ "at record type " <+> prettyTCM d return $ EtaExpandVar fi d pars@@ -426,8 +430,9 @@ etaExpandEquationStrategy :: Int -> UnifyStrategy etaExpandEquationStrategy k s = do+ reportSDoc "tc.lhs.unify" 40 $ "trying etaExpandEquationStrategy" -- Andreas, 2019-02-23, re #3578, is the following reduce redundant?- Equal Dom{unDom = a} u v <- getReducedEqualityUnraised k s+ Equal (unDom -> a) u v <- getReducedEqualityUnraised k s (d, pars) <- catMaybesMP $ addContext tel $ isEtaRecordType a guard =<< orM [ (Right True ==) <$> runBlocked (isSingletonRecord d pars)@@ -441,7 +446,7 @@ Def f es -> usesCopatterns f Con c _ _ -> isJust <$> isRecordConstructor (conName c) - Var _ _ -> return False+ Var x _ -> rewUsesCopatterns $ RewVarHead x Lam _ _ -> __IMPOSSIBLE__ Lit _ -> __IMPOSSIBLE__ Pi _ _ -> __IMPOSSIBLE__@@ -449,14 +454,15 @@ Level _ -> __IMPOSSIBLE__ MetaV _ _ -> return False DontCare _ -> return False- Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s+ Dummy s _ -> __IMPOSSIBLE_VERBOSE__ (show s) - tel = varTel s `abstract` telFromList (take k $ telToList $ eqTel s)+ tel = varTel s `abstract` telFromList (take' k $ telToList $ eqTel s) simplifySizesStrategy :: Int -> UnifyStrategy simplifySizesStrategy k s = do+ reportSDoc "tc.lhs.unify" 40 $ "trying simplifySizesStrategy" isSizeName <- isSizeNameTest- Equal Dom{unDom = a} u v <- getReducedEquality k s+ Equal (unDom -> a) u v <- getReducedEquality k s case unEl a of Def d _ -> do guard $ isSizeName d@@ -471,6 +477,7 @@ injectiveTypeConStrategy :: Int -> UnifyStrategy injectiveTypeConStrategy k s = do+ reportSDoc "tc.lhs.unify" 40 $ "trying injectiveTypeConStrategy" injTyCon <- optInjectiveTypeConstructors <$> pragmaOptions guard injTyCon eq <- eqUnLevel =<< getReducedEquality k s@@ -489,26 +496,28 @@ PrimitiveSort{} -> __IMPOSSIBLE__ GeneralizableVar{} -> __IMPOSSIBLE__ Constructor{} -> __IMPOSSIBLE__ -- Never a type!- let us = fromMaybe __IMPOSSIBLE__ $ allApplyElims es- vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es'+ let us = mustAllApplyElims es+ vs = mustAllApplyElims es' return $ TypeConInjectivity k d us vs _ -> mzero injectivePragmaStrategy :: Int -> UnifyStrategy injectivePragmaStrategy k s = do+ reportSDoc "tc.lhs.unify" 40 $ "trying injectivePragmaStrategy" 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 def <- getConstInfo d guard $ defInjective def- let us = fromMaybe __IMPOSSIBLE__ $ allApplyElims es- vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es'+ let us = mustAllApplyElims es+ vs = mustAllApplyElims es' return $ TypeConInjectivity k d us vs _ -> mzero skipIrrelevantStrategy :: Int -> UnifyStrategy skipIrrelevantStrategy k s = do+ reportSDoc "tc.lhs.unify" 40 $ "trying skipIrrelevantStrategy" 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@@ -520,13 +529,12 @@ -- Actually doing the unification ---------------------------------------------------- -unifyStep- :: UnifyState -> UnifyStep -> UnifyStepT TCM (UnificationResult' UnifyState)+unifyStep :: UnifyState -> UnifyStep -> UnifyStepT TCM (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) $ pureEqualTermB a u v+ isReflexive <- addContext (varTel s) $ lift $ pureBlockOrEqualTerm a u v withoutK <- withoutKOption- splitOnStrict <- asksTC envSplitOnStrict+ splitOnStrict <- viewTC eSplitOnStrict case isReflexive of Left block -> return $ UnifyBlocked block Right False -> return $ UnifyStuck []@@ -544,7 +552,7 @@ withoutK <- withoutKOption -- Split equation telescope into parts before and after current equation- let (eqListTel1, _ : eqListTel2) = splitAt k $ telToList $ eqTel s+ let (eqListTel1, _ : eqListTel2) = splitAt' k $ telToList $ eqTel s (eqTel1, eqTel2) = (telFromList eqListTel1, telFromList eqListTel2) -- Get constructor telescope and target indices@@ -555,7 +563,7 @@ 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+ let args = mustAllApplyElims es in drop (length pars) args _ -> __IMPOSSIBLE__ @@ -624,7 +632,7 @@ UnifyStuck _ -> let n = eqCount s- Equal Dom{unDom = a} u v = getEquality k s+ Equal (unDom -> a) u v = getEquality k s in return $ UnifyStuck [UnifyIndicesNotVars (varTel s `abstract` eqTel s) a (raise n u) (raise n v) (raise (n-k) ixs)]@@ -678,15 +686,22 @@ unifyStep s EtaExpandVar{ expandVar = fi, expandVarRecordType = d , expandVarParameters = pars } = do recd <- fromMaybe __IMPOSSIBLE__ <$> isRecord d+ -- We don't eta-expand variables which occur in local rewrite rules+ -- In principle, I think we could handle this safely, but it is tricky+ localRew <- localRewritingOption+ if localRew && i `VarSet.member` inRewVars (varTel s)+ then pure $ UnifyStuck [UnifyVarInRewriteEta (varTel s) i]+ else do let delta = _recTel recd `apply` pars c = _recConHead recd let nfields = size delta (varTel', rho) = expandTelescopeVar (varTel s) (m-1-i) delta c- projectFlexible = [ FlexibleVar (getArgInfo fi) (flexForced fi) (projFlexKind j) (flexPos fi) (i + j) | j <- [0 .. nfields - 1] ]+ projectFlexible = [ FlexibleVar (getArgInfo fi) (flexForced fi) (projFlexKind j) (flexPos fi) (i + j) |+ j <- [0 .. nfields - 1] ] tellUnifySubst $ rho return $ Unifies $ UState { varTel = varTel'- , flexVars = projectFlexible ++ liftFlexibles nfields (flexVars s)+ , flexVars = projectFlexible ++! liftFlexibles nfields (flexVars s) , eqTel = applyPatSubst rho $ eqTel s , eqLHS = applyPatSubst rho $ eqLHS s , eqRHS = applyPatSubst rho $ eqRHS s@@ -725,9 +740,12 @@ where expandKth us = do let (us1,v:us2) = fromMaybe __IMPOSSIBLE__ $ splitExactlyAt k us- vs <- snd <$> etaExpandRecord d pars (unArg v)- vs <- reduce vs- return $ us1 ++ vs ++ us2+ mvs <- etaExpandRecord d pars (unArg v)+ case mvs of+ Nothing -> lift $ patternViolation neverUnblock -- Issue #8636: cannot eta-expand+ Just (_, vs) -> do+ vs <- addContext (varTel s) $ reduce vs+ return $! us1 ++! vs ++! us2 unifyStep s LitConflict { litType = a@@ -760,28 +778,27 @@ unifyStep s (TypeConInjectivity k d us vs) = do dtype <- defType <$> getConstInfo d TelV dtel _ <- telView dtype- let deq = Def d $ map Apply $ teleArgs dtel+ let deq = Def d $ map' Apply $ teleArgs dtel -- TODO: tellUnifyProof ??? -- but d is not a constructor... Unifies <$> do lensEqTel reduce $ s { eqTel = dtel `abstract` applyUnder k (eqTel s) (raise k deq)- , eqLHS = us ++ dropAt k (eqLHS s)- , eqRHS = vs ++ dropAt k (eqRHS s)+ , eqLHS = us ++! dropAt k (eqLHS s)+ , eqRHS = vs ++! dropAt k (eqRHS s) } data RetryNormalised = RetryNormalised | DontRetryNormalised deriving (Eq, Show) -solutionStep- :: (PureTCM m, MonadWriter UnifyOutput m)- => RetryNormalised+solutionStep ::+ RetryNormalised -> UnifyState -> UnifyStep- -> m (UnificationResult' UnifyState)+ -> WriterT UnifyOutput TCM (UnificationResult' UnifyState) solutionStep retry s step@Solution{ solutionAt = k- , solutionType = dom@Dom{ unDom = a }+ , solutionType = dom@(unDom -> a) , solutionVar = fi@FlexibleVar{ flexVar = i } , solutionTerm = u } = do let m = varCount s@@ -796,7 +813,7 @@ let forcedVars | inMakeCase = IntMap.empty | otherwise = IntMap.fromList [ (flexVar fi, getModality fi) | fi <- flexVars s, flexForced fi == Forced ]- (p, bound) <- patternBindingForcedVars forcedVars u+ (p, bound) <- lift $ patternBindingForcedVars forcedVars u -- To maintain the invariant that each variable in varTel is bound exactly once in the pattern -- substitution we need to turn the bound variables in `p` into dot patterns in the rest of the@@ -809,11 +826,11 @@ -- patternBindingForcedVars). let updModality md vars tel | IntMap.null vars = tel- | otherwise = telFromList $ zipWith upd (downFrom $ size tel) (telToList tel)+ | otherwise = telFromList $ zipWith' upd (downFrom $ size tel) (telToList tel) where upd i a | Just md' <- IntMap.lookup i vars = setModality (composeModality md md') a | otherwise = a- s <- return $ s { varTel = updModality (getModality fi) bound (varTel s) }+ s <- return $! s { varTel = updModality (getModality fi) bound (varTel s) } reportSDoc "tc.lhs.unify.force" 45 $ vcat [ "forcedVars =" <+> pretty (IntMap.keys forcedVars)@@ -822,13 +839,29 @@ , "bound =" <+> pretty (IntMap.keys bound) , "dotSub =" <+> pretty dotSub ] + -- Splitting on variables that occur in local rewrite rules is not allowed!+ reportSDoc "tc.lhs.unify" 65 $ vcat+ [ "Checking whether variable:" <+>+ addContext (varTel s) (prettyTCM $ var i)+ , "occurs in a local rewrite rule in" <+>+ prettyTCM (varTel s)+ , "i.e. is one of" <+>+ addContext (varTel s) (prettyTCM $+ fmap var $ VarSet.toAscList $ inRewVars $ varTel s)+ ]++ localRew <- localRewritingOption+ if localRew && i `VarSet.member` inRewVars (varTel s)+ then pure $ UnifyStuck [UnifyVarInRewrite (varTel s) a i u]+ else do+ -- Check that the type of the variable is equal to the type of the equation -- (not just a subtype), otherwise we cannot instantiate (see Issue 2407).- let dom'@Dom{ unDom = a' } = getVarType (m-1-i) s+ let dom'@(unDom -> a') = getVarType (m-1-i) s equalTypes <- addContext (varTel s) $ do reportSDoc "tc.lhs.unify" 45 $ "Equation type: " <+> prettyTCM a reportSDoc "tc.lhs.unify" 45 $ "Variable type: " <+> prettyTCM a'- pureEqualTypeB a a'+ lift $ pureBlockOrEqualType a a' -- The conditions on the relevances are as follows (see #2640): -- - If the type of the equation is relevant, then the solution must be@@ -847,9 +880,9 @@ mod = applyUnless (shapeIrrelevant `moreRelevant` eqrel) (setRelevance eqrel) $ applyUnless (usableQuantity envmod) (setQuantity zeroQuantity) $ varmod- reportSDoc "tc.lhs.unify" 65 $ text $ "Equation modality: " ++ show (getModality dom)- reportSDoc "tc.lhs.unify" 65 $ text $ "Variable modality: " ++ show varmod- reportSDoc "tc.lhs.unify" 65 $ text $ "Solution must be usable in a " ++ show mod ++ " position."+ reportSDoc "tc.lhs.unify" 65 $ text $ "Equation modality: " ++! show (getModality dom)+ reportSDoc "tc.lhs.unify" 65 $ text $ "Variable modality: " ++! show varmod+ reportSDoc "tc.lhs.unify" 65 $ text $ "Solution must be usable in a " ++! show mod ++! " position." -- Andreas, 2018-10-18 -- Currently, the modality check has problems with meta-variables created in the type signature, -- and thus, in quantity 0, that get into terms using the unifier, and there are checked to be@@ -872,26 +905,30 @@ Right True | usable -> case solveVar (m - 1 - i) p s of Nothing | retry == RetryNormalised -> do- u <- normalise u s <- lensVarTel normalise s+ -- #8577: Need to normalise 'u' under 'varTel'+ u <- addContext (varTel s) $ normalise u solutionStep DontRetryNormalised s step{ solutionTerm = u } Nothing ->- return $ UnifyStuck [UnifyRecursiveEq (varTel s) a i u]- Just (s', sub) -> do+ return $! UnifyStuck [UnifyRecursiveEq (varTel s) a i u]+ Just (s', sub, perm) -> do let rho = sub `composeS` dotSub tellUnifySubst rho let (s'', sigma) = solveEq k (applyPatSubst rho u) s' tellUnifyProof sigma+ tellUnifySolutionPerm perm return $ Unifies s'' -- Andreas, 2019-02-23, issue #3578: do not eagerly reduce -- Unifies <$> liftTCM (reduce s'')- Right True -> return $ UnifyStuck [UnifyUnusableModality (varTel s) a i u mod]+ Right True -> return $! UnifyStuck [UnifyUnusableModality (varTel s) a i u mod] solutionStep _ _ _ = __IMPOSSIBLE__ unify :: UnifyState -> UnifyStrategy -> UnifyLogT TCM (UnificationResult' UnifyState)-unify s strategy = if isUnifyStateSolved s- then return $ Unifies s- else tryUnifyStepsAndContinue (strategy s)+unify s strategy = do+ reportSDoc "tc.lhs.unify" 40 $ "unify"+ if isUnifyStateSolved s+ then return $ Unifies s+ else tryUnifyStepsAndContinue (strategy s) where tryUnifyStepsAndContinue :: ListT TCM UnifyStep -> UnifyLogT TCM (UnificationResult' UnifyState)@@ -927,7 +964,7 @@ UnifyStuck err1 -> do y <- fallback case y of- UnifyStuck err2 -> return $ UnifyStuck $ err1 ++ err2+ UnifyStuck err2 -> return $! UnifyStuck $! err1 ++! err2 _ -> return y failure :: Monad m => m (UnificationResult' a)@@ -935,12 +972,12 @@ -- | Turn a term into a pattern while binding as many of the given forced variables as possible (in -- non-forced positions).-patternBindingForcedVars :: PureTCM m => IntMap Modality -> Term -> m (DeBruijnPattern, IntMap Modality)+patternBindingForcedVars :: IntMap Modality -> Term -> TCM (DeBruijnPattern, IntMap Modality) patternBindingForcedVars forced v = do let v' = precomputeFreeVars_ v runWriterT (evalStateT (go unitModality v') forced) where- noForced v = gets $ IntSet.disjoint (precomputedFreeVars v) . IntMap.keysSet+ noForced v = gets $ VarSet.disjoint (precomputedFreeVars v) . VarSet.fromList . IntMap.keys bind md i = do gets (IntMap.lookup i) >>= \case@@ -948,39 +985,39 @@ -- The new binding site must be more relevant (more relevant = smaller). -- "The forcing analysis guarantees that there exists such a position." -- Really? Andreas, 2021-08-18, issue #5506- tell $ IntMap.singleton i md- modify $ IntMap.delete i- return $ varP (deBruijnVar i)- _ -> return $ dotP (Var i [])+ tell $! IntMap.singleton i md+ modify $! IntMap.delete i+ return $! varP (deBruijnVar i)+ _ -> return $! dotP (Var i []) - go md v = ifM (noForced v) (return $ dotP v) $ do+ go md v = ifM (noForced v) (return $! dotP v) $ do v' <- lift $ lift $ reduce v case v' of Var i [] -> bind md i -- we know i is forced Con c ci es | Just vs <- allApplyElims es -> do fs <- defForced <$> getConstInfo (conName c)- let goArg Forced v = return $ fmap (unnamed . dotP) v+ let goArg Forced v = return $! fmap (unnamed . dotP) v goArg NotForced v = fmap unnamed <$> traverse (go $ composeModality md $ getModality v) v- (ps, bound) <- listen $ zipWithM goArg (fs ++ repeat NotForced) vs+ (ps, bound) <- listen $ zipWithM goArg (fs ++! repeat NotForced) vs if IntMap.null bound- then return $ dotP v -- bound nothing+ then return $! dotP v -- bound nothing else do let cpi = (toConPatternInfo ci) { conPLazy = True } -- Not setting conPType. Is this a problem?- return $ ConP c cpi $ map (setOrigin Inserted) ps- | otherwise -> return $ dotP v -- Higher constructor (es has IApply)+ return $! ConP c cpi $! map' (setOrigin Inserted) ps+ | otherwise -> return $! dotP v -- Higher constructor (es has IApply) -- Non-pattern positions- Var _ (_:_) -> return $ dotP v- Lam{} -> return $ dotP v- Pi{} -> return $ dotP v- Def{} -> return $ dotP v- MetaV{} -> return $ dotP v- Sort{} -> return $ dotP v- Level{} -> return $ dotP v- DontCare{} -> return $ dotP v- Dummy{} -> return $ dotP v- Lit{} -> return $ dotP v+ Var _ (_:_) -> return $! dotP v+ Lam{} -> return $! dotP v+ Pi{} -> return $! dotP v+ Def{} -> return $! dotP v+ MetaV{} -> return $! dotP v+ Sort{} -> return $! dotP v+ Level{} -> return $! dotP v+ DontCare{} -> return $! dotP v+ Dummy{} -> return $! dotP v+ Lit{} -> return $! dotP v -- Andreas, 2023-08-20, issue #6767 -- The last case is not __IMPOSSIBLE__ (regresssion in 2.6.2). -- It would be if we had reduced to `constructorForm`,
src/full/Agda/TypeChecking/Rules/LHS/Unify/LeftInverse.hs view
@@ -1,7 +1,9 @@ {-# OPTIONS_GHC -Wunused-imports #-}- {-# LANGUAGE NondecreasingIndentation #-} +{-| Functions for building the left inverse part of a 'UnifyEquiv'.+ -}+ module Agda.TypeChecking.Rules.LHS.Unify.LeftInverse where import Prelude hiding ((!!), null)@@ -10,6 +12,10 @@ import Control.Monad.State import Control.Monad.Except +import Data.Functor++import qualified Agda.TypeChecking.Monad.Benchmark as Bench+ import Agda.Syntax.Common import Agda.Syntax.Internal @@ -29,10 +35,42 @@ import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null+import Agda.Utils.Permutation import Agda.Utils.Size import Agda.Utils.Impossible ++data DigestedUnifyStep+ = DSolution Int (Dom Type) (FlexibleVar Int) Term (Either () ())+ | DEtaExpandVar (FlexibleVar Int) QName Args++instance PrettyTCM DigestedUnifyStep where+ prettyTCM (DSolution a b c d e) = prettyTCM (Solution a b c d e)+ prettyTCM (DEtaExpandVar a b c) = prettyTCM (EtaExpandVar a b c)++data DigestedUnifyLogEntry+ = DUnificationStep UnifyState DigestedUnifyStep UnifyOutput++type DigestedUnifyLog = [(DigestedUnifyLogEntry,UnifyState)]++-- | Pre-process a UnifyLog so that we catch unsupported steps early.+digestUnifyLog :: UnifyLog -> Either NoLeftInv DigestedUnifyLog+digestUnifyLog log = forM log \(UnificationStep s step out, s') -> do+ let illegal = Left $ Illegal step+ unsupported = Left $ UnsupportedYet step+ ret step = pure (DUnificationStep s step out, s')+ case step of+ Solution a b c d e -> ret $ DSolution a b c d e+ EtaExpandVar a b c -> ret $ DEtaExpandVar a b c+ Deletion{} -> illegal+ TypeConInjectivity{} -> illegal+ -- These should end up in a NoUnify+ Conflict{} -> __IMPOSSIBLE__+ LitConflict{} -> __IMPOSSIBLE__+ Cycle{} -> __IMPOSSIBLE__+ _ -> unsupported+ 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"@@ -41,6 +79,8 @@ 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"+ prettyTCM (CantTransport t) = fsep $ pwords "The type" <> [prettyTCM t] <> pwords "can not be transported"+ prettyTCM (CantTransport' t) = fsep $ pwords "The type" <> [prettyTCM t] <> pwords "can not be transported" data NoLeftInv = UnsupportedYet {badStep :: UnifyStep}@@ -50,69 +90,75 @@ | SplitOnStrict -- ^ splitting on a Strict Set. | SplitOnFlat -- ^ splitting on a @♭ argument | UnsupportedCxt+ | CantTransport (Closure (Abs Type))+ | CantTransport' (Closure Type) 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 <- cubicalOption- "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+-- | Build the left inverse part of a 'UnifyEquiv' (@τ@, @leftInv@).+buildLeftInverse :: UnifyState -> UnifyLog -> TCM (Either NoLeftInv (Substitution, Substitution))+buildLeftInverse s0 log = Bench.billTo [Bench.UnifyIndices, Bench.CubicalLeftInversion] $ case digestUnifyLog log of+ Left no -> do+ reportSDoc "tc.lhs.unify.inv.badstep" 20 $ "No Left Inverse:" <+> prettyTCM (badStep no)+ return (Left no)+ Right log -> do - 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+ reportSDoc "tc.lhs.unify.inv.badstep" 20 $ do+ cubical <- cubicalOption+ "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+ ] - return $ Right (tau,leftInv)+ compose :: [(Retract, Term)] -> ExceptT NoLeftInv TCM Retract+ compose [] = __IMPOSSIBLE__+ compose [(xs, _)] = pure xs+ compose ((x, t):xs) = do+ r <- compose xs+ ExceptT $ composeRetract x t r <&> \case+ Left e -> Left (CantTransport e)+ Right x -> Right x + 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 -> runExceptT (compose xs) >>= \case+ Left no -> return (Left no)+ Right (_, _, tau0, leftInv0) -> do+ -- Γ,φ,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+ reportSDoc "tc.lhs.unify.inv" 20 $ addContext working_tel $ "tau0 :" <+> prettyTCM tau0+ reportSDoc "tc.lhs.unify.inv" 20 $ addContext working_tel $ addContext ("r" :: String, __DUMMY_DOM__) $+ "leftInv0: " <+> prettyTCM leftInv0++ reportSDoc "tc.lhs.unify.inv" 20 $ "=== after mod"+ do+ reportSDoc "tc.lhs.unify.inv" 20 $ addContext working_tel $ "tau :" <+> prettyTCM tau+ reportSDoc "tc.lhs.unify.inv" 20 $ addContext working_tel $ addContext ("r" :: String, __DUMMY_DOM__) $+ "leftInv: " <+> prettyTCM leftInv++ return $ Right (tau,leftInv)+ type Retract = (Telescope, Substitution, Substitution, Substitution) -- Γ (the problem, including equalities), -- Δ ⊢ ρ : Γ@@ -123,13 +169,13 @@ 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 :: Retract -> Term -> Retract -> TCM (Either (Closure (Abs Type)) 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 $ addContext prob0 $ "tau0 :" <+> prettyTCM tau0 reportSDoc "tc.lhs.unify.inv" 20 $ "Γ1 :" <+> prettyTCM prob1- addContext prob1 $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau1 :" <+> prettyTCM tau1+ reportSDoc "tc.lhs.unify.inv" 20 $ addContext prob1 $ "tau1 :" <+> prettyTCM tau1 {-@@ -160,7 +206,7 @@ let rho = rho1 `composeS` rho0 let tau = tau0 `composeS` tau1 - addContext prob0 $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau :" <+> prettyTCM tau+ reportSDoc "tc.lhs.unify.inv" 20 $ addContext prob0 $ "tau :" <+> prettyTCM tau {- Γ0 ⊢ leftInv : ρ[τ] = idΓ0@@ -187,117 +233,120 @@ -} 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)+ reportSDoc "tc.lhs.unify.inv" 20 $ addContext prob0 $ addContext ("r" :: String, __DUMMY_DOM__) $ "leftInv0 :" <+> prettyTCM leftInv0+ reportSDoc "tc.lhs.unify.inv" 20 $ addContext prob1 $ "rho0 :" <+> prettyTCM rho0+ reportSDoc "tc.lhs.unify.inv" 20 $ addContext prob0 $ "tau0 :" <+> prettyTCM tau0+ reportSDoc "tc.lhs.unify.inv" 20 $ addContext prob0 $ "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+ reportSDoc "tc.lhs.unify.inv" 20 $ addContext prob1 $ addContext ("r" :: String, __DUMMY_DOM__) $ "leftInv1 :" <+> prettyTCM leftInv1+ reportSDoc "tc.lhs.unify.inv" 20 $ addContext prob0 $ addContext ("r" :: String, __DUMMY_DOM__) $ "step0 :" <+> prettyTCM step0 interval <- primIntervalType max <- primIMax neg <- primINeg- result <- sequenceA <$> do+ result <- sequenceA <$!> do 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+ 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+ 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)- leftInv <- case result of- Right x -> pure x- Left cl -> do- reportSDoc "impossible" 10 $ vcat- [ "transpSysTel' errored with term"- , prettyTCM cl- ]- __IMPOSSIBLE__-- let sigma = termsS __IMPOSSIBLE__ $ absBody leftInv- verboseS "tc.lhs.unify.inv" 20 do- addContext prob0 $ addContext ("r" :: String, __DUMMY_DOM__) do- reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv :" <+> prettyTCM (absBody leftInv)- reportSDoc "tc.lhs.unify.inv" 40 $ "leftInv :" <+> pretty (absBody leftInv)- reportSDoc "tc.lhs.unify.inv" 40 $ "leftInvSub :" <+> pretty sigma- return (prob, rho, tau, sigma)+ lift $ runExceptT (map' unArg <$> transpSysTel' True tel [(i, leftInv0)] face step0i)+ case result of+ Left cl -> pure (Left cl)+ Right leftInv -> do+ let sigma = termsS __IMPOSSIBLE__ $ absBody leftInv+ verboseS "tc.lhs.unify.inv" 20 do+ addContext prob0 $ addContext ("r" :: String, __DUMMY_DOM__) do+ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv :" <+> prettyTCM (absBody leftInv)+ reportSDoc "tc.lhs.unify.inv" 40 $ "leftInv :" <+> pretty (absBody leftInv)+ reportSDoc "tc.lhs.unify.inv" 40 $ "leftInvSub :" <+> pretty sigma+ return $ Right (prob, rho, tau, sigma) -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+-- | Build the left inverse corresponding to a single unification step.+buildEquiv :: DigestedUnifyLogEntry -> UnifyState -> TCM (Either NoLeftInv (Retract,Term))+buildEquiv (DUnificationStep st step@(DSolution 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+ cantTransport' :: ExceptT (Closure Type) TCM b -> ExceptT NoLeftInv TCM b+ cantTransport' m = withExceptT CantTransport' m+ cantTransport :: ExceptT (Closure (Abs Type)) TCM b -> ExceptT NoLeftInv TCM b+ cantTransport m = withExceptT CantTransport 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+ -- k counts in eqs from the left u = eqLHS st !! k v = eqRHS st !! k- x = flexVar fx+ -- Γ ⊢ perm : Γ' is a reordering used by instantiateTelescope to ensure the+ -- resulting context is well-formed. Works on de Bruijn levels.+ perm = fromMaybe __IMPOSSIBLE__ $ unifySolutionPerm output+ -- The new de Bruijn index of fx in Γ'. The target context for τ is obtained by dropping+ -- x from Γ' (and the kth equation from the equation telescope) and instantiating+ -- it with u (resp. refl).+ x = fromMaybe __IMPOSSIBLE__ $ lookupRP (reverseP perm) (flexVar fx) neqs = size eqs- phis = 1 -- neqs+ phis = 1 interval <- lift $ primIntervalType- -- Γ, φs : I^phis+ -- Γ, φ : I 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))+ map' (defaultDom . (,interval) . ("phi" ++) . show) [0 .. phis - 1]+ -- working_tel = Γ, φ : I, eqs : lhs ≡ rhs+ working_tel <- abstract gamma_phis <$!>+ cantTransport' (pathTelescope' (raise phis $ eqTel st) (raise phis $ eqLHS st) (raise phis $ eqRHS st))+ -- working_tel' = Γ' , φ : I, eqs : lhs ≡ rhs+ -- = Γ₁, x : A, Γ₂, φ : I, eqs : lhs ≡ rhs+ let permw = liftP (size working_tel - size gamma) perm+ working_tel' <- pure $ permuteTel permw working_tel 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])+ , "perm:" <+> prettyTCM perm ] (tau,leftInv,phi) <- addContext working_tel $ runNamesT [] $ do- let raiseFrom tel x = raise (size working_tel - size tel) x+ let+ raiseFrom :: Subst a => Telescope -> a -> a+ raiseFrom tel x = raise (size working_tel - size tel) x+ bindSplit (tel1,tel2) = (tel1,AbsN (teleNames tel1) tel2) u <- open . raiseFrom gamma . unArg $ u v <- open . raiseFrom gamma . unArg $ 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)+ -- working_tel ⊢ γ₁,x,γ₂,φ,eqs : working_tel'+ let all_args = permute permw $ teleArgs working_tel - -- [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 : A, Γ₂, φ : I, eqs : lhs ≡ rhs+ let (gamma1, xxi) = bindSplit $ splitTelescopeAt (size gamma - x - 1) working_tel'+ (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+ (x_arg:xi0,k_arg:xi1) = splitAt' (size gamma - size gamma1 + phis + k) xxi_args+ -- working_tel ⊢ x : A, Γ₂, φ : I, eqs : lhs ≡ rhs+ xxi_here = absAppN xxi $ map' unArg gamma1_args+ -- x:A, Γ₂ φ+ (xpre,krest) = bindSplit $ splitTelescopeAt ((size gamma - size gamma1) + phis + k) xxi_here k_arg <- open $ unArg k_arg xpre <- open xpre krest <- open krest+ -- Δ₀ = Γ₁, Γ₂+ -- Δ = x eq. Δ₀, φ : I, eqs-k : lhs-k ≡ rhs-k delta <- bindN ["x","eq"] $ \ [x,eq] -> do- let pre = apply1 <$> xpre <*> x+ 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)+ apply1 <$!> applyN krest (x:args) <*!> eq+ -- working_tel ⊢ delta0_args : Δ₀+ let delta0_args = xi0 ++! xi1 let appSide = case side of Left{} -> id Right{} -> unview . INeg . argN@@ -305,18 +354,19 @@ -- 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)+ 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)+ 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+ 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 = i. Δ (k i) (λ j → k (i ∧ j)) d <- bind "i" $ \ i -> applyN delta (csingl' i) -- Andrea 06/06/2018@@ -325,19 +375,17 @@ -- 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+ -- We might want to instead use the info discovered by instantiateTelescope+ -- 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))+ tau <- (gamma1_args ++!) <$!> lift (cantTransport (transpTel' flag d phi delta0_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 :: 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@@ -347,63 +395,61 @@ xi0 <- open xi0 xi1 <- open xi1- delta0 <- bind "i" $ \ i -> apply <$> xpre <*> (take 1 `fmap` csingl i)+ delta0 <- bind "i" $ \ i -> apply <$!> xpre <*!> (take' 1 <$!> csingl i) delta0 <- open delta0 xi0f <- bind "i" $ \ i -> do- m <- trFillTel' flag <$> delta0 <*> phi <*> xi0 <*> i- lift (errorToUnsupported m)+ m <- trFillTel' flag <$!> delta0 <*!> phi <*!> xi0 <*!> i+ lift (cantTransport 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)+ args <- mapM (open . unArg) =<< (lazyAbsApp <$!> xi0f <*!> i)+ apply <$> applyN krest (take' 1 (csingl' i) ++! args) <*!> (drop 1 <$!> csingl i) delta1 <- open delta1 xi1f <- bind "i" $ \ i -> do- m <- trFillTel' flag <$> delta1 <*> phi <*> xi1 <*> i- lift (errorToUnsupported m)+ m <- trFillTel' flag <$!> delta1 <*!> phi <*!> xi1 <*!> i+ lift (cantTransport m) xi1f <- open xi1f fmap absBody $ bind "i" $ \ i' -> do- let (+++) m = liftM2 (++) m+ 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))))+ fmap (permute (invertP __IMPOSSIBLE__ permw)) $+ gamma1_args +++ ((take' 1 <$!> csingl i) +++ ((lazyAbsApp <$!> xi0f <*!> i) +++ ((drop 1 <$!> 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 φ+ reportSDoc "tc.lhs.unify.inv" 20 $ addContext working_tel $ "tau :" <+> prettyTCM (map (setHiding NotHidden) tau)+ reportSDoc "tc.lhs.unify.inv" 20 $ addContext working_tel $ "tauS :" <+> prettyTCM (termsS __IMPOSSIBLE__ $ map unArg tau)+ reportSDoc "tc.lhs.unify.inv" 20 $ addContext working_tel $ addContext ("r" :: String, defaultDom interval) $+ "leftInv: " <+> prettyTCM (map (setHiding NotHidden) leftInv)+ reportSDoc "tc.lhs.unify.inv" 20 $ addContext working_tel $ "leftInv[0]:" <+> (prettyTCM =<< reduce (subst 0 iz $ map (setHiding NotHidden) leftInv))+ reportSDoc "tc.lhs.unify.inv" 20 $ addContext working_tel $ "leftInv[1]:" <+> (prettyTCM =<< reduce (subst 0 io $ map (setHiding NotHidden) leftInv))+ reportSDoc "tc.lhs.unify.inv" 20 $ addContext working_tel $ "[rho]tau :" <+> prettyTCM (applySubst (termsS __IMPOSSIBLE__ $ map unArg tau) $ fromPatternSubstitution- $ raise (size (eqTel st) - 1{-k-} + phis {-neqs{-φs-} - 1{-φ0-}-})+ $ raise (size (eqTel st) - 1 + phis) $ 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 $+ reportSDoc "tc.lhs.unify.inv" 20 $ addContext (varTel next) $ addContext (eqTel next) $ "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+ reportSDoc "tc.lhs.unify.inv" 20 $+ addContext (varTel next) $ addContext ("φ" :: String, __DUMMY_DOM__) $ addContext (raise 1 $ eqTel next) $+ "c :" <+> prettyTCM c 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 $+ addContext (varTel next) $ addContext ("φ" :: String, __DUMMY_DOM__) $ addContext (raise 1 $ eqTel next) $+ "rho :" <+> prettyTCM rho+ return ((working_tel+ , rho+ , termsS __IMPOSSIBLE__ $ map' unArg tau+ , termsS __IMPOSSIBLE__ $ map' unArg leftInv)+ , phi)+buildEquiv (DUnificationStep st step@(DEtaExpandVar fv _d _args) output) next = runExceptT $ do reportSDoc "tc.lhs.unify.inv" 20 "buildEquiv EtaExpandVar" let gamma = varTel st@@ -411,12 +457,13 @@ x = flexVar fv neqs = size eqs phis = 1- interval <- primIntervalType+ 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 <$>- pathTelescope (raise phis $ eqTel st) (raise phis $ eqLHS st) (raise phis $ eqRHS st)+ map' (defaultDom . (,interval) . ("phi" ++) . show) [0 .. phis - 1]+ working_tel <- abstract gamma_phis <$!> do+ withExceptT CantTransport' $+ 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 @@ -424,18 +471,6 @@ 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 {-# SPECIALIZE explainStep :: UnifyStep -> TCM Doc #-} explainStep :: MonadPretty m => UnifyStep -> m Doc
src/full/Agda/TypeChecking/Rules/LHS/Unify/Types.hs view
@@ -4,12 +4,11 @@ import Prelude hiding (null) +import Control.Applicative ((<|>)) import Control.Monad-import Control.Monad.Writer (WriterT(..), MonadWriter(..)) import Data.Foldable (toList) import Data.DList (DList)-import qualified Data.List as List import Agda.Syntax.Common import Agda.Syntax.Internal@@ -24,8 +23,6 @@ import Agda.TypeChecking.Rules.LHS.Problem -import Agda.Utils.Functor-import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Null@@ -33,7 +30,7 @@ import Agda.Utils.Singleton import Agda.Utils.Size import Agda.Utils.Tuple-+import Agda.Utils.StrictWriter import Agda.Utils.Impossible ----------------------------------------------------@@ -56,7 +53,7 @@ eqConstructorForm :: HasBuiltins m => Equality -> m Equality eqConstructorForm (Equal a u v) = Equal a <$> constructorForm u <*> constructorForm v -eqUnLevel :: (HasBuiltins m, HasOptions m) => Equality -> m Equality+eqUnLevel :: (HasBuiltins m) => Equality -> m Equality eqUnLevel (Equal a u v) = Equal a <$> unLevel u <*> unLevel v where unLevel (Level l) = reallyUnLevelView l@@ -221,14 +218,16 @@ --- | Instantiate the k'th variable with the given value.+-- | Instantiate the k'th variable (from the left) with the given value. -- Returns Nothing if there is a cycle.-solveVar :: Int -- ^ Index @k@+solveVar :: Int -- ^ De Bruijn _level_ @k@ -> DeBruijnPattern -- ^ Solution @u@- -> UnifyState -> Maybe (UnifyState, PatternSubstitution)+ -> UnifyState -> Maybe (UnifyState, PatternSubstitution, Permutation) solveVar k u s = case instantiateTelescope (varTel s) k u of Nothing -> Nothing- Just (tel' , sigma , rho) -> Just $ (,sigma) $ UState+ Just (tel' , sigma , perm) ->+ let rho = deleteP k perm+ in Just $ (, sigma , perm) $ UState { varTel = tel' , flexVars = permuteFlex (reverseP rho) $ flexVars s , eqTel = applyPatSubst sigma $ eqTel s@@ -237,9 +236,7 @@ } where permuteFlex :: Permutation -> FlexibleVars -> FlexibleVars- permuteFlex perm =- mapMaybe $ \(FlexibleVar ai fc k p x) ->- FlexibleVar ai fc k p <$> List.elemIndex x (permPicks perm)+ permuteFlex perm = mapMaybe (traverse (lookupRP perm)) applyUnder :: Int -> Telescope -> Term -> Telescope applyUnder k tel u@@ -448,18 +445,20 @@ { unifySubst :: PatternSubstitution -- varΓ' ⊢ σ : varΓ , unifyProof :: PatternSubstitution -- varΓ',eqΓ' ⊢ ps : eqΓ[σ] -- varΓ', us' =_eqΓ' vs' ⊢ ap(ps) : us[σ] =_{eqΓ[σ]} vs[σ]--- , unifyLog :: UnifyLog+ -- For solution steps, the dependency-preserving reordering of varΓ generated+ -- by instantiateTelescope (used by LeftInverse). Works on de Bruijn levels.+ , unifySolutionPerm :: Maybe Permutation } instance Semigroup UnifyOutput where x <> y = UnifyOutput { unifySubst = unifySubst y `composeS` unifySubst x , unifyProof = unifyProof y `composeS` unifyProof x--- , unifyLog = unifyLog x ++ unifyLog y+ , unifySolutionPerm = unifySolutionPerm x <|> unifySolutionPerm y } instance Monoid UnifyOutput where- mempty = UnifyOutput IdS IdS -- []+ mempty = UnifyOutput IdS IdS Nothing mappend = (<>) type UnifyLogT m a = WriterT UnifyLog' m a@@ -467,14 +466,17 @@ type UnifyStepT m a = WriterT UnifyOutput m a tellUnifySubst :: MonadWriter UnifyOutput m => PatternSubstitution -> m ()-tellUnifySubst sub = tell $ UnifyOutput sub IdS+tellUnifySubst sub = tell $ mempty { unifySubst = sub } tellUnifyProof :: MonadWriter UnifyOutput m => PatternSubstitution -> m ()-tellUnifyProof sub = tell $ UnifyOutput IdS sub+tellUnifyProof sub = tell $ mempty { unifyProof = sub } +tellUnifySolutionPerm :: MonadWriter UnifyOutput m => Permutation -> m ()+tellUnifySolutionPerm perm = tell $ mempty { unifySolutionPerm = Just perm }+ 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+runUnifyLogT :: Monad m => UnifyLogT m a -> m (a, UnifyLog)+runUnifyLogT m = second toList <$> runWriterT m
src/full/Agda/TypeChecking/Rules/Record.hs view
@@ -4,7 +4,7 @@ module Agda.TypeChecking.Rules.Record where -import Prelude hiding (null, not, (&&), (||))+import Prelude hiding (null, (&&), (||)) import Data.Maybe import qualified Data.Set as Set@@ -19,7 +19,6 @@ import qualified Agda.Syntax.Info as Info import Agda.TypeChecking.Monad-import Agda.TypeChecking.Primitive import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope import Agda.TypeChecking.Reduce@@ -30,26 +29,26 @@ import Agda.TypeChecking.CompiledClause (hasProjectionPatterns) import Agda.TypeChecking.CompiledClause.Compile import Agda.TypeChecking.InstanceArguments+import Agda.TypeChecking.Rules.Record.Cubical (addCompositionForRecord) 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.Boolean import Agda.Utils.Function ( applyWhen )-import Agda.Utils.Lens-import Agda.Utils.List (headWithDefault)-import Agda.Utils.Maybe+import Agda.Utils.List+import Agda.Utils.List1 (pattern (:|) ) import Agda.Utils.Monad import Agda.Utils.Null import qualified Agda.Syntax.Common.Pretty as P import Agda.Utils.Size+import Agda.Utils.POMonoid (hasLeftAdjoint) import Agda.Utils.Impossible+import qualified Agda.Utils.List1 as List1 --------------------------------------------------------------------------- -- * Records@@ -71,14 +70,16 @@ checkRecDef :: A.DefInfo -- ^ Position and other info. -> QName -- ^ Record type identifier.+ -> PositivityCheck -- ^ Report positivity errors for this record type? -> UniverseCheck -- ^ Check universes?+ -> ForceRecordEta -- ^ @{-# ETA_EQUALITY #-}@ pragma attached to this record definition? -> A.RecordDirectives -- ^ (Co)Inductive, (No)Eta, (Co)Pattern, Constructor? -> A.DataDefParams -- ^ Record parameters. -> 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) contel0 fields = do+checkRecDef i name pc uc forceEta (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.@@ -90,17 +91,17 @@ traceCall (CheckRecDef (getRange name) name ps fields) $ do reportSDoc "tc.rec" 10 $ vcat [ "checking record def" <+> prettyTCM name- , nest 2 $ "ps =" <+> prettyList (map prettyA ps)+ , nest 2 $ "ps =" <+> prettyList (map' prettyA ps) , nest 2 $ "contel =" <+> prettyA contel- , nest 2 $ "fields =" <+> prettyA (map Constr fields)+ , nest 2 $ "fields =" <+> prettyA (map' Constr fields) ] -- get type of record def <- instantiateDef =<< getConstInfo name t <- instantiateFull $ defType def let npars = case theDef def of- DataOrRecSig n -> n- _ -> __IMPOSSIBLE__+ DataOrRecSig n IsRecord_ -> n+ _ -> __IMPOSSIBLE__ -- If the record type is erased, then hard compile-time mode is -- entered.@@ -135,7 +136,7 @@ -- needed for impredicative Prop (not implemented yet) -- ftel <- return $ -- if s == Prop- -- then telFromList $ map (setRelevance Irrelevant) $ telToList ftel+ -- then telFromList $ map' (setRelevance Irrelevant) $ telToList ftel -- else ftel reportSDoc "tc.rec" 20 $ do@@ -143,7 +144,7 @@ "gamma = " <+> inTopContext (prettyTCM gamma) -- record type (name applied to parameters)- rect <- El s . Def name . map Apply <$> getContextArgs+ rect <- El s . Def name . map' Apply <$> getContextArgs -- Put in @rect@ as correct target of constructor type. -- Andreas, 2011-05-10 use telePi_ instead of telePi to preserve@@ -159,28 +160,27 @@ -- Add record type to signature. reportSDoc "tc.rec" 15 $ "adding record type to signature" - etaenabled <- etaEnabled- let getName :: A.Declaration -> [Dom QName]- getName (A.Field _ x arg) = [x <$ domFromArg arg]- getName (A.ScopedDecl _ [f]) = getName f- getName _ = []-- setTactic dom f = f { domTactic = domTactic dom }+ getName = \case+ A.Field _ x arg -> [ x <$ domFromArg arg ]+ A.ScopedDecl _ (f :| []) -> getName f+ _ -> [] - fs = zipWith setTactic (telToList ftel) $ concatMap getName fields+ setTactic dom f = f & dTactic .~ (dom ^. dTactic)+ fs = zipWith' setTactic (telToList ftel) $ concatMap getName fields + -- Andreas, 2020-04-19, issue #4560+ -- If the user declared the record constructor as @pattern@,+ -- then switch on pattern matching for no-eta-equality.+ -- Default is no pattern matching, but definition by copatterns instead.+ patCopat = maybe CopatternMatching (const PatternMatching) pat+ eta = ((patCopat <$) . rangedThing) <$> eta0 -- indCo is what the user wrote: inductive/coinductive/Nothing. -- We drop the Range. indCo = rangedThing <$> ind -- A constructor is inductive unless declared coinductive. conInduction = fromMaybe Inductive indCo- -- Andreas, 2016-09-20, issue #2197.- -- Eta is inferred by the positivity checker.- -- We should turn it off until it is proven to be safe.- noEta = Inferred $ NoEta patCopat- haveEta0 = maybe noEta Specified eta- con = ConHead conName (IsRecord patCopat) conInduction $ map argFromDom fs+ con = ConHead conName (IsRecord patCopat) conInduction NotHIT $ map' argFromDom fs -- A record is irrelevant if all of its fields are. -- In this case, the associated module parameter will be irrelevant.@@ -190,19 +190,38 @@ | Just NoEta{} <- eta = relevant | CoInductive <- conInduction = relevant | null (telToList ftel) = relevant -- #6270: eta unit types don't need to be irrelevant- | otherwise = minimum $ irrelevant : map getRelevance (telToList ftel)+ | otherwise = minimum $ irrelevant : map' getRelevance (telToList ftel) - -- Andreas, 2017-01-26, issue #2436- -- Disallow coinductive records with eta-equality- -- Andreas, 2024-06-14, PR #7300- -- Just make this a deadcode warning.- haveEta <-- if (conInduction == CoInductive && theEtaEquality haveEta0 == YesEta) then do- noEta <$ do- setCurrentRange eta0 $ warning $ CoinductiveEtaRecord name- else pure haveEta0 reportSDoc "tc.rec" 30 $ "record constructor is " <+> prettyTCM con + -- Compute eta status from record directives and options.+ let noEta = NoEta patCopat+ etaenabled <- etaEnabled+ haveEta <- case forceEta of+ -- We force eta-equality since we have an ETA_EQUALITY pragma.+ YesForceRecordEta -> case eta of+ Just (NoEta _) -> typeError $ EtaPragmaVsNoEtaEquality+ _ -> pure $ EtaEquality YesEta EtaFromPragma+ -- We do not have an ETA_EQUALITY pragma, so we first look at possible eta-equality directives+ -- and then at the defaults.+ NoForceRecordEta -> case (eta, conInduction, etaenabled) of+ (Nothing, Inductive, True) -> pure $ EtaEquality YesEta EtaFromOption+ (Nothing, _, _) -> pure $ EtaEquality noEta EtaFromOption+ (Just noEta@NoEta{}, _, _) -> pure $ EtaEquality noEta EtaFromDirective+ (Just YesEta, Inductive,_) -> pure $ EtaEquality YesEta EtaFromDirective+ (Just YesEta, CoInductive, _) -> EtaEquality noEta EtaFromOption <$ do+ -- Andreas, 2017-01-26, issue #2436+ -- Disallow coinductive records with eta-equality+ -- Andreas, 2024-06-14, PR #7300+ -- Just make this a deadcode warning.+ setCurrentRange eta0 $ warning $ CoinductiveEtaRecord name++ -- Warn about 'pattern' directive if eta is on.+ case (haveEta, pat) of+ (EtaEquality YesEta _, Just r) -> setCurrentRange r $+ warning $ UselessPatternDeclarationForRecord "eta"+ _ -> pure ()+ -- Add the record definition. -- Andreas, 2016-06-17, Issue #2018:@@ -221,13 +240,14 @@ , recNamedCon = hasNamedCon , recFields = fs , recTel = telh `abstract` ftel+ , recPositivityCheck= pc , recAbstr = Info.defAbstract i , recEtaEquality' = haveEta , recPatternMatching= patCopat , recInduction = indCo -- We retain the original user declaration [(co)inductive] -- in case the record turns out to be recursive.- -- Determined by positivity checker:+ -- Determined by positivity checker (analysis running always, independently of recPositivityCheck): , recMutual = Nothing -- Determined by the termination checker: , recTerminates = Nothing@@ -247,6 +267,7 @@ , conSrcCon = con , conData = name , conAbstr = Info.defAbstract i+ , conPathCons = PointCons , conComp = emptyCompKit -- filled in later , conProj = Nothing -- filled in later , conForced = []@@ -261,7 +282,7 @@ -- Andreas, 2020-01-28, issue #4360: -- Use addTypedInstance instead of addNamedInstance -- to detect unusable instances.- addTypedInstance conName contype+ addTypedInstance r conName contype -- addNamedInstance conName name NotInstanceDef -> pure () @@ -306,9 +327,9 @@ ] -} - let info = setRelevance recordRelevance defaultArgInfo- addRecordVar =- addRecordNameContext (setArgInfo info $ defaultDom rect)+ -- Make a note of what variable is the 'self' variable in the telescope.+ let info = setOrigin RecordSelf $ setRelevance recordRelevance defaultArgInfo+ addRecordVar = addRecordNameContext (setArgInfo info $ defaultDom rect) let m = qnameToMName name -- Name of record module. @@ -329,7 +350,7 @@ [ "record section:" , nest 2 $ sep [ prettyTCM m <+> (inTopContext . prettyTCM =<< getContextTelescope)- , fsep $ punctuate comma $ map (return . P.pretty . map argFromDom . getName) fields+ , fsep $ punctuate comma $ map' (return . P.pretty . map' argFromDom . getName) fields ] ] reportSDoc "tc.rec.def" 15 $ nest 2 $ vcat@@ -355,203 +376,22 @@ -- record type. -- See test/Succeed/ProjectionsTakeModuleTelAsParameters.agda. tel' <- do- r <- headWithDefault __IMPOSSIBLE__ <$> getContext- return $ contextToTel $ r : params- setModuleCheckpoint m+ r <- fromMaybe __IMPOSSIBLE__ . cxLookup 0 <$> getContext+ return $ contextToTel $ CxExtend r params+ cp <- viewTC eCurrentCheckpoint+ setModuleCheckpoint m cp checkRecordProjections m name hasNamedCon con tel' ftel fields -- we define composition here so that the projections are already in the signature. whenM cubicalCompatibleOption do escapeContext impossible npars do- addCompositionForRecord name haveEta con tel (map argFromDom fs) ftel rect+ addCompositionForRecord name haveEta con tel (map' argFromDom fs) ftel rect -- The confluence checker needs to know what symbols match against -- the constructor. modifySignature $ updateDefinition conName $ \def ->- def { defMatchable = Set.fromList $ map unDom fs }-- where- -- Andreas, 2020-04-19, issue #4560- -- If the user declared the record constructor as @pattern@,- -- then switch on pattern matching for no-eta-equality.- -- Default is no pattern matching, but definition by copatterns instead.- patCopat = maybe CopatternMatching (const PatternMatching) pat- eta = ((patCopat <$) . rangedThing) <$> eta0---addCompositionForRecord- :: QName -- ^ Datatype name.- -> EtaEquality- -> ConHead- -> Telescope -- ^ @Γ@ parameters.- -> [Arg QName] -- ^ Projection names.- -> Telescope -- ^ @Γ ⊢ Φ@ field types.- -> Type -- ^ @Γ ⊢ T@ target type.- -> TCM ()-addCompositionForRecord name eta con tel fs ftel rect = do- cxt <- getContextTelescope- inTopContext $ do-- -- Record has no fields: attach composition data to record constructor- if null fs then do- kit <- defineCompData name con (abstract cxt tel) [] ftel rect empty- modifySignature $ updateDefinition (conName con) $ updateTheDef $ \case- r@Constructor{} -> r { conComp = kit, conProj = Just [] } -- no projections- _ -> __IMPOSSIBLE__-- -- No-eta record with pattern matching (i.e., withOUT copattern- -- matching): define composition as for a data type, attach it to- -- the record.- else if theEtaEquality eta == NoEta PatternMatching then do- kit <- defineCompData name con (abstract cxt tel) (unArg <$> fs) ftel rect empty- modifySignature $ updateDefinition name $ updateTheDef $ \case- r@Record{} -> r { recComp = kit }- _ -> __IMPOSSIBLE__-- -- Record has fields: attach composition data to record type- else do- -- If record has irrelevant fields but irrelevant projections are disabled,- -- we cannot generate composition data.- kit <- ifM (return (any isIrrelevant fs)- `and2M` do not . optIrrelevantProjections <$> pragmaOptions)- {-then-} (return emptyCompKit)- {-else-} (defineCompKitR name (abstract cxt tel) ftel fs rect)- modifySignature $ updateDefinition name $ updateTheDef $ \case- r@Record{} -> r { recComp = kit }- _ -> __IMPOSSIBLE__--defineCompKitR ::- QName -- ^ some name, e.g. record name- -> Telescope -- ^ param types Δ- -> Telescope -- ^ fields' types Δ ⊢ Φ- -> [Arg QName] -- ^ fields' names- -> Type -- ^ record type Δ ⊢ T- -> TCM CompKit-defineCompKitR name params fsT fns rect = do- required <- mapM getTerm'- [ someBuiltin builtinInterval- , someBuiltin builtinIZero- , someBuiltin builtinIOne- , someBuiltin builtinIMin- , someBuiltin builtinIMax- , someBuiltin builtinINeg- , someBuiltin builtinPOr- , someBuiltin builtinItIsOne- ]- reportSDoc "tc.rec.cxt" 30 $ prettyTCM params- 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] (defineKanOperationR DoTransp name params fsT fns rect)- hcomp <- whenDefined [builtinTrans,builtinHComp] (defineKanOperationR DoHComp name params fsT fns rect)- return $ CompKit- { nameOfTransp = transp- , nameOfHComp = hcomp- }- where- whenDefined xs m = do- xs <- mapM getTerm' xs- if all isJust xs then m else return Nothing---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)-defineKanOperationR cmd name params fsT fns rect = do- let project = (\ t fn -> t `applyE` [Proj ProjSystem fn])- 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- c' <- do- io <- primIOne- Just io_name <- getBuiltinName' builtinIOne- one <- primItIsOne- tInterval <- primIntervalType- let- (ix,rhs) =- case cmd of- -- TranspRArgs = phi : I, a0 : ..- -- Γ = Δ^I , CompRArgs- -- pats = ... | phi = i1- -- body = a0- DoTransp -> (1,Var 0 [])- -- HCompRArgs = phi : I, u : .., a0 : ..- -- Γ = Δ, CompRArgs- -- pats = ... | phi = i1- -- body = u i1 itIsOne- DoHComp -> (2,Var 1 [] `apply` [argN io, setRelevance irrelevant $ argN one])-- p = ConP (ConHead io_name IsData Inductive [])- (noConPatternInfo { conPType = Just (Arg defaultArgInfo tInterval)- , conPFallThrough = True })- []-- -- gamma, rtype-- s = singletonS ix p-- pats :: [NamedArg DeBruijnPattern]- pats = s `applySubst` teleNamedArgs gamma-- t :: Type- t = s `applyPatSubst` rtype-- gamma' :: Telescope- gamma' = unflattenTel (ns0 ++ ns1) $ s `applyPatSubst` (g0 ++ g1)- where- (g0,_:g1) = splitAt (size gamma - 1 - ix) $ flattenTel gamma- (ns0,_:ns1) = splitAt (size gamma - 1 - ix) $ teleNames gamma-- c = Clause { clauseFullRange = noRange- , clauseLHSRange = noRange- , clauseTel = gamma'- , namedClausePats = pats- , clauseBody = Just $ rhs- , clauseType = Just $ argN t- , clauseCatchall = empty- , clauseRecursive = Just False -- definitely non-recursive!- , clauseUnreachable = Just False- , 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 { clauseFullRange = noRange- , clauseLHSRange = noRange- , clauseTel = gamma- , namedClausePats = pats- , clauseBody = Just body- , clauseType = Just $ argN (unDom clause_ty)- , clauseCatchall = empty- , clauseRecursive = Nothing- -- Andreas 2020-02-06 TODO- -- Or: Just False; is it known to be non-recursive?- , clauseUnreachable = Just False- , clauseEllipsis = NoEllipsis- , clauseWhereModule = Nothing- }- reportSDoc "trans.rec" 17 $ text $ show c- reportSDoc "trans.rec" 16 $ text "type =" <+> text (show (clauseType c))- reportSDoc "trans.rec" 15 $ prettyTCM $ abstract gamma (unDom clause_ty)- reportSDoc "trans.rec" 10 $ text "body =" <+> prettyTCM (abstract gamma body)- return c- addClauses theName $ c' : cs- reportSDoc "trans.rec" 15 $ text $ "compiling clauses for " ++ show theName- (mst, _, cc) <- inTopContext (compileClauses Nothing cs)- whenJust mst $ setSplitTree theName- setCompiledClauses theName cc- reportSDoc "trans.rec" 15 $ text $ "compiled"- return $ Just theName+ def { defMatchable = Set.fromList $ map' unDom fs } {-| @checkRecordProjections m r q tel ftel fs@.@@ -580,11 +420,12 @@ checkProjs _ _ _ [] = return () checkProjs ftel1 ftel2 vs (A.ScopedDecl scope fs' : fs) =- setScope scope >> checkProjs ftel1 ftel2 vs (fs' ++ fs)+ setScope scope >> checkProjs ftel1 ftel2 vs (List1.toList fs' ++! fs) -- Case: projection.- checkProjs ftel1 (ExtendTel (dom@Dom{domInfo = ai,unDom = t}) ftel2) vs (A.Field info x _ : fs) =+ checkProjs ftel1 (ExtendTel (dom@(unDom -> t)) ftel2) vs (A.Field info x _ : fs) = traceCall (CheckProjection (getRange info) x t) $ do+ let ai = dom ^. dInfo -- Andreas, 2012-06-07: -- Issue 387: It is wrong to just type check field types again -- because then meta variables are created again.@@ -598,37 +439,39 @@ ] -- Andreas, 2021-05-11, issue #5378 -- The impossible is sometimes possible, so splitting out this part...- reportSDoc "tc.rec.proj" 5 $ nest 2 $ vcat+ reportSDoc "tc.rec.proj.escapeContext" 45 $ nest 2 $ vcat [ "ftel1 =" <+> escapeContext impossible 1 (prettyTCM ftel1) , "t =" <+> escapeContext impossible 1 (addContext ftel1 $ prettyTCM t) , "ftel2 =" <+> escapeContext impossible 1 (addContext ftel1 $ underAbstraction dom ftel2 prettyTCM) ]+ reportSDoc "tc.rec.proj" 5 $ nest 2 $ vcat+ [ "ftel1 =" <+> unsafeEscapeContext 1 (prettyTCM ftel1)+ , "t =" <+> unsafeEscapeContext 1 (addContext ftel1 $ prettyTCM t)+ , "ftel2 =" <+> unsafeEscapeContext 1 (addContext ftel1 $ underAbstraction dom ftel2 prettyTCM)+ ] reportSDoc "tc.rec.proj" 55 $ nest 2 $ vcat [ "ftel1 (raw) =" <+> pretty ftel1 , "t (raw) =" <+> pretty t , "ftel2 (raw) =" <+> pretty ftel2 ] reportSDoc "tc.rec.proj" 5 $ nest 2 $ vcat- [ "vs =" <+> prettyList_ (map prettyTCM vs)+ [ "vs =" <+> prettyList_ (map' prettyTCM vs) , "abstr =" <+> (text . show) (Info.defAbstract info) , "quant =" <+> (text . show) (getQuantity ai) , "coh =" <+> (text . show) (getCohesion ai) ] - unless (getCohesion ai == Continuous) __IMPOSSIBLE__- -- Andreas, 2025-05-03, moved check to ConcreteToAbstract.checkFieldArgInfo.- -- -- Cohesion check:- -- -- For a field `@c π : A` we would create a projection `π : .., (@(c^-1) r : R as) -> A`- -- -- So we want to check that `@.., (c^-1 . c) x : A |- x : A` is allowed by the modalities.- -- --- -- -- Alternatively we could create a projection `.. |- π r :c A`- -- -- but that would require support for a `t :c A` judgment.- -- if hasLeftAdjoint (UnderComposition (getCohesion ai))- -- then unless (getCohesion ai == Continuous)- -- -- Atm, only Continuous has a left adjoint.- -- -- Andrea TODO: properly update the context/type of the projection when we add Sharp- -- __IMPOSSIBLE__- -- else typeError $ InvalidFieldModality (getCohesion ai)+ -- Cohesion check:+ -- For a field `@c π : A`, if c has a left adjoint, we create a projection+ -- `@(c^-1) π : .., (@(c^-1 . c) r : R as) -> A`+ -- So we want to check that `@.., (c^-1 . c) x : A |- x : A` is allowed by the modalities.+ --+ -- Currently only sharp and continuous have left adjoints under composition.+ -- This check happens at scope checking time, so we should only be left+ -- with annotations with left adjoints here+ tel <- if hasLeftAdjoint (UnderComposition (getCohesion ai))+ then pure $ over listTel (map' (inverseApplyCohesion (getCohesion ai))) tel+ else __IMPOSSIBLE__ -- For now, we forbid any polarity annotations on record fields (we would need to do as above, -- and eta-equality or projection existence would be in danger).@@ -658,7 +501,7 @@ -} let t' = raiseFrom (size ftel1) 1 t t'' = applySubst (parallelS vs) t'- finalt = telePi (replaceEmptyName "r" tel) t''+ finalt = telePi tel t'' projname = qualify m $ qnameName x projcall o = Var 0 [Proj o projname] rel = getRelevance ai@@ -699,14 +542,16 @@ -- split the telescope into parameters (ptel) and the type or the record -- (rt) which should be R ptel telList = telToList tel- (ptelList,[rt]) = splitAt (size tel - 1) telList+ (ptelList,[rt]) = splitAt' (size tel - 1) telList ptel = telFromList ptelList cpo = if hasNamedCon then PatOCon else PatORec cpi = ConPatternInfo { conPInfo = PatternInfo cpo [] , conPRecord = True , conPFallThrough = False , conPType = Just $ argFromDom $ fmap snd rt- , conPLazy = True }+ , conPLazy = True+ , conPPrio = empty+ } conp = defaultNamedArg $ ConP con cpi $ teleNamedArgs ftel body = Just $ bodyMod $ var (size ftel2) cltel = ptel `abstract` ftel@@ -718,7 +563,7 @@ , clauseBody = body , clauseType = cltype , clauseCatchall = empty- , clauseRecursive = Just False+ , clauseRecursive = NotRecursive , clauseUnreachable = Just False , clauseEllipsis = NoEllipsis , clauseWhereModule = Nothing@@ -732,7 +577,7 @@ -- index of the record argument (in the type), -- start counting with 1: , projIndex = size tel -- which is @size ptel + 1@- , projLams = ProjLams $ map (argFromDom . fmap fst) telList+ , projLams = ProjLams $ map' (argFromDom . fmap fst) telList } reportSDoc "tc.rec.proj" 70 $ sep@@ -778,7 +623,7 @@ , _funTerminates = Just True }) { defArgOccurrences = [StrictPos]- , defCopatternLHS = hasProjectionPatterns cc+ , defCopatternLHS' = hasProjectionPatterns cc } computePolarity [projname] @@ -787,8 +632,8 @@ -- local variable" (i.e. the type you'd get were you to open -- the record module), but this type has to be treated in the -- context ftel1 otherwise it's nonsense- InstanceDef _r -> addTypedInstance projname t- NotInstanceDef -> pure ()+ InstanceDef kwr -> addTypedInstance kwr projname t+ NotInstanceDef -> pure () recurse
+ src/full/Agda/TypeChecking/Rules/Record/Cubical.hs view
@@ -0,0 +1,208 @@+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE NondecreasingIndentation #-}++module Agda.TypeChecking.Rules.Record.Cubical+ ( addCompositionForRecord+ ) where++import Prelude hiding (null, not, (&&), (||))++import Control.Monad+import Data.Maybe++import Agda.Interaction.Options++import Agda.Syntax.Common+import Agda.Syntax.Internal+import Agda.Syntax.Position++import Agda.TypeChecking.Monad+import Agda.TypeChecking.Primitive+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.CompiledClause.Compile+import Agda.TypeChecking.Rules.Data (defineCompData, defineKanOperationForFields)++import Agda.Utils.Boolean+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.Impossible+import Agda.Utils.Size+++addCompositionForRecord+ :: QName -- ^ Datatype name.+ -> EtaEquality+ -> ConHead+ -> Telescope -- ^ @Γ@ parameters.+ -> [Arg QName] -- ^ Projection names.+ -> Telescope -- ^ @Γ ⊢ Φ@ field types.+ -> Type -- ^ @Γ ⊢ T@ target type.+ -> TCM ()+addCompositionForRecord name eta con tel fs ftel rect = do+ cxt <- getContextTelescope+ inTopContext $ do++ -- Record has no fields: attach composition data to record constructor+ if null fs then do+ kit <- defineCompData name con (abstract cxt tel) [] ftel rect empty+ modifySignature $ updateDefinition (conName con) $ updateTheDef $ \case+ r@Constructor{} -> r { conComp = kit, conProj = Just [] } -- no projections+ _ -> __IMPOSSIBLE__++ -- No-eta record with pattern matching (i.e., withOUT copattern+ -- matching): define composition as for a data type, attach it to+ -- the record.+ else if theEtaEquality eta == NoEta PatternMatching then do+ kit <- defineCompData name con (abstract cxt tel) (unArg <$> fs) ftel rect empty+ modifySignature $ updateDefinition name $ updateTheDef $ \case+ r@Record{} -> r { recComp = kit }+ _ -> __IMPOSSIBLE__++ -- Record has fields: attach composition data to record type+ else do+ -- If record has irrelevant fields but irrelevant projections are disabled,+ -- we cannot generate composition data.+ kit <- ifM (return (any isIrrelevant fs)+ `and2M` do not . optIrrelevantProjections <$> pragmaOptions)+ {-then-} (return emptyCompKit)+ {-else-} (defineCompKitR name (abstract cxt tel) ftel fs rect)+ modifySignature $ updateDefinition name $ updateTheDef $ \case+ r@Record{} -> r { recComp = kit }+ _ -> __IMPOSSIBLE__+++defineCompKitR ::+ QName -- ^ some name, e.g. record name+ -> Telescope -- ^ param types Δ+ -> Telescope -- ^ fields' types Δ ⊢ Φ+ -> [Arg QName] -- ^ fields' names+ -> Type -- ^ record type Δ ⊢ T+ -> TCM CompKit+defineCompKitR name params fsT fns rect = do+ required <- mapM getTerm'+ [ someBuiltin builtinInterval+ , someBuiltin builtinIZero+ , someBuiltin builtinIOne+ , someBuiltin builtinIMin+ , someBuiltin builtinIMax+ , someBuiltin builtinINeg+ , someBuiltin builtinPOr+ , someBuiltin builtinItIsOne+ ]+ reportSDoc "tc.rec.cxt" 30 $ prettyTCM params+ 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] (defineKanOperationR DoTransp name params fsT fns rect)+ hcomp <- whenDefined [builtinTrans,builtinHComp] (defineKanOperationR DoHComp name params fsT fns rect)+ return $ CompKit+ { nameOfTransp = transp+ , nameOfHComp = hcomp+ }+ where+ whenDefined xs m = do+ xs <- mapM getTerm' xs+ if all isJust xs then m else return Nothing+++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)+defineKanOperationR cmd name params fsT fns rect = do+ let project = (\ t fn -> t `applyE` [Proj ProjSystem fn])+ 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+ c' <- do+ io <- primIOne+ Just io_name <- getBuiltinName' builtinIOne+ one <- primItIsOne+ tInterval <- primIntervalType+ let+ (ix,rhs) =+ case cmd of+ -- TranspRArgs = phi : I, a0 : ..+ -- Γ = Δ^I , CompRArgs+ -- pats = ... | phi = i1+ -- body = a0+ DoTransp -> (1,Var 0 [])+ -- HCompRArgs = phi : I, u : .., a0 : ..+ -- Γ = Δ, CompRArgs+ -- pats = ... | phi = i1+ -- body = u i1 itIsOne+ DoHComp -> (2,Var 1 [] `apply` [argN io, setRelevance irrelevant $ argN one])++ p = ConP (ConHead io_name IsData Inductive NotHIT [])+ (noConPatternInfo { conPType = Just (Arg defaultArgInfo tInterval)+ , conPFallThrough = True })+ []++ -- gamma, rtype++ s = singletonS ix p++ pats :: [NamedArg DeBruijnPattern]+ pats = s `applySubst` teleNamedArgs gamma++ t :: Type+ t = s `applyPatSubst` rtype++ gamma' :: Telescope+ gamma' = unflattenTel (ns0 ++ ns1) $ s `applyPatSubst` (g0 ++ g1)+ where+ (g0,_:g1) = splitAt (size gamma - 1 - ix) $ flattenTel gamma+ (ns0,_:ns1) = splitAt (size gamma - 1 - ix) $ teleNames gamma++ c = Clause { clauseFullRange = noRange+ , clauseLHSRange = noRange+ , clauseTel = gamma'+ , namedClausePats = pats+ , clauseBody = Just $ rhs+ , clauseType = Just $ argN t+ , clauseCatchall = empty+ , clauseRecursive = NotRecursive -- definitely non-recursive!+ , clauseUnreachable = Just False+ , 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 { clauseFullRange = noRange+ , clauseLHSRange = noRange+ , clauseTel = gamma+ , namedClausePats = pats+ , clauseBody = Just body+ , clauseType = Just $ argN (unDom clause_ty)+ , clauseCatchall = empty+ , clauseRecursive = MaybeRecursive+ -- Andreas 2020-02-06 TODO+ -- Or: NotRecursive; is it known to be non-recursive?+ , clauseUnreachable = Just False+ , clauseEllipsis = NoEllipsis+ , clauseWhereModule = Nothing+ }+ reportSDoc "trans.rec" 17 $ text $ show c+ reportSDoc "trans.rec" 16 $ text "type =" <+> text (show (clauseType c))+ reportSDoc "trans.rec" 15 $ prettyTCM $ abstract gamma (unDom clause_ty)+ reportSDoc "trans.rec" 10 $ text "body =" <+> prettyTCM (abstract gamma body)+ return c+ addClauses theName $ c' : cs+ reportSDoc "trans.rec" 15 $ text $ "compiling clauses for " ++ show theName+ (mst, _, cc) <- inTopContext (compileClauses Nothing cs)+ whenJust mst $ setSplitTree theName+ setCompiledClauses theName cc+ reportSDoc "trans.rec" 15 $ text $ "compiled"+ return $ Just theName
src/full/Agda/TypeChecking/Rules/Term.hs view
@@ -5,8 +5,10 @@ import Prelude hiding ( null ) import Control.Monad.Except ( MonadError(..) )+import Control.Monad.Trans.Maybe ( runMaybeT ) import Data.Maybe+import qualified Data.DList as DL import Data.Either (partitionEithers, lefts) import qualified Data.List as List import qualified Data.Map as Map@@ -15,7 +17,7 @@ import Agda.Interaction.Options import Agda.Interaction.Highlighting.Generate (disambiguateRecordFields) -import Agda.Syntax.Abstract (Binder, TypedBindingInfo (tbTacticAttr))+import Agda.Syntax.Abstract (Binder, TypedBindingInfo (tbTacticAttr), unBind, binderName) import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Abstract.Views as A import qualified Agda.Syntax.Info as A@@ -29,7 +31,7 @@ import Agda.Syntax.Internal.MetaVars import Agda.Syntax.Position import Agda.Syntax.Literal-import Agda.Syntax.Scope.Base ( ThingsInScope, AbstractName+import Agda.Syntax.Scope.Base ( ThingsInScope , emptyScopeInfo , exportedNamesInScope) import Agda.Syntax.Scope.Monad (getNamedScope)@@ -56,7 +58,9 @@ import Agda.TypeChecking.RecordPatterns import Agda.TypeChecking.Records import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Rewriting (checkEquationValid, checkLocalRewriteRule) import Agda.TypeChecking.Rules.LHS+import Agda.TypeChecking.Rules.LHS.Problem import Agda.TypeChecking.SizedTypes import Agda.TypeChecking.SizedTypes.Solve import Agda.TypeChecking.Sort@@ -73,6 +77,7 @@ import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.Lens+import Agda.Utils.List import Agda.Utils.List1 ( List1, pattern (:|) ) import Agda.Utils.List2 ( pattern List2 ) import qualified Agda.Utils.List1 as List1@@ -85,6 +90,7 @@ import Agda.Utils.Tuple import Agda.Utils.Impossible+import Agda.Utils.Boolean (implies) --------------------------------------------------------------------------- -- * Types@@ -111,22 +117,23 @@ , nest 2 $ "returns" <?> prettyTCM a ]) $ do let fallback = isType' CmpEq e =<< do workOnTypes $ newSortMeta- SortKit{..} <- sortKit+ SortKit{ isNameOfUniv } <- sortKit case unScope e of A.Fun i (Arg info t) b -> do- a <- setArgInfo info . defaultDom <$> checkPiDomain (info :| []) t+ a <- uncurry (defaultArgDomRew info) <$>+ checkPiDomain Nothing (info :| []) t b <- isType_ b- s <- inferFunSort a (getSort b)+ s <- inferFunSort a b let t' = El s $ Pi a $ NoAbs underscore b- checkTelePiSort t'+ hasPTSRule a (NoAbs underscore $ getSort b) --noFunctionsIntoSize t' return t' A.Pi _ tel e -> do (t0, t') <- checkPiTelescope (List1.toList tel) $ \ tel -> do t0 <- instantiateFull =<< isType_ e tel <- instantiateFull tel+ checkTelePiSort tel (getSort t0) return (t0, telePi tel t0)- checkTelePiSort t' --noFunctionsIntoSize t' return t' @@ -163,19 +170,19 @@ reportSDoc "tc.ip" 20 $ fsep [ "Rechecking meta " , prettyTCM x- , text $ " for interaction point " ++ show ii+ , text $ " for interaction point " ++! show ii ] mv <- lookupLocalMeta x let s0 = jMetaType . mvJudgement $ mv -- Andreas, 2016-10-14, issue #2257 -- The meta was created in a context of length @n@.- let n = length . envContext . clEnv . miClosRange . mvInfo $ mv- (vs, rest) <- splitAt n <$> getContextArgs+ let n = length . view eContext . clEnv . miClosRange . mvInfo $ mv+ (vs, rest) <- splitAt' n <$> getContextArgs - let oldCxtNames = map nameCanonical $ contextNames' $ envContext+ let oldCxtNames = map' nameCanonical $ contextNames' $ view eContext $ clEnv $ miClosRange $ mvInfo $ mv - newCxtNames <- map nameCanonical <$> getContextNames'+ newCxtNames <- map' nameCanonical <$> getContextNames' reportSDoc "tc.ip" 20 $ vcat [ " s0 = " <+> prettyTCM s0@@ -195,7 +202,7 @@ [ " s1 = " <+> text (show s1) ] case unEl s1 of- Sort s -> return $ El s $ MetaV x $ map Apply vs+ Sort s -> return $! El s $! MetaV x $! map' Apply vs _ -> __IMPOSSIBLE__ _ -> fallback@@ -246,24 +253,33 @@ -- * Telescopes --------------------------------------------------------------------------- +-- | We track whether a module telescope came from a data declaration because+-- data telescopes cannot contain tactic arguments (because they result+-- in slightly weird behaviour w.r.t. checking parameters of constructors+-- are fully general)+data ModTelOrigin = ModTelData | ModTelNotData+ deriving (Eq, Show)+ checkGeneralizeTelescope ::- Maybe ModuleName+ ModTelOrigin+ -- ^ Origin of telescope (i.e. if it came from a data declaration)+ -> Maybe ModuleName -- ^ The module the telescope belongs to (if any). -> A.GeneralizeTelescope -- ^ Telescope to check and add to the context for the continuation. -> ([Maybe Name] -> Telescope -> TCM a) -- ^ Continuation living in the extended context. -> TCM a-checkGeneralizeTelescope mm (A.GeneralizeTel vars tel) =- tr (generalizeTelescope vars (checkTelescope tel) . curry) . uncurry+checkGeneralizeTelescope o mm (A.GeneralizeTel vars tel) =+ tr (generalizeTelescope vars (checkTelescope o tel) . curry) . uncurry where tr = applyUnless (null tel) $ applyWhenJust mm $ \ m -> traceCallCPS $ CheckModuleParameters m tel -- | Type check a (module) telescope. -- Binds the variables defined by the telescope.-checkTelescope :: A.Telescope -> (Telescope -> TCM a) -> TCM a-checkTelescope = checkTelescope' LamNotPi+checkTelescope :: ModTelOrigin -> A.Telescope -> (Telescope -> TCM a) -> TCM a+checkTelescope o = checkTelescope' (LamNotPi o) -- | Type check the telescope of a dependent function type. -- Binds the resurrected variables defined by the telescope.@@ -273,13 +289,15 @@ -- | Flag to control resurrection on domains. data LamOrPi- = LamNotPi -- ^ We are checking a module telescope.- -- We pass into the type world to check the domain type.- -- This resurrects the whole context.- | PiNotLam -- ^ We are checking a telescope in a Pi-type.- -- We stay in the term world, but add resurrected- -- domains to the context to check the remaining- -- domains and codomain of the Pi-type.+ = LamNotPi ModTelOrigin+ -- ^ We are checking a module telescope.+ -- We pass into the type world to check the domain type.+ -- This resurrects the whole context.+ | PiNotLam+ -- ^ We are checking a telescope in a Pi-type.+ -- We stay in the term world, but add resurrected+ -- domains to the context to check the remaining+ -- domains and codomain of the Pi-type. deriving (Eq, Show) -- | Type check a telescope. Binds the variables defined by the telescope.@@ -292,9 +310,11 @@ -- | Check the domain of a function type. -- Used in @checkTypedBindings@ and to typecheck @A.Fun@ cases.-checkDomain :: (LensLock a, LensModality a) => LamOrPi -> List1 a -> A.Expr -> TCM Type-checkDomain lamOrPi xs e = do- -- Get cohesion and quantity of arguments, which should all be equal because+checkDomain :: (LensLock a, LensModality a, LensRewriteAnn a, LensRelevance a)+ => LamOrPi -> Maybe Name -> List1 a -> A.Expr -> TCM (Maybe RewDom, Type)+checkDomain lamOrPi n xs e = do+ -- Get cohesion and quantity of arguments, as well as if they are local+ -- rewrite rules. All of these properties should all be equal because -- they come from the same annotated Π-type. let (c :| cs) = fmap (getCohesion . getModality) xs unless (all (c ==) cs) $ __IMPOSSIBLE__@@ -302,6 +322,14 @@ let (q :| qs) = fmap (getQuantity . getModality) xs unless (all (q ==) qs) $ __IMPOSSIBLE__ + let (r :| rs) = fmap (getRewriteAnn) xs+ unless (all (r ==) rs) $ __IMPOSSIBLE__++ checkAllIrrelevanceAllowed xs++ -- Also get whether the domain is a local rewrite rule. If it is, and there+ -- are multiple arguments, we warn that this is unnecessary+ t <- applyQuantityToJudgement q $ applyCohesionToContext c $ applyWhenM (optPolarity <$> pragmaOptions) (applyPolarityToContext negativePolarity) $@@ -314,16 +342,41 @@ equalSort (getSort t) LockUniv - return t+ cxt <- getContext+ let s = LocalRewrite cxt n t++ -- For now, we disallow '@rewrite' domains on pi types+ -- In the future, this should be allowed only when the pi type is not in+ -- higher-order position (checked syntactically)+ r <- case lamOrPi of+ PiNotLam | isRewrite r -> IsNotRewrite <$+ runMaybeT (illegalRule s LocalRewriteOutsideTelescope)+ _ -> pure r++ eq <- checkEquationValid s r t+ rew <- traverse (checkLocalRewriteRule s) eq+ -- We do not (currently) distinguish failing to elaborate to a LocalEquation+ -- from failing to elaborate to a RewriteRule. In the case we have+ -- a valid LocalEquation, but failed to produce a RewriteRule, we could+ -- technically still store the LocalEquation and check the convertibility+ -- constraint at call sites. I don't think this is super important, but+ -- maybe worth trying in future.+ let rDom = RewDom <$> eq <*> fmap pure (join rew)+ whenJust rDom \rDom' -> reportSDoc "rewriting" 30 $+ "Successfully elaborated: " <+> prettyTCM (rewDomEq rDom') <+>+ " into a rewrite rule"++ return (rDom, t) where -- if we are checking a typed lambda, we resurrect before we check the -- types, but do not modify the new context entries -- otherwise, if we are checking a pi, we do not resurrect, but -- modify the new context entries- modEnv LamNotPi = workOnTypes- modEnv _ = id+ modEnv (LamNotPi _) = workOnTypes+ modEnv PiNotLam = id -checkPiDomain :: (LensLock a, LensModality a) => List1 a -> A.Expr -> TCM Type+checkPiDomain :: (LensLock a, LensModality a, LensRewriteAnn a, LensRelevance a)+ => Maybe Name -> List1 a -> A.Expr -> TCM (Maybe RewDom, Type) checkPiDomain = checkDomain PiNotLam -- | Check a typed binding and extends the context with the bound variables.@@ -335,14 +388,18 @@ 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) $ theTacticAttribute $ tbTacticAttr tac+ tac <- traverse (checkTacticAttribute lamOrPi) $+ theTacticAttribute $ 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 -- 2011-10-04 if flag --experimental-irrelevance is set experimental <- optExperimentalIrrelevance <$> pragmaOptions - t <- checkDomain lamOrPi xps e+ -- We pick one of the names to report local rewrite errors on+ let x = unBind $ binderName $ namedArg $ List1.head xps+ (rew, t) <- checkDomain lamOrPi (Just x) xps e+ whenJust rew $ \r -> reportSDoc "rewriting" 30 $ "Checked local rewrite:" <+> prettyTCM (rewDomEq r) -- Jesper, 2019-02-12, Issue #3534: warn if the type of an -- instance argument does not have the right shape@@ -357,10 +414,18 @@ NoOutputTypeName -> setCurrentRange e $ warning . InstanceNoOutputTypeName =<< prettyTCM (A.mkTBind r ixs e) - let setTac tac EmptyTel = EmptyTel- setTac tac (ExtendTel dom tel) = ExtendTel dom{ domTactic = tac } $ setTac (raise 1 tac) <$> tel- xs' = fmap (modMod lamOrPi experimental) xs- let tel = setTac tac $ namedBindsToTel1 xs t+ let setTacRew tac rew dom = dom & dTactic .~ tac & dRew .~ rew+ setTacRewTel tac rew EmptyTel = EmptyTel+ setTacRewTel tac rew (ExtendTel dom tel) =+ ExtendTel (setTacRew tac rew dom) $+ setTacRewTel (raise 1 tac) (raise 1 rew) <$> tel+ -- We need to convert to Dom and set the domTactic and domRew fields+ -- here in order to not drop @tactic and @rewrite annotations+ xs' = setTacRew tac rew+ . domNameFromNamedArgName+ . modMod lamOrPi experimental+ <$> xs+ let tel = setTacRewTel tac rew $ namedBindsToTel1 xs t addContext (xs', t) $ addTypedPatterns xps (ret tel) @@ -369,11 +434,10 @@ -- types, but do not modify the new context entries -- otherwise, if we are checking a pi, we do not resurrect, but -- modify the new context entries- modEnv LamNotPi = workOnTypes- modEnv _ = id- modMod PiNotLam xp = inverseApplyPolarity (withStandardLock UnusedPolarity)- . applyWhen xp (mapRelevance irrelevantToShapeIrrelevant)- modMod _ _ = id+ modMod PiNotLam xp =+ inverseApplyPolarity (withStandardLock UnusedPolarity) .+ applyWhen xp (mapRelevance irrelevantToShapeIrrelevant)+ modMod (LamNotPi _) _ = id checkTypedBindings lamOrPi (A.TLet _ lbs) ret = do checkLetBindings lbs (ret EmptyTel)@@ -383,19 +447,19 @@ addTypedPatterns xps ret = do let ps = List1.mapMaybe (A.extractPattern . namedArg) xps- lbs = map letBinding ps+ lbs = map' letBinding ps letBinding :: (A.Pattern, A.BindName) -> A.LetBinding- letBinding (p, n) = A.LetPatBind (A.LetRange r) p (A.Var $ A.unBind n)+ letBinding (p, n) = A.LetPatBind (A.LetRange r) defaultArgInfo p (A.Var $ A.unBind n) where r = fuseRange p n checkLetBindings' lbs ret -- | Check a tactic attribute. Should have type Term → TC ⊤. checkTacticAttribute :: LamOrPi -> Ranged A.Expr -> TCM Term-checkTacticAttribute LamNotPi (Ranged r e) = setCurrentRange r $+checkTacticAttribute (LamNotPi ModTelData) (Ranged r e) = setCurrentRange r $ typeError $ TacticAttributeNotAllowed-checkTacticAttribute PiNotLam (Ranged r e) = do+checkTacticAttribute _ (Ranged r e) = do expectedType <- el primAgdaTerm --> el (primAgdaTCM <#> primLevelZero <@> primUnit) checkExpr e expectedType @@ -461,7 +525,7 @@ -> Range -- ^ Range @r@ of the typed binding -> A.TypedBindingInfo -- ^ @tac@ tactic/finiteness attribute of the typed binding -> List1 (NamedArg Binder) -- ^ @xps@ variables/patterns of the typed binding- -> A.Type -- ^ @typ@ Type of the typed binding+ -> A.Type -- ^ @typ@ Type of the typed binding (underscore for untyped lambda). -> A.Expr -- ^ @body@ -> Type -- ^ @target@ -> TCM Term@@ -471,30 +535,38 @@ , "possiblePath =" <+> prettyTCM possiblePath , "numbinds =" <+> prettyTCM numbinds , "typ =" <+> prettyA (unScope typ)+ , "target =" <+> prettyTCM target , "tactic =" <+> prettyA (tbTacticAttr tac) ] reportSDoc "tc.term.lambda" 60 $ vcat [ "info =" <+> (text . show) info ] + checkAllIrrelevanceAllowed xs+ -- Consume @tac@: case tac of _ | null tac -> pure ()- A.TypedBindingInfo{ tbTacticAttr = TacticAttribute (Just tactic) } -> do+ A.TypedBindingInfo{ tbTacticAttr = TacticAttribute (Just (Ranged r e)) } -> do -- Andreas, 2024-02-22, issue #6783 -- Error out if user supplied a tactic (rather than dropping it silently).- _tactic <- checkTacticAttribute LamNotPi tactic- -- We should not survive this check...- __IMPOSSIBLE__+ setCurrentRange r $ typeError $ TacticAttributeNotAllowed _ -> __IMPOSSIBLE__ TelV tel btyp <- telViewUpTo numbinds target+ reportSDoc "tc.term.lambda" 30 $ vcat+ [ "tel =" <+> prettyTCM tel+ , "btyp =" <+> prettyTCM btyp+ ] if numbinds == 1 && not (null tel) then useTargetType tel btyp else if possiblePath then trySeeingIfPath- else dontUseTargetType-+ else dontUseTargetType =<< do pure (null tel) `and2M` (isJust <$> isBlocked btyp)+ -- If either @tel@ is not @null@ or @btyp@ is not blocked, then @target@ is not blocked,+ -- so we have nothing to block on, and cannot permit @dontUseTargetType@ to postpone.+ -- This happens e.g. in ill-typed cases like @(\ x -> x) : Nat@. where b = A.TBind r tac xps typ+ xs :: List1 (NamedArg Name) xs = fmap (updateNamedArg (A.unBind . A.binderName)) xps numbinds = length xps possiblePath = numbinds == 1 && isUnderscore (unScope typ)@@ -502,23 +574,46 @@ info = getArgInfo $ List1.head xs trySeeingIfPath = do- reportSLn "tc.term.lambda" 60 $ "trySeeingIfPath for " ++ show xps+ reportSLn "tc.term.lambda" 60 $ "trySeeingIfPath for " ++! show xps let postpone' blocker tgt =- ifM (isNothing <$> cubicalOption) {-then-} dontUseTargetType {-else-} $ postpone blocker tgt+ ifM (isNothing <$> cubicalOption) {-then-} (dontUseTargetType True) {-else-} $ postpone blocker tgt ifBlocked target postpone' $ \ _ t -> do- ifNotM (isPathType <$> pathView t) dontUseTargetType {-else-} do+ ifNotM (isPathType <$> pathView t) (dontUseTargetType False) {-else-} do -- Note that --cubical is on here since we returned from 'pathView'. checkPath (List1.head xps) typ body t + postpone_ = postponeTypeCheckingProblem_ $+ CheckExpr cmp (A.Lam A.exprNoRange (A.DomainFull b) body) target+ postpone blocker tgt = flip postponeTypeCheckingProblem blocker $ CheckExpr cmp (A.Lam A.exprNoRange (A.DomainFull b) body) tgt - dontUseTargetType = do+ -- Andreas, 2025-08-08.+ -- In case the target type does not resolve to a Pi,+ -- we construct a Pi-type from the yet unchecked type @typ@ of the domain(s)+ -- (which is underscore for an untyped lambda).+ -- This strategy is hazardous in various situations:+ --+ -- - We might be missing implicit lambdas that should precede the given lambda.+ --+ -- - If no modality is given at the lambda, we might commit to the default one+ -- which then might turn out to be the wrong one as more information surfaces.+ -- Unfortunately, we do not have modality metas otherwise we could postpone+ -- the decision.+ --+ -- To fix #7001, we could check whether the user has supplied the relevant modalities+ -- (depending on which language flags are on), and refuse to progress if they are missing.+ dontUseTargetType mayPostpone = ifM (pure mayPostpone `and2M` userOmittedModalities xs) postpone_ {-else-} do -- Checking λ (xs : argsT) → body : target verboseS "tc.term.lambda" 5 $ tick "lambda-no-target-type" - -- First check that argsT is a valid type+ -- First check that argsT is a valid type or create a meta for it. argsT <- workOnTypes $ isType_ typ+ -- Andreas, 2025-08-08, issue #7001:+ -- If the user has not written explicitly a modality for the lambda-bound variable,+ -- the default modality is used which might not be correct.+ -- As a consequence, the speculated function type created by @telePi tel@ below+ -- may have the wrong modality. let tel = namedBindsToTel1 xs argsT reportSDoc "tc.term.lambda" 30 $ "dontUseTargetType tel =" <+> pretty tel @@ -559,7 +654,7 @@ useTargetType tel@(ExtendTel dom (Abs y EmptyTel)) btyp = do verboseS "tc.term.lambda" 5 $ tick "lambda-with-target-type"- reportSLn "tc.term.lambda" 30 $ "useTargetType y = " ++ y+ reportSLn "tc.term.lambda" 30 $ "useTargetType y = " ++! y let (x :| []) = xs unless (sameHiding dom info) $ typeError $ WrongHidingInLambda target@@ -586,11 +681,37 @@ useTargetType _ _ = __IMPOSSIBLE__ +userOmittedModalities :: List1 (NamedArg Name) -> TCM Bool+userOmittedModalities xs = do+ (optErasure <$> pragmaOptions) `and2M` pure (any (null . getQuantity) xs)+-- TODO: extend to modalities beyond erasure.+-- userOmittedModalities :: List1 (NamedArg Name) -> TCM Bool+-- userOmittedModalities xs = do+-- erasure <- optErasure <$> pragmaOptions+-- -- polarity <- optPolarity <$> pragmaOptions+-- return $ flip any xs \ x -> or+-- [ erasure && null (getQuantity x)+-- -- TODO: ModalPolarity does not have a concept of default yet.+-- -- , polarity && null (getPolarityMod x)+-- -- TODO: a means for the user to tell they are serious about irrelevance,+-- -- e.g. flag --irrelevance.+-- -- Otherwise too many regressions.+-- -- , null $ getRelevance x+-- -- TODO: Cohesion and Annotation do not have a concept of default yet.+-- ]+ -- | Check that modality info in lambda is compatible with modality -- coming from the function type. -- If lambda has no user-given modality, copy that of function type.-lambdaModalityCheck :: (LensAnnotation dom, LensModality dom) => dom -> ArgInfo -> TCM ArgInfo-lambdaModalityCheck dom = lambdaAnnotationCheck (getAnnotation dom) <=< lambdaPolarityCheck m <=< lambdaCohesionCheck m <=< lambdaQuantityCheck m <=< lambdaIrrelevanceCheck m+lambdaModalityCheck ::+ (LensAnnotation dom, LensModality dom)+ => dom -> ArgInfo -> TCM ArgInfo+lambdaModalityCheck dom =+ lambdaAnnotationCheck (getAnnotation dom) <=<+ lambdaPolarityCheck m <=<+ lambdaCohesionCheck m <=<+ lambdaQuantityCheck m <=<+ lambdaIrrelevanceCheck m where m = getModality dom -- | Check that irrelevance info in lambda is compatible with irrelevance@@ -599,7 +720,7 @@ lambdaIrrelevanceCheck :: LensRelevance dom => dom -> ArgInfo -> TCM ArgInfo lambdaIrrelevanceCheck dom info -- Case: no specific user annotation: use relevance of function type- | getRelevance info == defaultRelevance = return $ setRelevance (getRelevance dom) info+ | getRelevance info == defaultRelevance = return $! setRelevance (getRelevance dom) info -- Case: explicit user annotation is taken seriously | otherwise = do let rPi = getRelevance dom -- relevance of function type@@ -614,7 +735,7 @@ lambdaQuantityCheck :: LensQuantity dom => dom -> ArgInfo -> TCM ArgInfo lambdaQuantityCheck dom info -- Case: no specific user annotation: use quantity of function type- | noUserQuantity info = return $ setQuantity (getQuantity dom) info+ | noUserQuantity info = return $! setQuantity (getQuantity dom) info -- Case: explicit user annotation is taken seriously | otherwise = do let qPi = getQuantity dom -- quantity of function type@@ -626,7 +747,7 @@ lambdaAnnotationCheck :: LensAnnotation dom => dom -> ArgInfo -> TCM ArgInfo lambdaAnnotationCheck dom info -- Case: no specific user annotation: use annotation of function type- | getAnnotation info == defaultAnnotation = return $ setAnnotation (getAnnotation dom) info+ | getAnnotation info == defaultAnnotation = return $! setAnnotation (getAnnotation dom) info -- Case: explicit user annotation is taken seriously | otherwise = do let aPi = getAnnotation dom -- annotation of function type@@ -641,7 +762,7 @@ lambdaCohesionCheck :: LensCohesion dom => dom -> ArgInfo -> TCM ArgInfo lambdaCohesionCheck dom info -- Case: no specific user annotation: use cohesion of function type- | getCohesion info == defaultCohesion = return $ setCohesion (getCohesion dom) info+ | getCohesion info == defaultCohesion = return $! setCohesion (getCohesion dom) info -- Case: explicit user annotation is taken seriously | otherwise = do let cPi = getCohesion dom -- cohesion of function type@@ -658,7 +779,7 @@ lambdaPolarityCheck :: LensModalPolarity dom => dom -> ArgInfo -> TCM ArgInfo lambdaPolarityCheck dom info -- Case: no specific user annotation: use polarity of function type- | getModalPolarity info == defaultPolarity = return $ setModalPolarity (getModalPolarity dom) info+ | getModalPolarity info == defaultPolarity = return $! setModalPolarity (getModalPolarity dom) info -- Case: explicit user annotation is taken seriously | otherwise = do let cPi = getModalPolarity dom -- polarity of function type@@ -754,15 +875,17 @@ t <- instantiateFull t ifBlocked t (\ blocker t' -> postponeTypeCheckingProblem (CheckExpr cmp e t') blocker) $ \ _ t' -> do case unEl t' of- Pi dom@(Dom{domInfo = info', unDom = a}) b- | not (sameHiding h info') -> typeError $ WrongHidingInLambda t'- | otherwise -> blockTerm t' $ do- ensureEmptyType (getRange i) a+ Pi a b -> do+ let info' = a ^. dInfo+ if not (sameHiding h info') then+ typeError $ WrongHidingInLambda t'+ else blockTerm t' $ do+ checkAbsurdPattern (Absurd (getRange i) a) -- Add helper function- aux <- makeAbsurdLambda (getRange i) dom b+ aux <- makeAbsurdLambda (getRange i) a b -- Andreas 2012-01-30: since aux is lifted to toplevel -- it needs to be applied to the current telescope (issue 557)- Def aux . map Apply . teleArgs <$> getContextTelescope+ Def aux . map' Apply . teleArgs <$> getContextTelescope _ -> typeError $ ShouldBePi t' -- Create an absurd lambda with the given type.@@ -797,7 +920,7 @@ , clauseBody = Nothing , clauseType = Just $ setModality mod $ defaultArg $ absBody b , clauseCatchall = YesCatchall empty -- absurd clauses are safe as catch-alls- , clauseRecursive = Just False+ , clauseRecursive = NotRecursive , clauseUnreachable = Just True -- absurd clauses are unreachable , clauseEllipsis = NoEllipsis , clauseWhereModule = Nothing@@ -858,12 +981,12 @@ useTerPragma $ (defaultDefn info qname t lang fun) { defMutual = j }- checkFunDef' t info (Just $ ExtLamInfo lamMod False empty) Nothing di qname $+ checkFunDef' t info (Just $ ExtLamInfo lamMod False empty) di qname $ List1.toList cs- whenNothingM (asksTC envMutualBlock) $+ whenNothingM (viewTC eMutualBlock) $ -- Andrea 10-03-2018: Should other checks be performed here too? e.g. termination/positivity/.. checkIApplyConfluence_ qname- return $ Def qname $ map Apply args+ return $! Def qname $! map' Apply args where -- Concrete definitions cannot use information about abstract things. abstract ConcreteDef = inConcreteMode@@ -900,12 +1023,13 @@ -- Get the blocker responsible for the type error. -- If we do not find a blocker or the error should not be handled, -- we reraise the error.- blocker <- maybe reraise return $ case err of+ blocker <- maybe reraise return $! case err of TypeError _ s cl -> case clValue cl of SortOfSplitVarError b _ -> b SplitError (UnificationStuck b c tel us vs _) -> b SplitError (BlockedType b aClosure) -> Just b CannotEliminateWithPattern b p a -> b+ CannotEliminateWithProjection b _ _ _ -> b -- Andrea: TODO look for blocking meta in tClosure and its Sort. -- SplitError (CannotCreateMissingClause _ _ _ tClosure) -> _ -> Nothing@@ -942,7 +1066,7 @@ Just Left{} -> return alwaysUnblock Just (Right m) | InstV{} <- mvInstantiation m -> return alwaysUnblock- | otherwise -> return $ unblockOnMeta x+ | 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)@@ -963,7 +1087,7 @@ -- The fields of the record that have not been given by field assignments @fs@ -- are looked up in the given modules @ms@.- fs' <- forM (xs List.\\ map (view nameFieldA) fs) $ \ f -> do+ fs' <- forM (xs List.\\ map' (view nameFieldA) fs) $ \ f -> do -- Get the possible assignments for field f from the modules. pms <- forM ms $ \ m -> do@@ -980,7 +1104,7 @@ [] -> return Nothing [(_, fa)] -> return (Just fa) x:y:zs -> typeError $ AmbiguousField f $ fmap fst $ List2 x y zs- return (fs ++ catMaybes fs')+ return (fs ++! catMaybes fs') -- | @checkRecordExpression fs e t@ checks record construction against type @t@. -- Precondition @e = Rec _ fs@.@@ -996,18 +1120,19 @@ [ "checking record expression" , prettyA e ]- ifBlocked t (\ _ t -> guessRecordType t) {-else-} $ \ _ t -> do+ let fields = [ x | Left (FieldAssignment x _) <- mfs ]+ ifBlocked t (\ _ t -> guessRecordType cmp e fields t) {-else-} $ \ _ t -> do case unEl t of -- Case: We know the type of the record already. Def r es -> do- let ~(Just vs) = allApplyElims es+ let vs = mustAllApplyElims es reportSDoc "tc.term.rec" 20 $ " r = " <> pure (P.pretty r) def <- getRecordDef r let -- Field names (C.Name) with ArgInfo from record type definition.- cxs = map argFromDom $ recordFieldNames def+ cxs = map' argFromDom $ recordFieldNames def -- Just field names.- xs = map unArg cxs+ xs = map' unArg cxs -- Record constructor. con = killRange $ _recConHead def reportSDoc "tc.term.rec" 20 $ vcat@@ -1019,13 +1144,13 @@ -- Record expressions corresponding to erased record -- constructors can only be used in compile-time mode. constructorQ <- getQuantity <$> getConstInfo (conName con)- currentQ <- viewTC eQuantity+ currentQ <- viewTC eQuantityZeroHardCompile unless (constructorQ `moreQuantity` currentQ) $ typeError RecordIsErased -- 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.- disambiguateRecordFields (map _nameFieldA $ lefts mfs) (map unDom $ _recFields def)+ disambiguateRecordFields (map' _nameFieldA $ lefts mfs) (map' unDom $ _recFields def) -- Compute the list of given fields, decorated with the ArgInfo from the record def. -- Andreas, 2019-03-18, issue #3122, also pick up non-visible fields from the modules.@@ -1045,52 +1170,49 @@ _ -> __IMPOSSIBLE__ -- Don't need to block here! reportSDoc "tc.term.rec" 20 $ text $ "finished record expression"- return $ Con con ConORec (map Apply args)+ return $! Con con ConORec $! map' Apply args _ -> typeError $ ShouldBeRecordType t-- where- -- Case: We don't know the type of the record.- guessRecordType t = do- let fields = [ x | Left (FieldAssignment x _) <- mfs ]- rs <- findPossibleRecords fields- reportSDoc "tc.term.rec" 30 $ "Possible records for" <+> prettyTCM t <+> "are" <?> pretty rs- case rs of- -- If there are no records with the right fields we might as well fail right away.- [] -> typeError $ NoKnownRecordWithSuchFields fields- -- If there's only one record with the appropriate fields, go with that.- [r] -> do- -- #5198: Don't generate metas for parameters of the current module. In most cases they- -- get solved, but not always.- def <- instantiateDef =<< getConstInfo r- ps <- freeVarsToApply r- let rt = defType def- reportSDoc "tc.term.rec" 30 $ "Type of unique record" <+> prettyTCM rt- vs <- newArgsMeta rt- target <- reduce $ piApply rt vs- s <- case unEl target of- Sort s -> return s- v -> do- reportSDoc "impossible" 10 $ vcat- [ "The impossible happened when checking record expression against meta"- , "Candidate record type r = " <+> prettyTCM r- , "Type of r = " <+> prettyTCM rt- , "Ends in (should be sort)= " <+> prettyTCM v- , text $ " Raw = " ++ show v- ]- __IMPOSSIBLE__- let inferred = El s $ Def r $ map Apply (ps ++ vs)- v <- checkExpr e inferred- coerce cmp v inferred t+checkRecordExpression _ _ _ _ = __IMPOSSIBLE__ - -- If there are more than one possible record we postpone- _:_:_ -> do- reportSDoc "tc.term.expr.rec" 10 $ sep- [ "Postponing type checking of"- , nest 2 $ prettyA e <+> ":" <+> prettyTCM t+guessRecordType :: Comparison -> A.Expr -> [C.Name] -> Type -> TCM Term+guessRecordType cmp e fields t = do+ rs <- findPossibleRecords fields+ reportSDoc "tc.term.rec" 30 $ "Possible records for" <+> prettyTCM t <+> "are" <?> pretty rs+ case rs of+ -- If there are no records with the right fields we might as well fail right away.+ [] -> typeError $ NoKnownRecordWithSuchFields fields+ -- If there's only one record with the appropriate fields, go with that.+ [r] -> do+ -- #5198: Don't generate metas for parameters of the current module. In most cases they+ -- get solved, but not always.+ def <- instantiateDef =<< getConstInfo r+ ps <- freeVarsToApply r+ let rt = defType def+ reportSDoc "tc.term.rec" 30 $ "Type of unique record" <+> prettyTCM rt+ vs <- newArgsMeta rt+ target <- reduce $ piApply rt vs+ s <- case unEl target of+ Sort s -> return s+ v -> do+ reportSDoc "impossible" 10 $ vcat+ [ "The impossible happened when checking record expression against meta"+ , "Candidate record type r = " <+> prettyTCM r+ , "Type of r = " <+> prettyTCM rt+ , "Ends in (should be sort)= " <+> prettyTCM v+ , text $ " Raw = " ++! show v ]- postponeTypeCheckingProblem_ $ CheckExpr cmp e t+ __IMPOSSIBLE__+ let inferred = El s $! Def r $! map' Apply (ps ++! vs)+ v <- checkExpr e inferred+ coerce cmp v inferred t -checkRecordExpression _ _ _ _ = __IMPOSSIBLE__+ -- If there are more than one possible record we postpone+ _:_:_ -> do+ reportSDoc "tc.term.expr.rec" 10 $ sep+ [ "Postponing type checking of"+ , nest 2 $ prettyA e <+> ":" <+> prettyTCM t+ ]+ postponeTypeCheckingProblem_ $ CheckExpr cmp e t -- | @checkRecordUpdate cmp ei recexpr fs e t@ --@@ -1113,16 +1235,16 @@ name <- freshNoName $ getRange recexpr addLetBinding defaultArgInfo Inserted name v t' $ do - let projs = map argFromDom $ _recFields defn+ let projs = map' argFromDom $ _recFields defn -- 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.- disambiguateRecordFields (map _nameFieldA fs) (map unArg projs)+ disambiguateRecordFields (map' _nameFieldA fs) (map' unArg projs) -- Desugar record update expression into record expression.- let fs' = map (\ (FieldAssignment x e) -> (x, Just e)) fs- let axs = map argFromDom $ recordFieldNames defn+ let fs' = map' (\ (FieldAssignment x e) -> (x, Just e)) fs+ let axs = map' argFromDom $ recordFieldNames defn es <- orderFieldsWarn r (const Nothing) axs fs' let es' = zipWith (replaceFields name ei) projs es let erec = A.Rec kwr ei [ Left (FieldAssignment x e) | (Arg _ x, Just e) <- zip axs es' ]@@ -1161,11 +1283,36 @@ -- * Terms --------------------------------------------------------------------------- +-- | Same as 'Agda.Syntax.Abstract.Views.appView',+-- but produces correct 'Hiding' when constructing the 'AppView'+-- from a postfix projection.+appViewM :: A.Expr -> TCM AppView+appViewM e = do+ (f, es) <- go e+ return $! f $! DL.toList es+ where+ go :: A.Expr -> TCM (A.Args -> AppView, DL.DList (NamedArg A.Expr))+ go = \case+ A.ScopedExpr _ e -> go e+ A.App _ e1 e2+ | A.Dot _ e2' <- unScope $ namedArg e2+ , Just (f0, hd) <- maybeProjTurnPostfix e2'+ -> do+ ai <- case getUnambiguous f0 of+ Just f -> isProjection f >>= \case+ Just p | isProperProjection_ p -> pure $ projArgInfo p+ _ -> pure defaultArgInfo+ Nothing -> pure defaultArgInfo+ return (Application hd, singleton (unnamedArg ai e1))+ A.App _ e1 arg -> second (`DL.snoc` arg) <$> go e1+ e -> return (Application e, mempty)+ -- | Remove top layers of scope info of expression and set the scope accordingly -- in the 'TCState'. scopedExpr :: A.Expr -> TCM A.Expr scopedExpr (A.ScopedExpr scope e) = setScope scope >> scopedExpr e+scopedExpr (A.Qualified mod e) = scopedExpr e scopedExpr e = return e -- | Type check an expression.@@ -1202,7 +1349,7 @@ irrelevantIfProp <- runBlocked (isPropM t) >>= \case Right True -> do let mod = unitModality { modRelevance = irrelevant }- return $ fmap dontCare . applyModalityToContext mod+ return $! fmap dontCare . applyModalityToContext mod _ -> return id irrelevantIfProp $ tryInsertHiddenLambda e tReduced $ case e of@@ -1281,7 +1428,10 @@ A.Dot{} -> typeError InvalidDottedExpression -- Application- _ | Application hd args <- appView e -> checkApplication cmp hd args e t+ e -> do+ Application hd args <- appViewM e+ e' <- checkApplication cmp hd args e t+ pure e' `catchIlltypedPatternBlockedOnMeta` \ (err, x) -> do -- We could not check the term because the type of some pattern is blocked.@@ -1304,14 +1454,15 @@ -- Insert hidden lambda if all of the following conditions are met: -- type is a hidden function type, {x : A} -> B or {{x : A}} -> B -- expression is not a lambda with the appropriate hiding yet- | Pi (Dom{domInfo = info, unDom = a}) b <- unEl tReduced+ | Pi dom@(unDom -> a) b <- unEl tReduced+ , let info = dom ^. dInfo , let h = getHiding info , notVisible h -- expression is not a matching hidden lambda or question mark , not (hiddenLambdaOrHole h e) = do let proceed = doInsert (setOrigin Inserted info) $ absName b- expandHidden <- asksTC envExpandLast+ expandHidden <- viewTC eExpandLast -- If we skip the lambda insertion for an introduction, -- we will hit a dead end, so proceed no matter what. if definitelyIntroduction then proceed else@@ -1367,12 +1518,14 @@ doQuoteTerm :: Comparison -> Term -> Type -> TCM Term doQuoteTerm cmp et t = do et' <- etaContract =<< instantiateFull et- case allMetasList et' of- [] -> do- q <- quoteTerm et'- ty <- el primAgdaTerm- coerce cmp q ty t- metas -> postponeTypeCheckingProblem (DoQuoteTerm cmp et t) $ unblockOnAllMetas $ Set.fromList metas+ quoteMetas <- optQuoteMetas <$> pragmaOptions+ let metas = allMetasList et'+ if quoteMetas || null metas then do+ q <- quoteTerm et'+ ty <- el primAgdaTerm+ coerce cmp q ty t+ else+ postponeTypeCheckingProblem (DoQuoteTerm cmp et t) $ unblockOnAllMetas $ Set.fromList metas -- | Unquote a TCM computation in a given hole. unquoteM :: A.Expr -> Term -> Type -> TCM ()@@ -1389,7 +1542,7 @@ reportSDoc "tc.term.tactic" 40 $ sep [ "Running tactic" <+> prettyTCM tac , nest 2 $ "on" <+> prettyTCM hole <+> ":" <+> prettyTCM goal ]- ok <- runUnquoteM $ unquoteTCM tac hole+ ok <- runUnquoteM [] $ unquoteTCM tac hole case ok of Left (BlockedOnMeta oldState blocker) -> do putTC oldState@@ -1423,7 +1576,7 @@ , ":" , prettyTCM t0 ]- reportSDoc "tc.interaction" 60 $ sep+ reportSDoc "tc.interaction" 90 $ sep [ "Raw:" , text (show t0) ]@@ -1440,7 +1593,7 @@ -- | Infer the type of a meta variable. -- If it is a new one, we create a new meta for its type. inferMeta :: A.MetaInfo -> (Comparison -> Type -> TCM (MetaId, Term)) -> TCM (Elims -> Term, Type)-inferMeta i newMeta = mapFst applyE <$> checkOrInferMeta i newMeta Nothing+inferMeta i newMeta = first applyE <$> checkOrInferMeta i newMeta Nothing -- | Type check a meta variable. -- If its type is not given, we return its type, or a fresh one, if it is a new meta.@@ -1452,6 +1605,9 @@ -> Maybe (Comparison , Type) -> TCM (Term, Type) checkOrInferMeta i newMeta mt = do+ -- We still need to check equational constraints even when checking a meta+ -- because definitions parameterised by a local rewrite rule do not block+ -- on the corresponding argument case A.metaNumber i of Nothing -> do unlessNull (A.metaScope i) setScope@@ -1522,7 +1678,7 @@ -- && (visible info || maybe True (absName b ==) (bareNameOf e))) checkKnownArgument arg (Arg _ v : vs) t = do -- Skip the arguments from vs that do not correspond to e- (dom@Dom{ unDom = a }, b) <- mustBePi t+ (dom@(unDom -> a), b) <- mustBePi t if not $ fromMaybe __IMPOSSIBLE__ $ fittingNamedArg arg dom -- Continue with the next one then checkKnownArgument arg vs (b `absApp` v)@@ -1543,17 +1699,19 @@ "Checking named arg" <+> sep [ fsep [ prettyTCM arg, ":", prettyTCM t0 ] ]- reportSLn "tc.term.args.named" 75 $ " arg = " ++ show (deepUnscope arg)+ reportSLn "tc.term.args.named" 75 $ " arg = " ++! show (deepUnscope arg) -- Ulf, 2017-03-24: (#2172) Always treat explicit _ and ? as implicit -- argument (i.e. solve with unification). -- Andreas, 2024-03-07, issue #2829: Except when we don't. -- E.g. when 'insertImplicitPatSynArgs' inserted an instance underscore.- let checkU i = checkMeta i (newMetaArg (A.metaKind i) info x) CmpLeq t0+ let checkU i = checkMeta i+ (\cmp -> newMetaArg (A.metaKind i) x cmp . defaultArgDom info)+ CmpLeq t0 let checkQ = checkQuestionMark (newInteractionMetaArg info x) CmpLeq t0 if not $ isHole e then checkExpr e t0 else localScope $ do- -- Note: we need localScope here,+ -- Note: we need localScope_ here, -- as scopedExpr manipulates the scope in the state.- -- However, we may not pull localScope over checkExpr!+ -- However, we may not pull localScope_ over checkExpr! -- This is why we first test for isHole, and only do -- scope manipulations if we actually handle the checking -- of e here (and not pass it to checkExpr).@@ -1575,14 +1733,14 @@ inferExpr' :: ExpandHidden -> A.Expr -> TCM (Term, Type) inferExpr' exh e = traceCall (InferExpr e) $ do- let Application hd args = appView e+ Application hd args <- appViewM e reportSDoc "tc.infer" 30 $ vcat [ "inferExpr': appView of " <+> prettyA e , " hd = " <+> prettyA hd , " args = " <+> prettyAs args ] reportSDoc "tc.infer" 60 $ vcat- [ text $ " hd (raw) = " ++ show hd+ [ text $ " hd (raw) = " ++! show hd ] inferApplication exh hd args e @@ -1596,17 +1754,18 @@ -- | Used to check aliases @f = e@. -- Switches off 'ExpandLast' for the checking of top-level application. checkDontExpandLast :: Comparison -> A.Expr -> Type -> TCM Term-checkDontExpandLast cmp e t = case e of- _ | Application hd args <- appView e, defOrVar hd ->+checkDontExpandLast cmp e t = do+ Application hd args <- appViewM e+ if defOrVar hd then traceCall (CheckExprCall cmp e t) $ localScope $ dontExpandLast $ do checkApplication cmp hd args e t- _ -> checkExpr' cmp e t -- note that checkExpr always sets ExpandLast+ else checkExpr' cmp e t -- note that checkExpr always sets ExpandLast -- | Check whether a de Bruijn index is bound by a module telescope. isModuleFreeVar :: Int -> TCM Bool isModuleFreeVar i = do params <- moduleParamsToApply =<< currentModule- return $ any ((== Var i []) . unArg) params+ return $! any ((== Var i []) . unArg) params -- | Infer the type of an expression, and if it is of the form -- @{tel} -> D vs@ for some datatype @D@ then insert the hidden@@ -1615,7 +1774,7 @@ inferExprForWith (Arg info e) = verboseBracket "tc.with.infer" 20 "inferExprForWith" $ applyRelevanceToContext (getRelevance info) $ do reportSDoc "tc.with.infer" 20 $ "inferExprForWith " <+> prettyTCM e- reportSLn "tc.with.infer" 80 $ "inferExprForWith " ++ show (deepUnscope e)+ reportSLn "tc.with.infer" 80 $ "inferExprForWith " ++! show (deepUnscope e) traceCall (InferExpr e) $ do -- Andreas, 2024-02-26, issue #7148: -- The 'instantiateFull' here performs necessary eta-contraction,@@ -1628,7 +1787,7 @@ case v of Var i [] -> whenM (isModuleFreeVar i) $ do reportSDoc "tc.with.infer" 80 $ vcat- [ text $ "with expression is variable " ++ show i+ [ text $ "with expression is variable " ++! show i , "current modules = " <+> do text . show =<< currentModule , "current module free vars = " <+> do text . show =<< getCurrentModuleFreeVars , "context size = " <+> do text . show =<< getContextSize@@ -1666,6 +1825,8 @@ | getOrigin info == Inserted = checkDontExpandLast | otherwise = checkExpr' + checkIrrelevanceAllowed info+ t <- workOnTypes $ isType_ t v <- applyModalityToContext info $ check CmpLeq e t @@ -1675,31 +1836,36 @@ t <- workOnTypes $ isType_ t current <- currentModule + checkIrrelevanceAllowed info+ -- Note: if addConstant is called under a nontrivial context then -- it'll automatically quantify the type we give it over the context axn <- qualify current <$> freshName_ (A.unBind x) addConstant' axn info t defaultAxiom val <- Def axn . fmap Apply <$> getContextArgs- addLetBinding info UserWritten (A.unBind x) val t ret+ addLetAxiom info UserWritten (A.unBind x) val t ret -checkLetBinding' b@(A.LetPatBind i p e) ret = do+checkLetBinding' b@(A.LetPatBind i ai p e) ret = do p <- expandPatternSynonyms p- (v, t) <- inferExpr' ExpandLast e++ checkIrrelevanceAllowed ai++ (v, t) <- applyModalityToContext ai $ inferExpr' ExpandLast e let -- construct a type t -> dummy for use in checkLeftHandSide- t0 = El (getSort t) $ Pi (defaultDom t) (NoAbs underscore __DUMMY_TYPE__)- p0 = Arg defaultArgInfo (Named Nothing p)+ t0 = El (getSort t) $ Pi (defaultArgDom ai t) (NoAbs underscore __DUMMY_TYPE__)+ p0 = Arg ai (Named Nothing p) reportSDoc "tc.term.let.pattern" 10 $ vcat [ "let-binding pattern p at type t" , nest 2 $ vcat [ "p (A) =" <+> prettyA p , "t =" <+> prettyTCM t , "cxtRel=" <+> do pretty =<< viewTC eRelevance- , "cxtQnt=" <+> do pretty =<< viewTC eQuantity+ , "cxtQnt=" <+> do pretty =<< viewTC eQuantityZeroHardCompile ] ] fvs <- getContextSize- checkLeftHandSide (CheckPattern p EmptyTel t) noRange Nothing [p0] t0 Nothing [] $ \ (LHSResult _ delta0 ps _ _t _ asb _ _) -> bindAsPatterns asb $ do+ checkLeftHandSide (CheckPattern p EmptyTel t) noRange LetLHS [p0] t0 NoWithFunction [] $ \ (LHSResult _ delta0 ps _ _t _ asb _ _) -> setCurrentRange p $ 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@@ -1708,7 +1874,7 @@ [ "p (I) =" <+> prettyTCM p , "delta =" <+> prettyTCM delta , "cxtRel=" <+> do pretty =<< viewTC eRelevance- , "cxtQnt=" <+> do pretty =<< viewTC eQuantity+ , "cxtQnt=" <+> do pretty =<< viewTC eQuantityZeroHardCompile ] reportSDoc "tc.term.let.pattern" 80 $ nest 2 $ vcat [ "p (I) =" <+> (text . show) p@@ -1717,20 +1883,20 @@ fs <- recordPatternToProjections p -- We remove the bindings for the pattern variables from the context. cxt0 <- getContext- let (binds, cxt) = splitAt (size delta) cxt0- toDrop = length binds+ let binds = cxTake (size delta) cxt0+ toDrop = length binds -- We create a substitution for the let-bound variables -- (unfortunately, we cannot refer to x in internal syntax -- so we have to copy v).- sigma = map ($ v) fs+ sigma = map' ($ v) fs -- We apply the types of the let bound-variables to this substitution. -- The 0th variable in a context is the last one, so we reverse. -- Further, we need to lower all other de Bruijn indices by -- the size of delta, so we append the identity substitution. sub = parallelS (reverse sigma) - updateContext sub (drop toDrop) $ do+ updateContext sub (cxDrop toDrop) $ do reportSDoc "tc.term.let.pattern" 20 $ nest 2 $ vcat [ "delta =" <+> prettyTCM delta , "binds =" <+> prettyTCM binds@@ -1741,11 +1907,11 @@ ] let tsl = applySubst sub fdelta -- We get a list of types- let ts = map unDom tsl+ let ts = map' unDom tsl -- and relevances.- let infos = map domInfo tsl+ let infos = map' domInfo tsl -- We get list of names of the let-bound vars from the context.- let xs = map ctxEntryName $ reverse binds+ let xs = map' ctxEntryName $ reverse binds -- We add all the bindings to the context. foldr (uncurry4 $ flip addLetBinding UserWritten) ret $ List.zip4 infos xs sigma ts @@ -1763,6 +1929,7 @@ [ "context =" <+> (prettyTCM =<< getContextTelescope) , "module =" <+> (prettyTCM =<< currentModule) , "fv =" <+> text (show fv)+ , "copy =" <+> pretty copyInfo ] checkSectionApplication i erased x modapp copyInfo -- Some other part of the code ensures that "open public" is
src/full/Agda/TypeChecking/Serialise.hs view
@@ -1,5 +1,10 @@+{-# LANGUAGE Strict #-} {-# LANGUAGE CPP #-} {-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_GHC -Wno-redundant-bang-patterns #-}+{-# OPTIONS_GHC -Wunused-imports #-} -- Andreas, Makoto, Francesco 2014-10-15 AIM XX: -- -O2 does not have any noticable effect on runtime@@ -18,9 +23,15 @@ -- -!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!- module Agda.TypeChecking.Serialise- ( encode, encodeFile, encodeInterface- , decode, decodeFile, decodeInterface, decodeHashes- , EmbPrj+ ( InterfacePrefix+ , Encoded+ , encode+ , encodeFile+ , decode+ , decodeFile+ , decodeInterface+ , deserializeInterface+ , deserializeHashes ) where @@ -29,273 +40,238 @@ import System.Directory ( createDirectoryIfMissing ) import System.FilePath ( takeDirectory ) -import Control.Arrow (second)-import Control.DeepSeq import qualified Control.Exception as E import Control.Monad-import Control.Monad.Except-import Control.Monad.IO.Class ( MonadIO(..) ) import Control.Monad.Reader-import Control.Monad.State.Strict-import Control.Monad.ST.Trans+import Control.Monad.Trans.Maybe -import Data.Array.IArray-import Data.Array.IO+import Data.Foldable (traverse_) import Data.Word-import Data.Word (Word32)-import Data.ByteString.Lazy ( ByteString )-import Data.ByteString.Builder ( byteString, toLazyByteString )-import qualified Data.ByteString.Lazy as L-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 Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB import qualified Data.List as List-import Data.Function (on)--import qualified Codec.Compression.GZip as G-import qualified Codec.Compression.Zlib.Internal as Z--import GHC.Compact as C+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL -import qualified Agda.TypeChecking.Monad.Benchmark as Bench+import GHC.Float (castWord64ToDouble) -import Agda.TypeChecking.Serialise.Base-import Agda.TypeChecking.Serialise.Instances () --instance only+import qualified Codec.Compression.Zstd as Z +import Agda.Interaction.Options.ProfileOptions qualified as Profile import Agda.TypeChecking.Monad+import Agda.TypeChecking.Monad.Benchmark qualified as Bench+import Agda.TypeChecking.Serialise.Base+import Agda.TypeChecking.Serialise.Instances () -- instances only +import Agda.Utils.CompactRegion qualified as Compact import Agda.Utils.Hash-import qualified Agda.Utils.HashTable as H+import Agda.Utils.HashTable qualified as H import Agda.Utils.IORef-import Agda.Utils.Null-import qualified Agda.Utils.ProfileOptions as Profile+import Agda.Utils.MinimalArray.Lifted qualified as AL+import Agda.Utils.MinimalArray.MutableLifted qualified as ML+import Agda.Utils.Monad ((<*!>))+import Agda.Utils.Serialize+import Agda.Utils.Tuple (second)+import Agda.Utils.VarSet (VarSet) import Agda.Utils.Impossible --- Note that the Binary instance for Int writes 64 bits, but throws--- away the 32 high bits when reading (at the time of writing, on--- 32-bit machines). Word64 does not have these problems.+#include "MachDeps.h" currentInterfaceVersion :: Word64-currentInterfaceVersion = 20250703 * 10 + 0+currentInterfaceVersion = 20261026 * 10 + 1 --- | The result of 'encode' and 'encodeInterface'.+ifaceVersionSize :: Int+ifaceVersionSize = SIZEOF_WORD64 -data Encoded = Encoded- { uncompressed :: ByteString- -- ^ The uncompressed bytestring, without hashes and the interface- -- version.- , compressed :: ByteString- -- ^ The compressed bytestring.- }+ifacePrefixSize :: Int+ifacePrefixSize = 2 * hashSize + ifaceVersionSize --- | Encodes something. To ensure relocatability file paths in--- positions are replaced with module names.+type InterfacePrefix =+ ( Hash -- sourceHash+ , Hash -- fullHash+ , Word64 -- interface version+ ) +-- | Hash-consed encoding of a value.+type Encoded =+ ( Word32 -- index of root Node+ , AL.Array Node+ , AL.Array String+ , AL.Array TL.Text+ , AL.Array T.Text+ , AL.Array Integer+ , AL.Array VarSet+ , AL.Array Double+ )++-- | Encodes something as a hash-consed tuple of arrays. To ensure relocatability, file paths in+-- positions are replaced with module names. encode :: EmbPrj a => a -> TCM Encoded encode a = do- collectStats <- hasProfileOption Profile.Serialize- newD@(Dict nD ltD stD bD iD dD- _nameD- _qnameD- nC ltC stC bC iC dC tC- nameC- qnameC- stats _) <- liftIO $ emptyDict collectStats- root <- liftIO $ (`runReaderT` newD) $ icode a- nL <- benchSort $ l nD- stL <- benchSort $ l stD- ltL <- benchSort $ l ltD- bL <- benchSort $ l bD- iL <- benchSort $ l iD- dL <- benchSort $ l dD- -- Record reuse statistics.- whenProfile Profile.Sharing $ do- statistics "pointers" tC- whenProfile Profile.Serialize $ do- statistics "Integer" iC- statistics "Lazy Text" ltC- statistics "Strict Text" stC- statistics "Text" bC- statistics "Double" dC- statistics "Node" nC- statistics "Shared Term" tC- statistics "A.QName" qnameC- statistics "A.Name" nameC- when collectStats $ do- stats <- Map.fromListWith __IMPOSSIBLE__ . map (second toInteger) <$> do- liftIO $ List.sort <$> H.toList stats- modifyStatistics $ Map.unionWith (+) stats- -- Encode hashmaps and root, and compress.- bits1 <- Bench.billTo [ Bench.Serialization, Bench.BinaryEncode ] $- return $!! B.encode (root, nL, ltL, stL, bL, iL, dL)- let compressParams = G.defaultCompressParams- { G.compressLevel = G.bestSpeed- , G.compressStrategy = G.huffmanOnlyStrategy- }- cbits <- Bench.billTo [ Bench.Serialization, Bench.Compress ] $- return $!! G.compressWith compressParams bits1- let x = B.encode currentInterfaceVersion <> cbits- return (Encoded { uncompressed = bits1, compressed = x })+ collectStats <- hasProfileOption Profile.Serialize+ newD <- liftIO $ emptyDict collectStats+ root <- liftIO $ (`runReaderT` newD) $ icode a++ (nodeA, stringA, lTextA, sTextA, integerA, varSetA, doubleA) <-+ Bench.billTo [Bench.Serialization, Bench.Sort] $ liftIO $ do+ (,,,,,,) <$!> toArray (nodeD newD)+ <*!> toArray (stringD newD)+ <*!> toArray (lTextD newD)+ <*!> toArray (sTextD newD)+ <*!> toArray (integerD newD)+ <*!> toArray (varSetD newD)+ <*!> toArrayWith castWord64ToDouble (doubleD newD)++ -- Record reuse statistics.+ whenProfile Profile.Sharing $ do+ statistics "pointers" (termC newD)+ whenProfile Profile.Serialize $ do+ statistics "Integer" (integerC newD)+ statistics "VarSet" (varSetC newD)+ statistics "Lazy Text" (lTextC newD)+ statistics "Strict Text" (sTextC newD)+ statistics "String" (stringC newD)+ statistics "Double" (doubleC newD)+ statistics "Node" (nodeC newD)+ statistics "Shared Term" (termC newD)+ statistics "A.QName" (qnameC newD)+ statistics "A.Name" (nameC newD)+ when collectStats $ do+ stats <- map (second fromIntegral) <$> do+ liftIO $ List.sort <$> H.toList (stats newD)+ traverse_ (uncurry tickN) stats++ pure (root, nodeA, stringA, lTextA, sTextA, integerA, varSetA, doubleA) where- l h = List.map fst . List.sortBy (compare `on` snd) <$> H.toList h- benchSort = Bench.billTo [Bench.Serialization, Bench.Sort] . liftIO- statistics :: String -> IORef FreshAndReuse -> TCM ()- statistics kind ioref = do- FreshAndReuse fresh+ toArray :: H.HashTableLU k Word32 -> IO (AL.Array k)+ toArray = toArrayWith id++ -- The 'Double' dictionary is keyed by bit patterns (see 'icodeDouble'),+ -- so its keys have to be converted back to 'Double's here.+ toArrayWith :: (k -> a) -> H.HashTableLU k Word32 -> IO (AL.Array a)+ toArrayWith f tbl = do+ size <- H.size tbl+ arr <- ML.new size undefined+ H.forAssocs tbl \k v -> ML.write arr (fromIntegral v) $! f k+ ML.unsafeFreeze arr++ statistics :: String -> FreshAndReuse -> TCM ()+ statistics kind far = do+ fresh <- liftIO $ getFresh far #ifdef DEBUG_SERIALISATION- reused+ reused <- liftIO $ getReuse far #endif- <- liftIO $ readIORef ioref tickN (kind ++ " (fresh)") $ fromIntegral fresh #ifdef DEBUG_SERIALISATION tickN (kind ++ " (reused)") $ fromIntegral reused #endif --- encode :: EmbPrj a => a -> TCM ByteString--- encode a = do--- fileMod <- sourceToModule--- (x, shared, total) <- liftIO $ do--- newD@(Dict nD sD iD dD _ _ _ _ _ stats _) <- emptyDict fileMod--- root <- runReaderT (icode a) newD--- nL <- l nD; sL <- l sD; iL <- l iD; dL <- l dD--- (shared, total) <- readIORef stats--- return (B.encode currentInterfaceVersion <>--- G.compress (B.encode (root, nL, sL, iL, dL)), shared, total)--- 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 Word32 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)- -- Andreas, 2024-10-15: If n is zero, create an empty array.- -- Since our indices are Word32, we need to represent it as [1..0] instead of the usual [0..-1].- if n <= 0 then (newArray_ (1,0) :: STT s B.Get (STArray s Word32 a)) else do-- arr <- newArray_ (0, fromIntegral n - 1) :: STT s B.Get (STArray s Word32 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+-- | Decode a hash-consed value. The result depends on the include path.+decode :: EmbPrj a => Encoded -> MaybeT TCM a+decode enc = stateSessionLensM lensModuleToSource \mf -> do+ includes <- lift $ getIncludeDirs+ arena <- liftIO $ Compact.new (2 ^ 12) -- 4 KB blocks - return arr+ let compactElems :: AL.Array a -> IO (AL.Array a)+ compactElems = AL.traverseIO' (Compact.add arena) --- | Decodes an uncompressed bytestring (without extra hashes or magic--- numbers). The result depends on the include path.------ Returns 'Nothing' if a decoding error is encountered.+ tryDecode $ do+ let (r, nodeA, stringA, lTextA, sTextA, integerA, varSetA, doubleA) = enc -decode :: EmbPrj a => ByteString -> TCM (Maybe a)-decode s = do- mf <- useTC stModuleToSource- incs <- getIncludeDirs+ stringA <- compactElems stringA+ lTextA <- compactElems lTextA+ sTextA <- compactElems sTextA+ integerA <- compactElems integerA+ varSetA <- compactElems varSetA+ doubleA <- compactElems doubleA+ filePathMemo <- H.empty+ nodeMemo <- ML.new (AL.size nodeA) MEEmpty+ modFile <- newIORef mf+ let dec = Decode nodeMemo arena nodeA stringA lTextA sTextA integerA varSetA+ doubleA filePathMemo modFile includes+ res <- runReaderT (value r) dec+ mf <- readIORef modFile+ pure (res, mf)+ -- -- "Compact" the interfaces (without breaking sharing) to+ -- -- reduce the amount of memory that is traversed by the+ -- -- garbage collector.+ -- lift $ Bench.billTo [Bench.Deserialization, Bench.Compaction] $+ -- liftIO $ C.getCompact <$!> C.compactWithSharing res - -- Note that runGetState can raise errors if the input is malformed.- -- The decoder is (intended to be) strict enough to ensure that all- -- such errors can be caught by the handler here.+getInterfacePrefix :: Interface -> InterfacePrefix+getInterfacePrefix i =+ (iSourceHash i, iFullHash i, currentInterfaceVersion) - res <- liftIO $ E.handle (\(E.ErrorCall s) -> pure $ Left s) $ do- ((r, nL, ltL, stL, bL, iL, dL), s, _) <- return $ runGetState B.get s 0- let ar = unListLike- when (not (null s)) $ E.throwIO $ E.ErrorCall "Garbage at end."- let nL' = ar nL- st <- St nL' (ar ltL) (ar stL) (ar bL) (ar iL) (ar dL)- <$> liftIO (newArray (bounds nL') MEEmpty)- <*> return mf <*> return incs- (r, st) <- runStateT (value r) st- let !mf = modFile st- return $ Right (mf, r)+-- | Serialize an interface prefix + an encoded interface to a lazy bytestring.+-- The result is lazy in order to avoid copying data when we prepend the+-- prefix to the compressed interface bytestring.+serializeEncodedInterface :: InterfacePrefix -> Encoded -> TCM LB.ByteString+serializeEncodedInterface prefix i = do+ let doCompress i = pure $! Z.compress 1 i -- we outline this to prevent let-lifting by GHC+ {-# NOINLINE doCompress #-} -- which could ruin the benchmark timing.+ (prefix, i) <- Bench.billTo [Bench.Serialization, Bench.BinaryEncode] $ liftIO $+ (,) <$!> serialize prefix <*!> serialize i+ i <- Bench.billTo [Bench.Serialization, Bench.Compress] $ doCompress i+ pure $! LB.fromStrict prefix <> LB.fromStrict i +-- | Convert ErrorCall-s (which are assumed to be deserialization errors) to+-- MaybeT TCM.+tryDecode :: IO a -> MaybeT TCM a+tryDecode act = MaybeT do+ res <- liftIO ((Right <$!> act) `E.catch` \(E.ErrorCall err) -> pure (Left err)) case res of- Left s -> do- reportSLn "import.iface" 5 $ "Error when decoding interface file: " ++ s+ Left err -> do+ reportSLn "import.iface" 5 $ "Error when decoding interface file: " ++ err pure Nothing-- Right (mf, x) -> do- setTCLens stModuleToSource mf- -- "Compact" the interfaces (without breaking sharing) to- -- reduce the amount of memory that is traversed by the- -- garbage collector.- Bench.billTo [Bench.Deserialization, Bench.Compaction] $- liftIO (Just . C.getCompact <$> C.compactWithSharing x)+ Right a -> pure $ Just a +-- | Decode an interface from a bytestring. We check the stored interface+-- version against the current interface version, but we don't do anything+-- with the hash prefix.+decodeInterface :: ByteString -> MaybeT TCM Interface+decodeInterface bstr = decode =<< deserializeInterface bstr -encodeInterface :: Interface -> TCM Encoded-encodeInterface i = do- r <- encode i- return r{ compressed = hashes <> compressed r }- where- hashes :: ByteString- hashes = B.runPut $ B.put (iSourceHash i) >> B.put (iFullHash i)+deserializeInterface :: ByteString -> MaybeT TCM Encoded+deserializeInterface bstr = do+ let decompressionError =+ tryDecode $ E.throwIO $ E.ErrorCall "decompression error"+ let (prefix, i) = B.splitAt ifacePrefixSize bstr+ ((_, _, ver) :: InterfacePrefix) <- tryDecode $ deserialize prefix+ if ver /= currentInterfaceVersion then+ decompressionError+ else case Z.decompress i of+ Z.Skip -> decompressionError+ Z.Error e -> decompressionError+ Z.Decompress i -> tryDecode $ deserialize i --- | Encodes an interface. To ensure relocatability file paths in--- positions are replaced with module names.------ An uncompressed bytestring corresponding to the encoded interface--- is returned.+-------------------------------------------------------------------------------- -encodeFile :: FilePath -> Interface -> TCM ByteString+-- | Encodes an interface. To ensure relocatability file paths in positions are+-- replaced with module names.+-- A hash-consed and compacted interface is returned.+encodeFile :: FilePath -> Interface -> TCM Interface encodeFile f i = do- r <- encodeInterface i- liftIO $ createDirectoryIfMissing True (takeDirectory f)- liftIO $ L.writeFile f (compressed r)- return (uncompressed r)---- | Decodes an interface. The result depends on the include path.------ Returns 'Nothing' if the file does not start with the right magic--- number or some other decoding error is encountered.--decodeInterface :: ByteString -> TCM (Maybe Interface)-decodeInterface s = do-- -- Note that runGetState and the decompression code below can raise- -- errors if the input is malformed. The decoder is (intended to be)- -- strict enough to ensure that all such errors can be caught by the- -- handler here or the one in decode.-- s <- liftIO $- E.handle (\(E.ErrorCall s) -> return (Left s)) $- E.evaluate $- let (ver, s', _) = runGetState B.get (L.drop 16 s) 0 in- if ver /= currentInterfaceVersion- then Left "Wrong interface version."- else Right $- toLazyByteString $- Z.foldDecompressStreamWithInput- (\s -> (byteString s <>))- (\s -> if null s- then mempty- else error "Garbage at end.")- (\err -> error (show err))- (Z.decompressST Z.gzipFormat Z.defaultDecompressParams)- s'+ let prefix = getInterfacePrefix i+ iEncoded <- encode i+ bstr <- serializeEncodedInterface prefix iEncoded+ i <- Bench.billTo [Bench.Deserialization] $+ maybe __IMPOSSIBLE__ pure =<< runMaybeT (decode @Interface iEncoded) - case s of- Right s -> decode s- Left err -> do- reportSLn "import.iface" 5 $- "Error when decoding interface file: " ++ err- return Nothing+ -- reload interface from the bytestring instead+ -- i <- Bench.billTo [Bench.Deserialization] $+ -- maybe __IMPOSSIBLE__ pure =<<+ -- runMaybeT (decode =<< deserializeInterface (LB.toStrict bstr)) -decodeHashes :: ByteString -> Maybe (Hash, Hash)-decodeHashes s- | L.length s < 16 = Nothing- | otherwise = Just $ B.runGet getH $ L.take 16 s- where getH = (,) <$> B.get <*> B.get+ liftIO $ createDirectoryIfMissing True (takeDirectory f)+ liftIO $ LB.writeFile f bstr+ pure i decodeFile :: FilePath -> TCM (Maybe Interface)-decodeFile f = decodeInterface =<< liftIO (L.readFile f)+decodeFile f = runMaybeT (decodeInterface =<< liftIO (B.readFile f))++deserializeHashes :: ByteString -> IO (Maybe (Hash, Hash))+deserializeHashes bstr =+ (Just <$!> deserialize bstr)+ `E.catch` \(E.ErrorCall _) -> pure Nothing
src/full/Agda/TypeChecking/Serialise/Base.hs view
@@ -3,7 +3,11 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} -- Due to ICODE vararg typeclass+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RoleAnnotations #-} +{-# OPTIONS_GHC -Wunused-imports #-}+ {- András, 2023-10-2: @@ -14,102 +18,85 @@ be forced beforehand with strict `let`, strict binding or ($!). -} -module Agda.TypeChecking.Serialise.Base where+{-+-- Layout of Word32 +The unit of hash-consing is generally Word32, but it's used in different ways depending on the type+of the object that's being encoded.++- For enums and word-sized integral types, the Word32 is a direct unboxed representation of the+ data. 64-bit values get truncated (dodgy, but correct so far). Let's call these "unboxed types".+- For most types, the Word32 is an index into the corresponding hashtable.+- For Syntax.Internal.Term, the range [(maxBound - varTableSize) .. (maxBound - 1)] is used to+ represent terms of the form "Var i []" where "i" is in [0..varTableSize-1].+-}++module Agda.TypeChecking.Serialise.Base (+ module Agda.TypeChecking.Serialise.Node+ , module Agda.TypeChecking.Serialise.Base+ ) where+ import qualified Control.Exception as E-import Control.Monad ((<$!>))-import Control.Monad.Except-import Control.Monad.IO.Class ( MonadIO(..) ) import Control.Monad.Reader-import Control.Monad.State.Strict (StateT, gets) 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 Data.Word (Word32)+import Data.Word (Word32, Word64) import Data.Maybe-import qualified Data.Binary as B-import qualified Data.Binary.Get as B import qualified Data.Text as T import qualified Data.Text.Lazy as TL-import Data.Typeable ( cast, Typeable, TypeRep, typeRep, typeRepFingerprint )-import GHC.Exts (Word(..), timesWord2#, xor#, Any)+import Data.Typeable (Typeable, TypeRep, typeRep, typeRepFingerprint)+import GHC.Exts+import GHC.Float (castDoubleToWord64) import GHC.Fingerprint.Type+import GHC.Generics (Generic) import Unsafe.Coerce +import Agda.Syntax.Abstract.Name (Name, nameBindingSite) import Agda.Syntax.Common (NameId)-import Agda.Syntax.Internal (Term, QName(..), ModuleName(..), nameId)+import Agda.Syntax.Internal (QName(..), nameId, Term(..), varTable, varTableSize)+import Agda.Syntax.Position (Range) import Agda.TypeChecking.Monad.Base.Types (ModuleToSource)+import Agda.TypeChecking.Serialise.Node import Agda.Utils.FileName-import Agda.Utils.HashTable (HashTable)+import Agda.Utils.HashTable (HashTableLU, HashTableLL) import qualified Agda.Utils.HashTable as H import Agda.Utils.IORef-import Agda.Utils.Lens import Agda.Utils.List1 (List1) import Agda.Utils.Monad import Agda.Utils.TypeLevel+import Agda.Utils.VarSet (VarSet)+import Agda.Utils.CompactRegion (Compact)+import qualified Agda.Utils.MinimalArray.MutablePrim as MP+import qualified Agda.Utils.MinimalArray.Lifted as AL+import qualified Agda.Utils.MinimalArray.MutableLifted as ML+import qualified Agda.Utils.CompactRegion as Compact -#include <MachDeps.h> --- | Constructor tag (maybe omitted) and argument indices.-data Node = Empty | Cons !Word32 !Node deriving Eq--instance Hashable Node where- -- Adapted from https://github.com/tkaitchuck/aHash/wiki/AHash-fallback-algorithm- hashWithSalt h n = fromIntegral (go (fromIntegral h) n) where- xor (W# x) (W# y) = W# (xor# x y)-- foldedMul :: Word -> Word -> Word- foldedMul (W# x) (W# y) = case timesWord2# x y of (# hi, lo #) -> W# (xor# hi lo)-- combine :: Word -> Word -> Word- combine x y = foldedMul (xor x y) factor where- -- We use a version of fibonacci hashing, where our multiplier is the- -- nearest prime to 2^64/phi or 2^32/phi. See https://stackoverflow.com/q/4113278.-#if WORD_SIZE_IN_BITS == 64- factor = 11400714819323198549-#else- factor = 2654435741-#endif-- go :: Word -> Node -> Word- go !h Empty = h- go h (Cons n ns) = go (combine h (fromIntegral n)) ns-- hash = hashWithSalt seed where-#if WORD_SIZE_IN_BITS == 64- seed = 3032525626373534813-#else- seed = 1103515245-#endif--instance B.Binary Node where-- get = go =<< B.get where+-- Caching Var-s+-------------------------------------------------------------------------------- - go :: Int -> B.Get Node- go n | n <= 0 =- pure Empty- go n = do- !x <- B.get- !node <- go (n - 1)- pure $ Cons x node+{-# INLINE varRangeStart #-}+varRangeStart :: Word32+varRangeStart = maxBound - fromIntegral varTableSize - put n = B.put (len n) <> go n where+{-# INLINE cacheVar #-}+cacheVar :: Int -> Maybe Word32+cacheVar x =+ if x < varTableSize then+ Just $! varRangeStart + fromIntegral x+ else+ Nothing - len :: Node -> Int- len = go 0 where- go !acc Empty = acc- go acc (Cons _ n) = go (acc + 1) n+{-# INLINE uncacheVar #-}+uncacheVar :: Word32 -> Maybe Term+uncacheVar x =+ if varRangeStart <= x+ then Just $! AL.unsafeIndex varTable (fromIntegral (x - varRangeStart))+ else Nothing - go :: Node -> B.Put- go Empty = mempty- go (Cons n ns) = B.put n <> go ns+-------------------------------------------------------------------------------- -- | Association lists mapping TypeRep fingerprints to values. In some cases -- values with different types have the same serialized representation. This@@ -124,78 +111,103 @@ fingerprintNoinline rep = typeRepFingerprint rep {-# NOINLINE fingerprintNoinline #-} -lookupME :: forall a b. Proxy a -> Fingerprint -> MemoEntry -> (a -> b) -> b -> b-lookupME proxy fprint me found notfound = go fprint me where- go :: Fingerprint -> MemoEntry -> b+lookupME :: forall a. Proxy a -> Fingerprint -> MemoEntry -> (# a | (# #) #)+lookupME proxy fprint me = go fprint me where+ go :: Fingerprint -> MemoEntry -> (# a | (# #) #) go fp MEEmpty =- notfound+ (# | (# #) #) go fp (MECons fp' x me)- | fp == fp' = found (unsafeCoerce x)+ | fp == fp' = let res = unsafeCoerce x in (# res | #) | True = go fp me {-# NOINLINE lookupME #-} --- | Structure providing fresh identifiers for hash map--- and counting hash map hits (i.e. when no fresh identifier required).-#ifdef DEBUG_SERIALISATION-data FreshAndReuse = FreshAndReuse- { farFresh :: !Word32 -- ^ Number of hash map misses.- , farReuse :: !Word32 -- ^ Number of hash map hits.- }-#else-newtype FreshAndReuse = FreshAndReuse- { farFresh :: Word32 -- ^ Number of hash map misses.- }-#endif+type FreshAndReuse = MP.IOArray Word32 -farEmpty :: FreshAndReuse-farEmpty = FreshAndReuse 0-#ifdef DEBUG_SERIALISATION- 0-#endif+{-# INLINE bumpFresh #-}+bumpFresh :: FreshAndReuse -> IO Word32+bumpFresh arr = do+ !n <- MP.unsafeRead arr 0+ MP.unsafeWrite arr 0 (n + 1)+ pure n -lensFresh :: Lens' FreshAndReuse Word32-lensFresh f r = f (farFresh r) <&> \ i -> r { farFresh = i }-{-# INLINE lensFresh #-}+{-# INLINE bumpReuse #-}+bumpReuse :: FreshAndReuse -> IO ()+bumpReuse arr = do+ !n <- MP.unsafeRead arr 1+ MP.unsafeWrite arr 1 (n + 1) -#ifdef DEBUG_SERIALISATION-lensReuse :: Lens' FreshAndReuse Word32-lensReuse f r = f (farReuse r) <&> \ i -> r { farReuse = i }-{-# INLINE lensReuse #-}-#endif+farEmpty :: IO FreshAndReuse+farEmpty = do+ arr <- MP.new 2+ MP.unsafeWrite arr 0 0+ MP.unsafeWrite arr 1 0+ pure arr --- | Two 'QName's are equal if their @QNameId@ is equal.-type QNameId = [NameId]+getFresh :: FreshAndReuse -> IO Word32+getFresh far = MP.unsafeRead far 0 --- | Computing a qualified names composed ID.+getReuse :: FreshAndReuse -> IO Word32+getReuse far = MP.unsafeRead far 1++-- Andreas, 2026-03-12, issue #8465+-- | We need to distinguish 'A.Name's with different 'nameBindingSite',+-- so we complement the key 'NameId' with that 'Range'.+data NameIdR = NameIdR+ { nidNameId :: {-# UNPACK #-} !NameId+ , nidBindingSite :: !Range+ } deriving (Eq, Generic)++instance Hashable NameIdR where+ {-# INLINE hashWithSalt #-}+ hashWithSalt h (NameIdR a b) = h `hashWithSalt` a `hashWithSalt` b++-- | Computing a key of an abstract name.+nameIdR :: Name -> NameIdR+nameIdR x = NameIdR (nameId x) (nameBindingSite x)++-- | Two 'QName's are equal if their @NameId@ is equal.+type QNameId = NameIdR++-- | Computing a key of a qualified name. qnameId :: QName -> QNameId-qnameId (QName (MName ns) n) = map nameId $ n:ns+qnameId = nameIdR . qnameName -- | State of the the encoder. data Dict = Dict -- Dictionaries which are serialized:- { nodeD :: !(HashTable Node Word32) -- ^ Written to interface file.- , stringD :: !(HashTable String Word32) -- ^ Written to interface file.- , lTextD :: !(HashTable TL.Text Word32) -- ^ Written to interface file.- , sTextD :: !(HashTable T.Text Word32) -- ^ Written to interface file.- , integerD :: !(HashTable Integer Word32) -- ^ Written to interface file.- , doubleD :: !(HashTable Double Word32) -- ^ Written to interface file.+ { nodeD :: !(HashTableLU Node Word32) -- ^ Written to interface file.+ , stringD :: !(HashTableLU String Word32) -- ^ Written to interface file.+ , lTextD :: !(HashTableLU TL.Text Word32) -- ^ Written to interface file.+ , sTextD :: !(HashTableLU T.Text Word32) -- ^ Written to interface file.+ , integerD :: !(HashTableLU Integer Word32) -- ^ Written to interface file.+ , varSetD :: !(HashTableLU VarSet Word32) -- ^ Written to interface file.+ -- Andreas, 2026-08-29, issue #8697:+ -- The 'Double' dictionary is keyed by the /bit pattern/ of the 'Double',+ -- because the 'Eq Double' instance identifies @0.0@ and @-0.0@, which+ -- would make hash-consing conflate these two distinct literals.+ -- (This is the inconsistency of issue #2169, which is why 'Eq Literal'+ -- compares 'Double's bitwise.)+ , doubleD :: !(HashTableLU Word64 Word32) -- ^ Written to interface file (as 'Double's). -- Dicitionaries which are not serialized, but provide -- short cuts to speed up serialization: -- Andreas, Makoto, AIM XXI -- Memoizing A.Name does not buy us much if we already memoize A.QName.- , nameD :: !(HashTable NameId Word32) -- ^ Not written to interface file.- , qnameD :: !(HashTable QNameId Word32) -- ^ Not written to interface file.+ -- Andreas, 2026-03-12+ -- Memoizing A.Name saves ~17% of serialization time (25s -> 21s for std-lib).+ , nameD :: !(HashTableLU NameIdR Word32) -- ^ Not written to interface file.+ , qnameD :: !(HashTableLU QNameId Word32) -- ^ Not written to interface file. -- Fresh UIDs and reuse statistics:- , nodeC :: !(IORef FreshAndReuse) -- counters for fresh indexes- , stringC :: !(IORef FreshAndReuse)- , lTextC :: !(IORef FreshAndReuse)- , sTextC :: !(IORef FreshAndReuse)- , integerC :: !(IORef FreshAndReuse)- , doubleC :: !(IORef FreshAndReuse)- , termC :: !(IORef FreshAndReuse)- , nameC :: !(IORef FreshAndReuse)- , qnameC :: !(IORef FreshAndReuse)- , stats :: !(HashTable String Int)+ , nodeC :: !FreshAndReuse -- counters for fresh indexes+ , stringC :: !FreshAndReuse+ , lTextC :: !FreshAndReuse+ , sTextC :: !FreshAndReuse+ , integerC :: !FreshAndReuse+ , varSetC :: !FreshAndReuse+ , doubleC :: !FreshAndReuse+ , termC :: !FreshAndReuse+ , nameC :: !FreshAndReuse+ , qnameC :: !FreshAndReuse+ , stats :: !(HashTableLU String Int) , collectStats :: !Bool -- ^ If @True@ collect in @stats@ the quantities of -- calls to @icode@ for each @Typeable a@.@@ -207,73 +219,80 @@ -- ^ Collect statistics for @icode@ calls? -> IO Dict emptyDict collectStats = Dict- <$> H.empty- <*> H.empty- <*> H.empty- <*> H.empty- <*> H.empty- <*> H.empty- <*> H.empty- <*> H.empty- <*> newIORef farEmpty- <*> newIORef farEmpty- <*> newIORef farEmpty- <*> newIORef farEmpty- <*> newIORef farEmpty- <*> newIORef farEmpty- <*> newIORef farEmpty- <*> newIORef farEmpty- <*> newIORef farEmpty- <*> H.empty- <*> pure collectStats+ <$!> H.empty+ <*!> H.empty+ <*!> H.empty+ <*!> H.empty+ <*!> H.empty+ <*!> H.empty+ <*!> H.empty+ <*!> H.empty+ <*!> H.empty+ <*!> farEmpty+ <*!> farEmpty+ <*!> farEmpty+ <*!> farEmpty+ <*!> farEmpty+ <*!> farEmpty+ <*!> farEmpty+ <*!> farEmpty+ <*!> farEmpty+ <*!> farEmpty+ <*!> H.empty+ <*!> pure collectStats --- | Univeral memo structure, to introduce sharing during decoding-type Memo = IOArray Word32 MemoEntry+-- | Decoder arguments.+data Decode = Decode+ { nodeMemo :: !(ML.IOArray MemoEntry) -- ^ Created and modified by decoder.+ -- Used to introduce sharing while deserializing objects.+ , arena :: !Compact -- ^ Compact region where the decoded interface+ -- is allocated.+ , nodeA :: !(AL.Array Node) -- ^ Obtained from interface.+ , stringA :: !(AL.Array String) -- ^ Obtained from interface.+ , lTextA :: !(AL.Array TL.Text) -- ^ Obtained from interface.+ , sTextA :: !(AL.Array T.Text) -- ^ Obtained from interface.+ , integerA :: !(AL.Array Integer) -- ^ Obtained from interface.+ , varSetA :: !(AL.Array VarSet) -- ^ Obtained from interface.+ , doubleA :: !(AL.Array Double) -- ^ Obtained from interface. --- | State of the decoder.-data St = St- { nodeE :: !(Array Word32 [Word32]) -- ^ Obtained from interface file.- , stringE :: !(Array Word32 String) -- ^ Obtained from interface file.- , lTextE :: !(Array Word32 TL.Text) -- ^ Obtained from interface file.- , sTextE :: !(Array Word32 T.Text) -- ^ Obtained from interface file.- , integerE :: !(Array Word32 Integer) -- ^ Obtained from interface file.- , doubleE :: !(Array Word32 Double) -- ^ Obtained from interface file.- , nodeMemo :: !Memo- -- ^ Created and modified by decoder.- -- Used to introduce sharing while deserializing objects.- , modFile :: !ModuleToSource+ , filePathMemo :: !(HashTableLL AbsolutePath AbsolutePath)+ -- ^ Memoizes filepaths computed for RangeFile-s.+ , modFile :: !(IORef ModuleToSource) -- ^ Maps module names to file names. Constructed by the decoder. , includes :: !(List1 AbsolutePath) -- ^ The include directories. } -- | Monad used by the encoder.- type S a = ReaderT Dict IO a -- | Monad used by the decoder. -- -- 'TCM' is not used because the associated overheads would make -- decoding slower.--type R = StateT St IO---- | Throws an error which is suitable when the data stream is--- malformed.+type R = ReaderT Decode IO malformed :: R a malformed = liftIO $ E.throwIO $ E.ErrorCall "Malformed input." {-# NOINLINE malformed #-} -- 2023-10-2 András: cold code, so should be out-of-line. +malformedIO :: IO a+malformedIO = E.throwIO $ E.ErrorCall "Malformed input."+{-# NOINLINE malformedIO #-}+ class Typeable a => EmbPrj a where icode :: a -> S Word32 -- ^ Serialization (wrapper). icod_ :: a -> S Word32 -- ^ Serialization (worker). value :: Word32 -> R a -- ^ Deserialization. +#ifdef DEBUG_SERIALISATION icode a = do !r <- icod_ a tickICode a pure r+#else+ icode a = icod_ a+#endif {-# INLINE icode #-} -- Simple enumeration types can be (de)serialized using (from/to)Enum.@@ -284,7 +303,7 @@ then pure $! toEnum i' else malformed - default icod_ :: (Enum a, Bounded a) => a -> S Word32+ default icod_ :: (Enum a) => a -> S Word32 icod_ x = return $! fromIntegral $! fromEnum x -- | The actual logic of `tickICode` is cold code, so it's out-of-line,@@ -303,213 +322,264 @@ tickICode _ = whenM (asks collectStats) $ goTickIcode (Proxy :: Proxy a) {-# INLINE tickICode #-} --- | Data.Binary.runGetState is deprecated in favour of runGetIncremental.--- Reimplementing it in terms of the new function. The new Decoder type contains--- strict byte strings so we need to be careful not to feed the entire lazy byte--- string to the decoder at once.-runGetState :: B.Get a -> L.ByteString -> B.ByteOffset -> (a, L.ByteString, B.ByteOffset)-runGetState g s n = feed (B.runGetIncremental g) (L.toChunks s)- where- feed (B.Done s n' x) ss = (x, L.fromChunks (s : ss), n + n')- feed (B.Fail _ _ err) _ = error err- feed (B.Partial f) (s : ss) = feed (f $ Just s) ss- feed (B.Partial f) [] = feed (f Nothing) []---- Specializing icodeX leads to Warning like--- src/full/Agda/TypeChecking/Serialise.hs:1297:1: Warning:--- RULE left-hand side too complicated to desugar--- case cobox_aQY5 of _ [Occ=Dead] { ghc-prim:GHC.Types.Eq# cobox ->--- icodeX @ String $dEq_aQY3 $dHashable_aQY4--- }------ type ICodeX k--- = (Dict -> HashTable k Word32)--- -> (Dict -> IORef Word32)--- -> k -> S Word32--- {-# SPECIALIZE icodeX :: ICodeX String #-}--- {-# SPECIALIZE icodeX :: ICodeX Integer #-}--- {-# SPECIALIZE icodeX :: ICodeX Double #-}--- {-# SPECIALIZE icodeX :: ICodeX Node #-}---- Andreas, 2014-10-16 AIM XX:--- Inlining this increases Serialization time by 10%--- Makoto's theory: code size increase might lead to--- instruction cache misses.--- {-# INLINE icodeX #-}-icodeX :: (Eq k, Hashable k)- => (Dict -> HashTable k Word32)- -> (Dict -> IORef FreshAndReuse)- -> k -> S Word32-icodeX dict counter key = do- d <- asks dict- c <- asks counter- liftIO $ do- mi <- H.lookup d key- case mi of- Just i -> do+icodeLText :: TL.Text -> S Word32+icodeLText key = do+ d <- asks lTextD+ c <- asks lTextC+ liftIO $+ H.insertingIfAbsent d key+ (\i -> do #ifdef DEBUG_SERIALISATION- modifyIORef' c $ over lensReuse (+ 1)+ bumpReuse c #endif- return $! i- Nothing -> do- !fresh <- (^. lensFresh) <$> do readModifyIORef' c $ over lensFresh (+ 1)- H.insert d key fresh- return fresh+ pure i)+ (bumpFresh c)+ pure --- Instead of inlining icodeX, we manually specialize it to--- its four uses: Integer, String, Double, Node.--- Not a great gain (hardly noticeable), but not harmful.+icodeSText :: T.Text -> S Word32+icodeSText key = do+ d <- asks sTextD+ c <- asks sTextC+ liftIO $+ H.insertingIfAbsent d key+ (\i -> do+#ifdef DEBUG_SERIALISATION+ bumpReuse c+#endif+ pure i)+ (bumpFresh c)+ pure icodeInteger :: Integer -> S Word32 icodeInteger key = do d <- asks integerD c <- asks integerC- liftIO $ do- mi <- H.lookup d key- case mi of- Just i -> do+ liftIO $+ H.insertingIfAbsent d key+ (\i -> do #ifdef DEBUG_SERIALISATION- modifyIORef' c $ over lensReuse (+ 1)+ bumpReuse c #endif- return $! i- Nothing -> do- !fresh <- (^. lensFresh) <$> do readModifyIORef' c $ over lensFresh (+ 1)- H.insert d key fresh- return fresh+ pure i)+ (bumpFresh c)+ pure +icodeVarSet :: VarSet -> S Word32+icodeVarSet key = do+ d <- asks varSetD+ c <- asks varSetC+ liftIO $+ H.insertingIfAbsent d key+ (\i -> do+#ifdef DEBUG_SERIALISATION+ bumpReuse c+#endif+ pure i)+ (bumpFresh c)+ pure+ icodeDouble :: Double -> S Word32 icodeDouble key = do d <- asks doubleD c <- asks doubleC- liftIO $ do- mi <- H.lookup d key- case mi of- Just i -> do+ liftIO $+ -- Key on the bit pattern, not on the 'Double' itself, see 'doubleD'.+ H.insertingIfAbsent d (castDoubleToWord64 key)+ (\i -> do #ifdef DEBUG_SERIALISATION- modifyIORef' c $ over lensReuse (+ 1)+ bumpReuse c #endif- return $! i- Nothing -> do- !fresh <- (^. lensFresh) <$> do readModifyIORef' c $ over lensFresh (+ 1)- H.insert d key fresh- return fresh+ pure i)+ (bumpFresh c)+ pure icodeString :: String -> S Word32 icodeString key = do d <- asks stringD c <- asks stringC- liftIO $ do- mi <- H.lookup d key- case mi of- Just i -> do+ liftIO $+ H.insertingIfAbsent d key+ (\i -> do #ifdef DEBUG_SERIALISATION- modifyIORef' c $ over lensReuse (+ 1)+ bumpReuse c #endif- return i- Nothing -> do- !fresh <- (^. lensFresh) <$> do readModifyIORef' c $ over lensFresh (+ 1)- H.insert d key fresh- return fresh+ pure i)+ (bumpFresh c)+ pure icodeNode :: Node -> S Word32 icodeNode key = do d <- asks nodeD c <- asks nodeC- liftIO $ do- mi <- H.lookup d key- case mi of- Just i -> do+ liftIO $+ H.insertingIfAbsent d key+ (\i -> do #ifdef DEBUG_SERIALISATION- modifyIORef' c $ over lensReuse (+ 1)+ bumpReuse c #endif- return $! i- Nothing -> do- !fresh <- (^. lensFresh) <$> do readModifyIORef' c $ over lensFresh (+ 1)- H.insert d key fresh- return fresh+ pure i)+ (bumpFresh c)+ pure --- icodeN :: [Word32] -> S Word32--- icodeN = icodeX nodeD nodeC --- | @icode@ only if thing has not seen before.+-- | @icode@ only if thing has not been seen before. icodeMemo- :: (Ord a, Hashable a)- => (Dict -> HashTable a Word32) -- ^ Memo structure for thing of key @a@.- -> (Dict -> IORef FreshAndReuse) -- ^ Statistics.+ :: (Hashable a)+ => (Dict -> HashTableLU a Word32) -- ^ Memo structure for thing of key @a@.+ -> (Dict -> FreshAndReuse) -- ^ Counter and statistics. -> a -- ^ Key to the thing. -> S Word32 -- ^ Fallback computation to encode the thing. -> S Word32 -- ^ Encoded thing.-icodeMemo getDict getCounter a icodeP = do- h <- asks getDict- mi <- liftIO $ H.lookup h a- st <- asks getCounter- case mi of- Just i -> liftIO $ do+icodeMemo getDict getCounter a icodeP = ReaderT \dict -> do+ let !c = getCounter dict+ !d = getDict dict+ H.insertingIfAbsent d a+ (\i -> do #ifdef DEBUG_SERIALISATION- modifyIORef' st $ over lensReuse (+ 1)+ bumpReuse c #endif- return $! i- Nothing -> do- liftIO $ modifyIORef' st $ over lensFresh (+ 1)- !i <- icodeP- liftIO $ H.insert h a i- return i+ pure i)+ (do _ <- bumpFresh c+ runReaderT icodeP dict)+ pure+{-# INLINE icodeMemo #-} +-- icodeMemo+-- :: (Ord a, Hashable a)+-- => (Dict -> HashTable a Word32) -- ^ Memo structure for thing of key @a@.+-- -> (Dict -> FreshAndReuse) -- ^ Counter and statistics.+-- -> a -- ^ Key to the thing.+-- -> S Word32 -- ^ Fallback computation to encode the thing.+-- -> S Word32 -- ^ Encoded thing.+-- icodeMemo getDict getCounter a icodeP = do+-- h <- asks getDict+-- mi <- liftIO $ H.lookup h a+-- c <- asks getCounter+-- case mi of+-- Just i -> liftIO $ do+-- #ifdef DEBUG_SERIALISATION+-- liftIO $ bumpReuse c+-- #endif+-- return $! i+-- Nothing -> do+-- !fresh <- liftIO $ bumpFresh c+-- !i <- icodeP+-- liftIO $ H.insert h a i+-- return i+ {-# INLINE vcase #-} -- | @vcase value ix@ decodes thing represented by @ix :: Word32@ -- via the @valu@ function and stores it in 'nodeMemo'. -- If @ix@ is present in 'nodeMemo', @valu@ is not used, but -- the thing is read from 'nodeMemo' instead.-vcase :: forall a . EmbPrj a => ([Word32] -> R a) -> Word32 -> R a-vcase valu = \ix -> do- memo <- gets nodeMemo- let fp = fingerprintNoinline (typeRep (Proxy :: Proxy a))+vcase :: forall a . EmbPrj a => (Node -> R a) -> Word32 -> R a+vcase valu = \ix -> ReaderT \dict -> do+ let !memo = nodeMemo dict++ let !fp = fingerprintNoinline (typeRep (Proxy :: Proxy a)) -- to introduce sharing, see if we have seen a thing -- represented by ix before- slot <- liftIO $ readArray memo ix- lookupME (Proxy :: Proxy a) fp slot+ let !iix = fromIntegral ix :: Int+ !slot <- ML.read memo iix+ case lookupME (Proxy :: Proxy a) fp slot of -- use the stored value- pure- -- read new value and save it- do !v <- valu . (! ix) =<< gets nodeE- liftIO $ writeArray memo ix $! MECons fp (unsafeCoerce v) slot- return v+ (# a | #) ->+ pure a+ _ -> do+ !v <- runReaderT (valu (AL.index (nodeA dict) iix)) dict+ !v <- Compact.add (arena dict) v+ ML.write memo iix $! MECons fp (unsafeCoerce v) slot+ return v ++-- Arity-generic functions+----------------------------------------------------------------------------------------------------+ -- | @icodeArgs proxy (a1, ..., an)@ maps @icode@ over @a1@, ..., @an@ -- and returns the corresponding list of @Word32@.--class ICODE t b where- icodeArgs :: IsBase t ~ b => All EmbPrj (Domains t) =>+class ICODE t (a :: Nat) where+ icodeArgs :: Arity t ~ a => All EmbPrj (Domains t) => Proxy t -> StrictProducts (Domains t) -> S Node -instance IsBase t ~ 'True => ICODE t 'True where- icodeArgs _ _ = return Empty+instance ICODE t 'Zero where+ icodeArgs _ _ = return N0 {-# INLINE icodeArgs #-} -instance ICODE t (IsBase t) => ICODE (a -> t) 'False where- icodeArgs _ (Pair a as) = do- !hd <- icode a- !node <- icodeArgs (Proxy :: Proxy t) as- pure $ Cons hd node+instance ICODE (a -> t) ('Suc 'Zero) where+ icodeArgs _ (Pair a _) = do+ !a <- icode a+ pure $ N1 a {-# INLINE icodeArgs #-} +instance ICODE (a -> b -> t) ('Suc ('Suc 'Zero)) where+ icodeArgs _ (Pair a (Pair b _)) = do+ !a <- icode a+ !b <- icode b+ pure $ N2 a b+ {-# INLINE icodeArgs #-}++instance ICODE (a -> b -> c -> t) ('Suc ('Suc ('Suc 'Zero))) where+ icodeArgs _ (Pair a (Pair b (Pair c _))) = do+ !a <- icode a+ !b <- icode b+ !c <- icode c+ pure $ N3 a b c+ {-# INLINE icodeArgs #-}++instance ICODE (a -> b -> c -> d -> t) ('Suc ('Suc ('Suc ('Suc 'Zero)))) where+ icodeArgs _ (Pair a (Pair b (Pair c (Pair d _)))) = do+ !a <- icode a+ !b <- icode b+ !c <- icode c+ !d <- icode d+ pure $ N4 a b c d+ {-# INLINE icodeArgs #-}++instance ICODE (a -> b -> c -> d -> e -> t) ('Suc ('Suc ('Suc ('Suc ('Suc 'Zero))))) where+ icodeArgs _ (Pair a (Pair b (Pair c (Pair d (Pair e _))))) = do+ !a <- icode a+ !b <- icode b+ !c <- icode c+ !d <- icode d+ !e <- icode e+ pure $ N5 a b c d e+ {-# INLINE icodeArgs #-}++instance ICODE t n+ => ICODE (a -> b -> c -> d -> e -> f -> t)+ ('Suc ('Suc ('Suc ('Suc ('Suc ('Suc n)))))) where+ icodeArgs _ (Pair a (Pair b (Pair c (Pair d (Pair e (Pair f n)))))) = do+ !a <- icode a+ !b <- icode b+ !c <- icode c+ !d <- icode d+ !e <- icode e+ !f <- icode f+ !n <- icodeArgs (Proxy :: Proxy t) n+ pure $ N6 a b c d e f n+ {-# INLINE icodeArgs #-}+ -- | @icodeN tag t a1 ... an@ serialises the arguments @a1@, ..., @an@ of the -- constructor @t@ together with a tag @tag@ picked to disambiguate between -- different constructors. -- It corresponds to @icodeNode . (tag :) =<< mapM icode [a1, ..., an]@ {-# INLINE icodeN #-}-icodeN :: forall t. ICODE t (IsBase t) => StrictCurrying (Domains t) (S Word32) =>- All EmbPrj (Domains t) =>+icodeN :: forall t. ICODE (Word32 -> t) (Arity (Word32 -> t))+ => StrictCurrying (Domains (Word32 -> t)) (S Word32)+ => All EmbPrj (Domains (Word32 -> t)) => Word32 -> t -> Arrows (Domains t) (S Word32) icodeN tag _ =- strictCurrys (Proxy :: Proxy (Domains t)) (Proxy :: Proxy (S Word32)) $ \ !args -> do- !node <- icodeArgs (Proxy :: Proxy t) args- icodeNode $ Cons tag node+ strictCurrys+ (Proxy :: Proxy (Domains (Word32 -> t)))+ (Proxy :: Proxy (S Word32))+ (\ !args -> do !node <- icodeArgs (Proxy :: Proxy (Word32 -> t)) args+ icodeNode node)+ tag -- | @icodeN'@ is the same as @icodeN@ except that there is no tag {-# INLINE icodeN' #-}-icodeN' :: forall t. ICODE t (IsBase t) => StrictCurrying (Domains t) (S Word32) =>+icodeN' :: forall t. ICODE t (Arity t) => StrictCurrying (Domains t) (S Word32) => All EmbPrj (Domains t) => t -> Arrows (Domains t) (S Word32) icodeN' _ =@@ -517,44 +587,113 @@ !node <- icodeArgs (Proxy :: Proxy t) args icodeNode node + -- Instead of having up to 25 versions of @valu N@, we define -- the class VALU which generates them by typeclass resolution. -- All of these should get inlined at compile time. -class VALU t b where-- valuN' :: b ~ IsBase t =>+class VALU t (a :: Nat) where+ valuN' :: a ~ Arity t => All EmbPrj (Domains t) => t -> StrictProducts (Constant Word32 (Domains t)) -> R (CoDomain t) - valueArgs :: b ~ IsBase t =>+ valueArgs :: a ~ Arity t => All EmbPrj (CoDomain t ': Domains t) =>- Proxy t -> [Word32] -> Maybe (StrictProducts (Constant Word32 (Domains t)))+ Proxy t -> Node -> Maybe (StrictProducts (Constant Word32 (Domains t))) -instance VALU t 'True where+instance VALU t 'Zero where {-# INLINE valuN' #-}- valuN' c () = return c-+ valuN' f _ = return f {-# INLINE valueArgs #-} valueArgs _ xs = case xs of- [] -> Just ()+ N0 -> Just () _ -> Nothing +instance VALU (a -> t) ('Suc 'Zero) where+ {-# INLINE valuN' #-}+ valuN' f (Pair a _) = do+ !a <- value a+ return $! f a+ {-# INLINE valueArgs #-}+ valueArgs _ xs = case xs of+ N1 a -> Just (Pair a ())+ _ -> Nothing -instance VALU t (IsBase t) => VALU (a -> t) 'False where+instance VALU (a -> b -> t) ('Suc ('Suc 'Zero)) where {-# INLINE valuN' #-}- valuN' c (Pair a as) = do- !v <- value a- let !cv = c v- valuN' cv as+ valuN' f (Pair a (Pair b _)) = do+ !a <- value a+ !b <- value b+ return $! f a b+ {-# INLINE valueArgs #-}+ valueArgs _ xs = case xs of+ N2 a b -> Just (Pair a (Pair b ()))+ _ -> Nothing +instance VALU (a -> b -> c -> t) ('Suc ('Suc ('Suc 'Zero))) where+ {-# INLINE valuN' #-}+ valuN' f (Pair a (Pair b (Pair c _))) = do+ !a <- value a+ !b <- value b+ !c <- value c+ return $! f a b c {-# INLINE valueArgs #-} valueArgs _ xs = case xs of- x : xs' -> Pair x <$!> valueArgs (Proxy :: Proxy t) xs'- _ -> Nothing+ N3 a b c -> Just (Pair a (Pair b (Pair c ())))+ _ -> Nothing +instance VALU (a -> b -> c -> d -> t) ('Suc ('Suc ('Suc ('Suc 'Zero)))) where+ {-# INLINE valuN' #-}+ valuN' f (Pair a (Pair b (Pair c (Pair d _)))) = do+ !a <- value a+ !b <- value b+ !c <- value c+ !d <- value d+ return $! f a b c d+ {-# INLINE valueArgs #-}+ valueArgs _ xs = case xs of+ N4 a b c d -> Just (Pair a (Pair b (Pair c (Pair d ()))))+ _ -> Nothing++instance VALU (a -> b -> c -> d -> e -> t) ('Suc ('Suc ('Suc ('Suc ('Suc 'Zero))))) where+ {-# INLINE valuN' #-}+ valuN' f (Pair a (Pair b (Pair c (Pair d (Pair e _))))) = do+ !a <- value a+ !b <- value b+ !c <- value c+ !d <- value d+ !e <- value e+ return $! f a b c d e+ {-# INLINE valueArgs #-}+ valueArgs _ xs = case xs of+ N5 a b c d e -> Just (Pair a (Pair b (Pair c (Pair d (Pair e ())))))+ _ -> Nothing++instance VALU t n+ => VALU (a -> b -> c -> d -> e -> f -> t)+ ('Suc ('Suc ('Suc ('Suc ('Suc ('Suc n)))))) where+ {-# INLINE valuN' #-}+ valuN' fun (Pair a (Pair b (Pair c (Pair d (Pair e (Pair f n)))))) = do+ !a <- value a+ !b <- value b+ !c <- value c+ !d <- value d+ !e <- value e+ !f <- value f+ let !fun' = fun a b c d e f+ valuN' fun' n++ {-# INLINE valueArgs #-}+ valueArgs _ xs = case xs of+ N6 a b c d e f n -> do+ !n <- valueArgs (Proxy :: Proxy t) n+ Just (Pair a (Pair b (Pair c (Pair d (Pair e (Pair f n))))))+ _ -> Nothing++--------------------------------------------------------------------------------+ {-# INLINE valuN #-}-valuN :: forall t. VALU t (IsBase t) =>+valuN :: forall t. VALU t (Arity t) => StrictCurrying (Constant Word32 (Domains t)) (R (CoDomain t)) => All EmbPrj (Domains t) => t -> Arrows (Constant Word32 (Domains t)) (R (CoDomain t))@@ -563,10 +702,9 @@ (valuN' f) {-# INLINE valueN #-}-valueN :: forall t. VALU t (IsBase t) =>+valueN :: forall t. VALU t (Arity t) => All EmbPrj (CoDomain t ': Domains t) => t -> Word32 -> R (CoDomain t)-valueN t = vcase valu where- valu int32s = case valueArgs (Proxy :: Proxy t) int32s of- Nothing -> malformed- Just vs -> valuN' t vs+valueN t = vcase \n -> case valueArgs (Proxy :: Proxy t) n of+ Nothing -> malformed+ Just vs -> valuN' t vs
src/full/Agda/TypeChecking/Serialise/Instances.hs view
@@ -1,5 +1,4 @@ {-# OPTIONS_GHC -Wunused-imports #-}- {-# OPTIONS_GHC -fno-warn-orphans #-} -- Only instances exported@@ -10,8 +9,9 @@ import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Serialise.Base import Agda.TypeChecking.Serialise.Instances.Common (SerialisedRange(..))-import Agda.TypeChecking.Serialise.Instances.Highlighting () import Agda.TypeChecking.Serialise.Instances.Errors ()+import Agda.TypeChecking.Serialise.Instances.General ()+import Agda.TypeChecking.Serialise.Instances.Highlighting () import Agda.Utils.Hash type RangedImportedModules =
src/full/Agda/TypeChecking/Serialise/Instances/Abstract.hs view
@@ -1,27 +1,33 @@ {-# OPTIONS_GHC -Wunused-imports #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Agda.TypeChecking.Serialise.Instances.Abstract where import Control.Monad+import Control.Monad.Reader++import Data.HashMap.Strict qualified as HMap+import Data.Map qualified as Map+import Data.Set qualified as Set import Data.Void (Void)-import qualified Data.Map as Map-import qualified Data.Set as Set -import Agda.Syntax.Common-import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Abstract.Name+ ( AbstractName(..), AbstractModule(..), KindOfName, NameMetadata(..), WhyInScope(..) )+import Agda.Syntax.Abstract qualified as A import Agda.Syntax.Abstract.Pattern ( noDotOrEqPattern )+import Agda.Syntax.Common+import Agda.Syntax.Fixity import Agda.Syntax.Info+import Agda.Syntax.Position import Agda.Syntax.Scope.Base-import Agda.Syntax.Fixity import Agda.TypeChecking.Serialise.Base-import Agda.TypeChecking.Serialise.Instances.Common () --instance only+import Agda.TypeChecking.Serialise.Instances.Common (SerialisedRange(..)) import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.Null+ import Agda.Utils.Impossible -- Don't serialize the tactic.@@ -66,20 +72,24 @@ _ -> malformed instance EmbPrj NameSpace where- icod_ (NameSpace a b c) = icodeN' NameSpace a b c+ icod_ (NameSpace a b c d) = icodeN' NameSpace a b c d value = valueN NameSpace +-- Andreas, 2025-10-23:+-- We serialize the Ranges in WhyInScope+-- so that we have then e.g. in the ClashingDefinition error.+ instance EmbPrj WhyInScope where icod_ Defined = icodeN' Defined- icod_ (Opened a b) = icodeN 0 Opened a b- icod_ (Applied a b) = icodeN 1 Applied a b+ icod_ (Opened a b) = icodeN 0 (\(_ :: SerialisedRange) -> Opened) (SerialisedRange (getRange a)) a b+ icod_ (Applied a b) = icodeN 1 (\(_ :: SerialisedRange) -> Applied) (SerialisedRange (getRange a)) a b - value = vcase valu where- valu [] = valuN Defined- valu [0, a, b] = valuN Opened a b- valu [1, a, b] = valuN Applied a b- valu _ = malformed+ value = vcase \case+ N0 -> valuN Defined+ (N4 0 r a b) -> valuN (\(SerialisedRange r) a b -> Opened (setRange r a) b) r a b+ (N4 1 r a b) -> valuN (\(SerialisedRange r) a b -> Applied (setRange r a) b) r a b+ _ -> malformed -- Issue #1346: QNames are shared on their nameIds, so serializing will lose fixity information for -- rebound fixities. We don't care about that in terms, but in the scope it's important to keep the@@ -102,22 +112,17 @@ value = toAbsName <.> value instance EmbPrj NameMetadata where- icod_ NoMetadata = icodeN' NoMetadata- icod_ (GeneralizedVarsMetadata a) = icodeN' GeneralizedVarsMetadata a-- value = vcase valu where- valu [] = valuN NoMetadata- valu [a] = valuN GeneralizedVarsMetadata a- valu _ = malformed+ icod_ (NameMetadata a b) = icodeN' NameMetadata a b+ value = valueN NameMetadata instance EmbPrj A.Suffix where icod_ A.NoSuffix = icodeN' A.NoSuffix icod_ (A.Suffix a) = icodeN' A.Suffix a value = vcase valu where- valu [] = valuN A.NoSuffix- valu [a] = valuN A.Suffix a- valu _ = malformed+ valu N0 = valuN A.NoSuffix+ valu (N1 a) = valuN A.Suffix a+ valu _ = malformed instance EmbPrj AbstractModule where icod_ (AbsModule a b) = icodeN' AbsModule a b@@ -125,27 +130,7 @@ value = valueN AbsModule instance EmbPrj KindOfName where- -- -- Enums have a generic EmbPrj- --- -- icod_ DefName = icodeN' DefName- -- icod_ ConName = icodeN 1 ConName- -- icod_ FldName = icodeN 2 FldName- -- icod_ PatternSynName = icodeN 3 PatternSynName- -- icod_ QuotableName = icodeN 4 QuotableName- -- icod_ MacroName = icodeN 5 MacroName- -- icod_ GeneralizeName = icodeN 6 GeneralizeName- -- icod_ DisallowedGeneralizeName = icodeN 7 DisallowedGeneralizeName-- -- value = vcase valu where- -- valu [] = valuN DefName- -- valu [1] = valuN ConName- -- valu [2] = valuN FldName- -- valu [3] = valuN PatternSynName- -- valu [4] = valuN QuotableName- -- valu [5] = valuN MacroName- -- valu [6] = valuN GeneralizeName- -- valu [7] = valuN DisallowedGeneralizeName- -- valu _ = malformed+ -- Enums have a generic EmbPrj instance EmbPrj BindingSource where icod_ = \case@@ -177,34 +162,36 @@ -- Only for pattern synonyms (where a is Void) instance EmbPrj a => EmbPrj (A.Pattern' a) where- icod_ (A.VarP a) = icodeN 0 A.VarP a- icod_ (A.ConP a b c) = icodeN 1 A.ConP a b c- icod_ (A.DefP p a b) = icodeN 2 (A.DefP p) a b- icod_ t@(A.WildP p) = icodeN 3 t- icod_ (A.AsP p a b) = icodeN 4 (A.AsP p) a b- icod_ (A.DotP r a) = icodeN 5 (A.DotP r) a- icod_ t@(A.AbsurdP _) = icodeN 6 t- icod_ (A.LitP i a) = icodeN 7 (A.LitP i) a- icod_ (A.ProjP p a b) = icodeN 8 (A.ProjP p) a b- icod_ (A.PatternSynP p a b) = icodeN 9 (A.PatternSynP p) a b- icod_ (A.RecP r a b) = icodeN 10 (A.RecP r) a b- icod_ (A.EqualP _ a) = __IMPOSSIBLE__- icod_ (A.WithP i a) = icodeN 11 (A.WithP i) a+ icod_ x = ReaderT \dict -> case x of+ (A.VarP a) -> runReaderT (icodeN 0 A.VarP a) dict+ (A.ConP a b c) -> runReaderT (icodeN 1 A.ConP a b c) dict+ (A.DefP p a b) -> runReaderT (icodeN 2 (A.DefP p) a b) dict+ t@(A.WildP p) -> runReaderT (icodeN 3 t) dict+ (A.AsP p a b) -> runReaderT (icodeN 4 (A.AsP p) a b) dict+ (A.DotP r a) -> runReaderT (icodeN 5 (A.DotP r) a) dict+ t@(A.AbsurdP _) -> runReaderT (icodeN 6 t) dict+ (A.LitP i a) -> runReaderT (icodeN 7 (A.LitP i) a) dict+ (A.ProjP p a b) -> runReaderT (icodeN 8 (A.ProjP p) a b) dict+ (A.PatternSynP p a b) -> runReaderT (icodeN 9 (A.PatternSynP p) a b) dict+ (A.RecP r a b) -> runReaderT (icodeN 10 (A.RecP r) a b) dict+ (A.EqualP _ a) -> __IMPOSSIBLE__ dict+ (A.WithP i a) -> runReaderT (icodeN 11 (A.WithP i) a) dict - value = vcase valu where- valu [0, a] = valuN A.VarP a- valu [1, a, b, c] = valuN A.ConP a b c- valu [2, a, b] = valuN (A.DefP i) a b- valu [3] = valuN (A.WildP i)- valu [4, a, b] = valuN (A.AsP i) a b- valu [5, a] = valuN (A.DotP i) a- valu [6] = valuN (A.AbsurdP i)- valu [7, a] = valuN (A.LitP i) a- valu [8, a, b] = valuN (A.ProjP i) a b- valu [9, a, b] = valuN (A.PatternSynP i) a b- valu [10, a, b] = valuN (A.RecP empty) a b- valu [11, a] = valuN (A.WithP i) a- valu _ = malformed+ value x = ReaderT \dict -> runReaderT (vcase valu x) dict where+ valu x = ReaderT \dict -> case x of+ (N2 0 a) -> runReaderT (valuN A.VarP a) dict+ (N4 1 a b c) -> runReaderT (valuN A.ConP a b c) dict+ (N3 2 a b) -> runReaderT (valuN (A.DefP i) a b) dict+ (N1 3) -> runReaderT (valuN (A.WildP i)) dict+ (N3 4 a b) -> runReaderT (valuN (A.AsP i) a b) dict+ (N2 5 a) -> runReaderT (valuN (A.DotP i) a) dict+ (N1 6) -> runReaderT (valuN (A.AbsurdP i)) dict+ (N2 7 a) -> runReaderT (valuN (A.LitP i) a) dict+ (N3 8 a b) -> runReaderT (valuN (A.ProjP i) a b) dict+ (N3 9 a b) -> runReaderT (valuN (A.PatternSynP i) a b) dict+ (N3 10 a b) -> runReaderT (valuN (A.RecP empty) a b) dict+ (N2 11 a) -> runReaderT (valuN (A.WithP i) a) dict+ _ -> malformedIO i = patNoRange @@ -216,13 +203,19 @@ icod_ = icod_ <=< noDotOrEqPattern (return $ A.WildP empty) value = fmap (__IMPOSSIBLE__ :: Void -> A.Expr) <.> value +instance EmbPrj A.PatternSynDefn where+ icod_ (A.PatternSynDefn a b) = icodeN' A.PatternSynDefn a b+ value = vcase \case+ N2 a b -> valuN A.PatternSynDefn a b+ _ -> malformed+ instance EmbPrj ParenPreference where icod_ PreferParen = icodeN' PreferParen icod_ PreferParenless = icodeN 1 PreferParenless value = vcase valu where- valu [] = valuN PreferParen- valu [1] = valuN PreferParenless- valu _ = malformed+ valu N0 = valuN PreferParen+ valu (N1 1) = valuN PreferParenless+ valu _ = malformed instance EmbPrj Precedence where icod_ TopCtx = icodeN' TopCtx@@ -237,21 +230,21 @@ icod_ DotPatternCtx = icodeN 9 DotPatternCtx value = vcase valu where- valu [] = valuN TopCtx- valu [1] = valuN FunctionSpaceDomainCtx- valu [2, a] = valuN LeftOperandCtx a- valu [3, a, b] = valuN RightOperandCtx a b- valu [4] = valuN FunctionCtx- valu [5, a] = valuN ArgumentCtx a- valu [6] = valuN InsideOperandCtx- valu [7] = valuN WithFunCtx- valu [8] = valuN WithArgCtx- valu [9] = valuN DotPatternCtx- valu _ = malformed+ valu N0 = valuN TopCtx+ valu (N1 1) = valuN FunctionSpaceDomainCtx+ valu (N2 2 a) = valuN LeftOperandCtx a+ valu (N3 3 a b) = valuN RightOperandCtx a b+ valu (N1 4) = valuN FunctionCtx+ valu (N2 5 a) = valuN ArgumentCtx a+ valu (N1 6) = valuN InsideOperandCtx+ valu (N1 7) = valuN WithFunCtx+ valu (N1 8) = valuN WithArgCtx+ valu (N1 9) = valuN DotPatternCtx+ valu _ = malformed instance EmbPrj ScopeInfo where- icod_ (ScopeInfo a b c d e f g h i j k) = icodeN' (\ a b c d e -> ScopeInfo a b c d e f g h i j k) a b c d e+ icod_ (ScopeInfo a b c d e f g h i j) = icodeN' (\ a b c d e -> ScopeInfo a b c d e f g h i j) a b c d e - value = valueN (\ a b c d e -> ScopeInfo a b c d e Map.empty Map.empty Set.empty Map.empty Map.empty Map.empty)+ value = valueN (\ a b c d e -> ScopeInfo a b c d e HMap.empty HMap.empty Set.empty Map.empty Map.empty) instance EmbPrj NameOrModule
src/full/Agda/TypeChecking/Serialise/Instances/Common.hs view
@@ -1,36 +1,17 @@-{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-}+ module Agda.TypeChecking.Serialise.Instances.Common (SerialisedRange(..)) where import qualified Control.Exception as E-import Control.Monad ( (<=<), (<$!>) )+import Control.Monad ( (<$!>) ) import Control.Monad.IO.Class ( MonadIO(..) )-import Control.Monad.Except ( MonadError(..) )-import Control.Monad.Reader ( MonadReader(..), asks ) import Control.Monad.State ( runStateT )-import Control.Monad.State.Strict ( gets, modify )--import Data.Array.IArray-import qualified Data.Foldable as Fold-import Data.Hashable-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HMap-import Data.Int (Int32)-import Data.IntSet (IntSet)-import qualified Data.IntSet as IntSet-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Sequence (Seq)-import qualified Data.Sequence as Seq-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Strict.Tuple (Pair(..))-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import Data.Typeable-import Data.Void-import Data.Word (Word32, Word64)+import Control.Monad.Reader ( asks ) import Agda.Syntax.Common import Agda.Syntax.Builtin@@ -46,128 +27,17 @@ import Agda.TypeChecking.Monad.Base.Types import Agda.TypeChecking.Serialise.Base+import Agda.TypeChecking.Serialise.Instances.General () -import Agda.Utils.BiMap (BiMap)-import qualified Agda.Utils.BiMap as BiMap import Agda.Utils.FileId (getIdFile)-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 qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Null-import Agda.Utils.SmallSet (SmallSet(..))-import Agda.Utils.Set1 (Set1)-import qualified Agda.Utils.Set1 as Set1-import Agda.Utils.Trie (Trie(..))-import Agda.Utils.WithDefault +import Agda.Utils.IORef import Agda.Utils.Impossible import Agda.Utils.CallStack--instance {-# OVERLAPPING #-} EmbPrj String where- icod_ = icodeString- value i = (! i) <$!> gets stringE--instance EmbPrj TL.Text where- icod_ = icodeX lTextD lTextC- value i = (! i) <$!> gets lTextE--instance EmbPrj T.Text where- icod_ = icodeX sTextD sTextC- value i = (! i) <$!> gets sTextE--instance EmbPrj Integer where- icod_ = icodeInteger- value i = (! i) <$!> gets integerE--instance EmbPrj Word64 where- icod_ i = icodeN' (undefined :: Word32 -> Word32 -> Word32) (word32 q) (word32 r)- where (q, r) = quotRem i (2 ^ 32)- word32 :: Word64 -> Word32- word32 = fromIntegral-- value = vcase valu where- valu [a, b] = return $! n * fromIntegral a + fromIntegral b- valu _ = malformed- n = 2 ^ 32--instance EmbPrj Word32 where- icod_ i = return i- value i = return i---- Andreas, Agda Hackathon 2024-10-15--- Are we sure we never use an Int that does not fit into 32 bits?-instance EmbPrj Int where- icod_ i = return $! fromIntegral i- value i = return $! fromIntegral i--instance EmbPrj Int32 where- icod_ i = return $! fromIntegral i- value i = return $! fromIntegral i--instance EmbPrj Char where- icod_ c = return $! fromIntegral $ fromEnum c- value i = return $! toEnum $ fromInteger $ toInteger i--instance EmbPrj Double where- icod_ = icodeDouble- value i = (! i) <$!> gets doubleE--instance EmbPrj Void where- icod_ = absurd- value = vcase valu where valu _ = malformed--instance EmbPrj () where- icod_ () = pure 0-- value 0 = pure ()- value _ = malformed--instance (EmbPrj a, EmbPrj b) => EmbPrj (a, b) where- icod_ (a, b) = icodeN' (,) a b-- value = valueN (,)--instance (EmbPrj a, EmbPrj b) => EmbPrj (Pair a b) where- icod_ (a :!: b) = icodeN' (:!:) a b-- value = valueN (:!:)--instance (EmbPrj a, EmbPrj b, EmbPrj c) => EmbPrj (a, b, c) where- icod_ (a, b, c) = icodeN' (,,) a b c-- value = valueN (,,)--instance (EmbPrj a, EmbPrj b) => EmbPrj (Either a b) where- icod_ (Left x) = icodeN 0 Left x- icod_ (Right x) = icodeN 1 Right x-- value = vcase valu where- valu [0, x] = valuN Left x- valu [1, x] = valuN Right x- valu _ = malformed--instance EmbPrj a => EmbPrj (Maybe a) where- icod_ Nothing = icodeN' Nothing- icod_ (Just x) = icodeN' Just x-- value = vcase valu where- valu [] = valuN Nothing- valu [x] = valuN Just x- valu _ = malformed--instance EmbPrj a => EmbPrj (Strict.Maybe a) where- icod_ m = icode (Strict.toLazy m)- value m = Strict.toStrict <$!> value m--instance EmbPrj Bool where- icod_ False = pure 0- icod_ True = pure 1-- value 0 = pure False- value 1 = pure True- value _ = malformed+import qualified Agda.Utils.HashTable as H+import qualified Agda.Utils.CompactRegion as Compact+import Agda.Utils.Functor ((<.>)) instance EmbPrj ConstructorOrPatternSynonym @@ -191,13 +61,15 @@ _ -> malformed instance EmbPrj Cubical where- icod_ CErased = icodeN' CErased- icod_ CFull = icodeN 0 CFull+ icod_ CWithoutGlue = icodeN' CWithoutGlue+ icod_ CErased = icodeN 0 CErased+ icod_ CFull = icodeN 1 CFull value = vcase $ \case- [] -> valuN CErased- [0] -> valuN CFull- _ -> malformed+ N0 -> valuN CWithoutGlue+ N1 0 -> valuN CErased+ N1 1 -> valuN CFull+ _ -> malformed instance EmbPrj Language where icod_ WithoutK = icodeN' WithoutK@@ -205,102 +77,46 @@ icod_ (Cubical a) = icodeN 1 Cubical a value = vcase $ \case- [] -> valuN WithoutK- [0] -> valuN WithK- [1, a] -> valuN Cubical a+ N0 -> valuN WithoutK+ N1 0 -> valuN WithK+ N2 1 a -> valuN Cubical a _ -> malformed -instance EmbPrj a => EmbPrj (Position' a) where- icod_ (P.Pn file pos line col) = icodeN' P.Pn file pos line col-- value = valueN P.Pn--instance (EmbPrj a, Typeable b) => EmbPrj (WithDefault' a b) where- icod_ = \case- Default -> icodeN' Default- Value b -> icodeN' Value b+instance EmbPrj AllowedErasedMatchesIndexed where+ icod_ Restricted = icodeN' Restricted+ icod_ Unrestricted = icodeN 0 Unrestricted value = vcase $ \case- [] -> valuN Default- [a] -> valuN Value a- _ -> malformed--instance EmbPrj TopLevelModuleName where- icod_ (TopLevelModuleName a b c d) = icodeN' TopLevelModuleName a b c d-- value = valueN TopLevelModuleName--instance {-# OVERLAPPABLE #-} EmbPrj a => EmbPrj [a] where- icod_ xs = icodeNode =<< go xs where- go :: [a] -> S Node- go [] = pure Empty- go (a:as) = do {n <- icode a; ns <- go as; pure $! Cons n ns}-- value = vcase (mapM 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- value = maybe malformed return . List2.fromListMaybe <=< value--instance (EmbPrj k, EmbPrj v, EmbPrj (BiMap.Tag v)) =>- EmbPrj (BiMap k v) where- 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 Word32-mapPairsIcode xs = icodeNode =<< convert Empty 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 (Cons start (Cons entry ys)) xs--mapPairsValue :: (EmbPrj k, EmbPrj v) => [Word32] -> 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+ N0 -> valuN Restricted+ N1 0 -> valuN Unrestricted+ _ -> malformed -instance (Ord a, EmbPrj a, EmbPrj b) => EmbPrj (Map a b) where- icod_ m = mapPairsIcode (Map.toAscList m)- value = vcase ((Map.fromDistinctAscList <$!>) . mapPairsValue)+instance EmbPrj AllowedErasedMatches where+ icod_ (AllowedErasedMatches e n d) =+ icodeN' AllowedErasedMatches e n d -instance (Ord a, EmbPrj a) => EmbPrj (Set a) where- icod_ s = icode (Set.toAscList s)- value s = Set.fromDistinctAscList <$!> value s+ value = valueN AllowedErasedMatches -instance (Ord a, EmbPrj a) => EmbPrj (Set1 a) where- icod_ s = icode (Set1.toAscList s)- value s = Set1.fromDistinctAscList <$!> value s+instance EmbPrj AllowedErasedMatchesWithDefaults where+ icod_ ErasedMatchesDefault = icodeN' ErasedMatchesDefault+ icod_ ErasedMatchesDefaultOn = icodeN 0 ErasedMatchesDefaultOn+ icod_ (ErasedMatches a) = icodeN 1 ErasedMatches a -instance EmbPrj IntSet where- icod_ s = icode (IntSet.toAscList s)- value s = IntSet.fromDistinctAscList <$!> value s+ value = vcase $ \case+ N0 -> valuN ErasedMatchesDefault+ N1 0 -> valuN ErasedMatchesDefaultOn+ N2 1 a -> valuN ErasedMatches a+ _ -> malformed -instance Typeable a => EmbPrj (SmallSet a) where- icod_ (SmallSet a) = icodeN' SmallSet a- value = valueN SmallSet+instance EmbPrj a => EmbPrj (Position' a) where+ icod_ (P.Pn file pos line col) = icodeN' P.Pn file pos line col -instance (Ord a, EmbPrj a, EmbPrj b) => EmbPrj (Trie a b) where- icod_ (Trie a b)= icodeN' Trie a b+ value = valueN P.Pn - value = valueN Trie+instance EmbPrj TopLevelModuleName where+ icod_ (TopLevelModuleName a b c d) = icodeN' TopLevelModuleName a b c d -instance EmbPrj a => EmbPrj (Seq a) where- icod_ s = icode (Fold.toList s)- value s = Seq.fromList <$!> value s+ value = valueN TopLevelModuleName instance EmbPrj a => EmbPrj (P.Interval' a) where icod_ (P.Interval f p q) = icodeN' P.Interval f p q@@ -312,17 +128,23 @@ icod_ (RangeFile _ (Just a)) = icode a value r = do- m :: TopLevelModuleName- <- value r- mf <- gets modFile- incs <- gets includes- (r, mf) <- liftIO $ runStateT (findFile'' incs m) mf- modify $ \s -> s { modFile = mf }+ !m :: TopLevelModuleName <- value r+ !mfref <- asks modFile+ !mf <- liftIO $ readIORef mfref+ !incs <- asks includes+ (!r, !mf) <- liftIO $ runStateT (findFile'' incs m) mf+ liftIO $ writeIORef mfref mf case r of- Left err -> liftIO $ E.throwIO $ E.ErrorCall $ "file not found: " ++ show err- Right (SourceFile i) -> do- let fp = getIdFile (fileDict mf) i- return $ RangeFile fp (Just m)+ Left err ->+ liftIO $ E.throwIO $ E.ErrorCall $ "file not found: " ++ show err+ Right (SourceFile i) -> do+ let !fp = getIdFile (fileDict mf) i+ !fpmemo <- asks filePathMemo+ !arena <- asks arena+ liftIO $ H.insertingIfAbsent fpmemo fp+ (\fp -> pure $ RangeFile fp (Just m))+ (Compact.add arena fp)+ (\fp -> pure $ RangeFile fp (Just m)) -- | Ranges are always deserialised as 'noRange'. @@ -348,8 +170,8 @@ icod_ (C.Name r nis xs) = icodeN 1 C.Name r nis xs value = vcase valu where- valu [0, a, b] = valuN C.NoName a b- valu [1, r, nis, xs] = valuN C.Name r nis xs+ valu (N3 0 a b) = valuN C.NoName a b+ valu (N4 1 r nis xs) = valuN C.Name r nis xs valu _ = malformed instance EmbPrj NamePart where@@ -357,35 +179,35 @@ icod_ (Id a) = icodeN' Id a value = vcase valu where- valu [] = valuN Hole- valu [a] = valuN Id a- valu _ = malformed+ valu N0 = valuN Hole+ valu (N1 a) = valuN Id a+ valu _ = malformed instance EmbPrj NameInScope where icod_ InScope = icodeN' InScope icod_ NotInScope = icodeN 0 NotInScope value = vcase valu where- valu [] = valuN InScope- valu [0] = valuN NotInScope- valu _ = malformed+ valu N0 = valuN InScope+ valu (N1 0) = valuN NotInScope+ valu _ = malformed instance EmbPrj C.QName where icod_ (Qual a b) = icodeN' Qual a b icod_ (C.QName a ) = icodeN' C.QName a value = vcase valu where- valu [a, b] = valuN Qual a b- valu [a] = valuN C.QName a- valu _ = malformed+ valu (N2 a b) = valuN Qual a b+ valu (N1 a) = valuN C.QName a+ valu _ = malformed instance (EmbPrj a, EmbPrj b) => EmbPrj (ImportedName' a b) where icod_ (ImportedModule a) = icodeN 1 ImportedModule a icod_ (ImportedName a) = icodeN 2 ImportedName a value = vcase valu where- valu [1, a] = valuN ImportedModule a- valu [2, a] = valuN ImportedName a+ valu (N2 1 a) = valuN ImportedModule a+ valu (N2 2 a) = valuN ImportedName a valu _ = malformed instance EmbPrj Associativity where@@ -404,9 +226,9 @@ icod_ (Related a) = icodeN' Related a value = vcase valu where- valu [] = valuN Unrelated- valu [a] = valuN Related a- valu _ = malformed+ valu N0 = valuN Unrelated+ valu (N1 a) = valuN Related a+ valu _ = malformed instance EmbPrj Fixity where icod_ (Fixity a b c) = icodeN' Fixity a b c@@ -430,11 +252,11 @@ icod_ (IdPart a) = icodeN' IdPart a value = vcase valu where- 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+ valu (N3 0 a b) = valuN VarPart a b+ valu (N3 1 a b) = valuN HolePart a b+ valu (N2 2 a) = valuN WildPart a+ valu (N1 a) = valuN IdPart a+ valu _ = malformed instance EmbPrj MetaId where icod_ (MetaId a b) = icode (a, b)@@ -451,19 +273,38 @@ value = valueN A.QName +-- | Note: Serialization of 'A.AmbiguousQName' discards lineage,+-- treating all entries as just 'A.QName' rather than 'A.AbstractName'. instance EmbPrj A.AmbiguousQName where- icod_ (A.AmbQ a) = icode a- value n = A.AmbQ <$!> value n+ icod_ = icod_ . A.getAmbiguous+ value = A.ambiguous <.> value +-- instance EmbPrj A.AmbiguousQName where+-- icod_ (A.AmbQ a) = icode a+-- value n = A.AmbQ <$!> value n++-- instance EmbPrj A.AmbQNameEntry where+-- icod_ = \case+-- A.AmbQName a -> icodeN 0 a+-- A.AmbAbstractName a -> icodeN 1 a+-- value = vcase \case+-- N2 0 a -> valuN A.AmbQName a+-- N2 1 a -> valuN A.AmbAbstractName a+-- _ -> malformed+ instance EmbPrj A.ModuleName where icod_ (A.MName a) = icode a value n = A.MName <$!> value n instance EmbPrj A.Name where- icod_ (A.Name a b c d e f) = icodeMemo nameD nameC a $- icodeN' (\ a b c -> A.Name a b c . underlyingRange) a b c (SerialisedRange d) e f+ icod_ x@(A.Name a b c d e f) =+ -- Andreas, 2026-03-12: issue #8465:+ -- We include the definition site into the key for 'A.Name'+ -- to correctly serialize the 'nameDefinitionSite' field.+ icodeMemo nameD nameC (nameIdR x) $+ icodeN' (\ a b c d e f -> A.Name a b c (underlyingRange d) e f) a b c (SerialisedRange d) e f - value = valueN (\a b c d -> A.Name a b c (underlyingRange d))+ value = valueN (\a b c d e f -> A.Name a b c (underlyingRange d) e f) instance EmbPrj a => EmbPrj (C.FieldAssignment' a) where icod_ (C.FieldAssignment a b) = icodeN' C.FieldAssignment a b@@ -500,10 +341,6 @@ value = valueN OpaqueId -instance (Eq k, Hashable k, EmbPrj k, EmbPrj v) => EmbPrj (HashMap k v) where- icod_ m = mapPairsIcode (HMap.toList m)- value = vcase ((HMap.fromList <$!>) . mapPairsValue)- instance EmbPrj a => EmbPrj (WithHiding a) where icod_ (WithHiding a b) = icodeN' WithHiding a b @@ -519,11 +356,22 @@ icod_ (NoEta a) = icodeN' NoEta a value = vcase valu where- valu [] = valuN YesEta- valu [a] = valuN NoEta a- valu _ = malformed+ valu N0 = valuN YesEta+ valu (N1 a) = valuN NoEta a+ valu _ = malformed instance EmbPrj PatternOrCopattern++instance EmbPrj a => EmbPrj (DataOrRecord' a) where+ icod_ = \case+ IsData -> icodeN' IsData+ IsRecord pm -> icodeN' IsRecord pm++ value = vcase $ \case+ N0 -> valuN IsData+ N1 pm -> valuN IsRecord pm+ _ -> malformed+ instance EmbPrj OverlapMode instance EmbPrj Induction where@@ -531,9 +379,9 @@ icod_ CoInductive = icodeN 1 CoInductive value = vcase valu where- valu [] = valuN Inductive- valu [1] = valuN CoInductive- valu _ = malformed+ valu N0 = valuN Inductive+ valu (N1 1) = valuN CoInductive+ valu _ = malformed instance EmbPrj Hiding where icod_ Hidden = return 0@@ -590,10 +438,10 @@ Quantityω a -> icodeN' Quantityω a -- default quantity, shorter code value = vcase $ \case- [0, a] -> valuN Quantity0 a- [1, a] -> valuN Quantity1 a- [a] -> valuN Quantityω a- _ -> malformed+ (N2 0 a) -> valuN Quantity0 a+ (N2 1 a) -> valuN Quantity1 a+ (N1 a) -> valuN Quantityω a+ _ -> malformed -- -- ALT: forget quantity origin when serializing? -- instance EmbPrj Quantity where@@ -609,11 +457,13 @@ instance EmbPrj Cohesion where icod_ Flat = return 0 icod_ Continuous = return 1- icod_ Squash = return 2+ icod_ Sharp = return 2+ icod_ Squash = return 3 value 0 = return Flat value 1 = return Continuous- value 2 = return Squash+ value 2 = return Sharp+ value 3 = return Squash value _ = malformed instance EmbPrj ModalPolarity where@@ -644,7 +494,7 @@ icod_ (Modality a b c d) = icodeN' Modality a b c d value = vcase $ \case- [a, b, c, d] -> valuN Modality a b c d+ (N4 a b c d) -> valuN Modality a b c d _ -> malformed instance EmbPrj OriginRelevant where@@ -692,13 +542,13 @@ ShapeIrrelevant a -> icodeN 1 ShapeIrrelevant a value = vcase \case- [a] -> valuN Relevant a- [0, a] -> valuN Irrelevant a- [1, a] -> valuN ShapeIrrelevant a+ N1 a -> valuN Relevant a+ N2 0 a -> valuN Irrelevant a+ N2 1 a -> valuN ShapeIrrelevant a _ -> malformed instance EmbPrj Annotation where- icod_ (Annotation l) = icodeN' Annotation l+ icod_ (Annotation l r) = icodeN' Annotation l r value = valueN Annotation @@ -712,14 +562,24 @@ value 2 = pure (IsLock LockOLock) value _ = malformed +instance EmbPrj RewriteAnn where+ icod_ IsNotRewrite = pure 0+ icod_ (IsRewrite _) = pure 1++ value 0 = pure IsNotRewrite+ value 1 = pure $ IsRewrite noRange+ value _ = malformed+ instance EmbPrj Origin where- icod_ UserWritten = return 0- icod_ Inserted = return 1- icod_ Reflected = return 2- icod_ CaseSplit = return 3- icod_ Substitution = return 4- icod_ ExpandedPun = return 5+ icod_ UserWritten = return 0+ icod_ Inserted = return 1+ icod_ Reflected = return 2+ icod_ CaseSplit = return 3+ icod_ Substitution = return 4+ icod_ ExpandedPun = return 5 icod_ Generalization = return 6+ icod_ ConversionFail = return 7+ icod_ RecordSelf = return 8 value 0 = return UserWritten value 1 = return Inserted@@ -728,6 +588,8 @@ value 4 = return Substitution value 5 = return ExpandedPun value 6 = return Generalization+ value 7 = return ConversionFail+ value 8 = return RecordSelf value _ = malformed instance EmbPrj a => EmbPrj (WithOrigin a) where@@ -740,9 +602,9 @@ icod_ (KnownFVs a) = icodeN' KnownFVs a value = vcase valu where- valu [] = valuN UnknownFVs- valu [a] = valuN KnownFVs a- valu _ = malformed+ valu N0 = valuN UnknownFVs+ valu (N1 a) = valuN KnownFVs a+ valu _ = malformed instance EmbPrj ConOrigin where icod_ ConOSystem = return 0@@ -776,32 +638,32 @@ icod_ (LitWord64 a) = icodeN 7 LitWord64 a value = vcase valu where- valu [a] = valuN LitNat a- valu [1, a] = valuN LitFloat a- valu [2, a] = valuN LitString a- valu [3, a] = valuN LitChar a- valu [5, a] = valuN LitQName a- valu [6, a, b] = valuN LitMeta a b- valu [7, a] = valuN LitWord64 a- valu _ = malformed+ valu (N1 a) = valuN LitNat a+ valu (N2 1 a) = valuN LitFloat a+ valu (N2 2 a) = valuN LitString a+ valu (N2 3 a) = valuN LitChar a+ valu (N2 5 a) = valuN LitQName a+ valu (N3 6 a b) = valuN LitMeta a b+ valu (N2 7 a) = valuN LitWord64 a+ valu _ = malformed instance EmbPrj IsAbstract where icod_ AbstractDef = icodeN 0 AbstractDef icod_ ConcreteDef = icodeN' ConcreteDef value = vcase valu where- valu [0] = valuN AbstractDef- valu [] = valuN ConcreteDef- valu _ = malformed+ valu (N1 0) = valuN AbstractDef+ valu N0 = valuN ConcreteDef+ valu _ = malformed instance EmbPrj IsOpaque where icod_ (OpaqueDef a) = icodeN' OpaqueDef a icod_ TransparentDef = icodeN' TransparentDef value = vcase valu where- valu [a] = valuN OpaqueDef a- valu [] = valuN TransparentDef- valu _ = malformed+ valu (N1 a) = valuN OpaqueDef a+ valu N0 = valuN TransparentDef+ valu _ = malformed instance EmbPrj SrcLoc where icod_ (SrcLoc p m f sl sc el ec) = icodeN' SrcLoc p m f sl sc el ec@@ -817,19 +679,19 @@ icod_ (ImpMissingDefinitions a b) = icodeN 2 ImpMissingDefinitions a b value = vcase valu where- valu [0, a] = valuN Impossible a- valu [1, a] = valuN Unreachable a- valu [2, a, b] = valuN ImpMissingDefinitions a b- valu _ = malformed+ valu (N2 0 a) = valuN Impossible a+ valu (N2 1 a) = valuN Unreachable a+ valu (N3 2 a b) = valuN ImpMissingDefinitions a b+ valu _ = malformed instance EmbPrj ExpandedEllipsis where icod_ NoEllipsis = icodeN' NoEllipsis icod_ (ExpandedEllipsis a b) = icodeN 1 ExpandedEllipsis a b value = vcase valu where- valu [] = valuN NoEllipsis- valu [1,a,b] = valuN ExpandedEllipsis a b- valu _ = malformed+ valu N0 = valuN NoEllipsis+ valu (N3 1 a b) = valuN ExpandedEllipsis a b+ valu _ = malformed instance EmbPrj OptionsPragma where icod_ (OptionsPragma a b) = icod_ (a, b)@@ -844,9 +706,9 @@ icod_ (PrimitiveName x) = icodeN 1 PrimitiveName x value = vcase valu where- valu [0, x] = valuN BuiltinName x- valu [1, x] = valuN PrimitiveName x- valu _ = malformed+ valu (N2 0 x) = valuN BuiltinName x+ valu (N2 1 x) = valuN PrimitiveName x+ valu _ = malformed instance EmbPrj IsInstance where icod_ = \case@@ -854,15 +716,15 @@ NotInstanceDef -> icodeN' NotInstanceDef value = vcase \case- [a] -> valuN InstanceDef a- [] -> valuN NotInstanceDef- _ -> malformed+ N1 a -> valuN InstanceDef a+ N0 -> valuN NotInstanceDef+ _ -> malformed instance EmbPrj a => EmbPrj (RecordDirectives' a) where icod_ (RecordDirectives a b c d) = icodeN' RecordDirectives a b c d value = vcase \case- [a, b, c, d] -> valuN RecordDirectives a b c d+ N4 a b c d -> valuN RecordDirectives a b c d _ -> malformed instance EmbPrj RecordDirective where@@ -873,17 +735,19 @@ PatternOrCopattern a -> icodeN 3 PatternOrCopattern a value = vcase \case- [0, a, b] -> valuN Constructor a b- [1, a] -> valuN Eta a- [2, a] -> valuN Induction a- [3, a] -> valuN PatternOrCopattern a+ (N3 0 a b) -> valuN Constructor a b+ (N2 1 a) -> valuN Eta a+ (N2 2 a) -> valuN Induction a+ (N2 3 a) -> valuN PatternOrCopattern a _ -> malformed +instance EmbPrj PositivityCheck+ instance EmbPrj Catchall where icod_ NoCatchall = icodeN' NoCatchall icod_ (YesCatchall x) = icodeN' YesCatchall x value = vcase valu where- valu [] = valuN NoCatchall- valu [x] = valuN YesCatchall x- valu _ = malformed+ valu N0 = valuN NoCatchall+ valu (N1 x) = valuN YesCatchall x+ valu _ = malformed
src/full/Agda/TypeChecking/Serialise/Instances/Compilers.hs view
@@ -1,5 +1,4 @@ {-# OPTIONS_GHC -Wunused-imports #-}- {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fwarn-unused-imports #-}
src/full/Agda/TypeChecking/Serialise/Instances/Errors.hs view
@@ -1,26 +1,30 @@-{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans #-}+ module Agda.TypeChecking.Serialise.Instances.Errors where import Control.Monad import Agda.TypeChecking.Serialise.Base import Agda.TypeChecking.Serialise.Instances.Common ( SerialisedRange(..) )-import Agda.TypeChecking.Serialise.Instances.Internal () --instance only+import Agda.TypeChecking.Serialise.Instances.General () --instance only import Agda.TypeChecking.Serialise.Instances.Abstract () --instance only+import Agda.TypeChecking.Serialise.Instances.Internal () --instance only+import Agda.TypeChecking.Serialise.Instances.Highlighting () --instance only +import Agda.Syntax.Common.Pretty import Agda.Syntax.Concrete.Definitions.Errors ( DeclarationWarning(..), DeclarationWarning'(..), OpenOrImport(..) ) import Agda.Syntax.Parser.Monad import Agda.TypeChecking.Monad.Base import qualified Agda.TypeChecking.Monad.Base.Warning as W import Agda.Interaction.Options+import Agda.Interaction.Options.ProfileOptions import Agda.Interaction.Options.Warnings import Agda.Interaction.Library.Base import Agda.Termination.CutOff-import Agda.Syntax.Common.Pretty-import Agda.Utils.ProfileOptions +import Agda.Utils.DocTree qualified as DocTree import Agda.Utils.Impossible instance EmbPrj IsAmbiguous where@@ -29,9 +33,9 @@ NotAmbiguous -> icodeN' NotAmbiguous value = vcase \case- [a] -> valuN YesAmbiguous a- [] -> valuN NotAmbiguous- _ -> malformed+ N1 a -> valuN YesAmbiguous a+ N0 -> valuN NotAmbiguous+ _ -> malformed instance EmbPrj TCWarning where icod_ (TCWarning fp r a b c d) = icodeN' (\ fp -> TCWarning fp . underlyingRange) fp (SerialisedRange r) a b c d@@ -69,12 +73,12 @@ CantGeneralizeOverSorts a -> icodeN 14 CantGeneralizeOverSorts a IllformedAsClause a -> icodeN 15 IllformedAsClause a WithoutKFlagPrimEraseEquality -> icodeN 16 WithoutKFlagPrimEraseEquality- InstanceWithExplicitArg a -> icodeN 17 InstanceWithExplicitArg a+ InstanceWithExplicitArg a b -> icodeN 17 InstanceWithExplicitArg 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+ WrongInstanceDeclaration a -> icodeN 22 WrongInstanceDeclaration a RewriteNonConfluent a b c d -> icodeN 23 RewriteNonConfluent a b c d RewriteMaybeNonConfluent a b c -> icodeN 24 RewriteMaybeNonConfluent a b c PragmaCompileErased a b -> icodeN 25 PragmaCompileErased a b@@ -109,6 +113,7 @@ PragmaCompileList -> __IMPOSSIBLE__ PragmaCompileMaybe -> __IMPOSSIBLE__ NoMain _ -> __IMPOSSIBLE__+ UnknownJSPrimitive _ -> __IMPOSSIBLE__ IllegalRewriteRule a b -> icodeN 53 IllegalRewriteRule a b MissingTypeSignatureForOpaque a b -> icodeN 54 MissingTypeSignatureForOpaque a b ConflictingPragmaOptions a b -> icodeN 55 ConflictingPragmaOptions a b@@ -140,95 +145,133 @@ FixingCohesion a b c -> icodeN 72 FixingCohesion a b c FixingPolarity a b c -> icodeN 73 FixingPolarity a b c RewritesNothing -> icodeN 74 RewritesNothing+ IllegalDeclarationInDataDefinition ds -> __IMPOSSIBLE__ -- We don't serialize concrete definitions (yet)+ UnusedImports a b -> icodeN 75 UnusedImports a b+ DefinitionBeforeDeclaration x -> icodeN 76 DefinitionBeforeDeclaration x+ RecursiveRecordNeedsInductivity{} -> __IMPOSSIBLE__ -- Error warning+ IgnoringRew a b -> icodeN 77 IgnoringRew a b+ InferredLocalRewrite a b -> icodeN 78 InferredLocalRewrite a b+ ShouldBeEtaRecordPattern -> icodeN 79 ShouldBeEtaRecordPattern+ UnguardedEtaRecordW a -> icodeN 80 UnguardedEtaRecordW a value = vcase $ \ case- [0, a, b] -> valuN UnreachableClauses a b- [1, a, b] -> valuN OldBuiltin a b- [2] -> valuN EmptyRewritePragma- [3, a] -> valuN UselessPublic a- [4, a] -> valuN UselessInline a- [5, a] -> valuN DuplicateRecordDirective a- [6, a, b, c] -> valuN DeprecationWarning a b c- [7, a] -> valuN NicifierIssue a- [8, a] -> valuN InversionDepthReached a- [9, a] -> valuN UserWarning a- [10] -> valuN AbsurdPatternRequiresAbsentRHS- [11, a, b, c, d] -> valuN ModuleDoesntExport a b c d- [12, a] -> valuN LibraryWarning a- [13, a, b] -> valuN CoverageNoExactSplit a b- [14, a] -> valuN CantGeneralizeOverSorts a- [15, a] -> valuN IllformedAsClause a- [16] -> valuN WithoutKFlagPrimEraseEquality- [17, a] -> valuN InstanceWithExplicitArg a- [18, a] -> valuN InfectiveImport a- [19, a] -> valuN CoInfectiveImport a- [20, a] -> valuN InstanceNoOutputTypeName a- [21, a] -> valuN InstanceArgWithExplicitArg a- [22] -> valuN WrongInstanceDeclaration- [23, a, b, c, d] -> valuN RewriteNonConfluent a b c d- [24, a, b, c] -> valuN RewriteMaybeNonConfluent a b c- [25, a, b] -> valuN PragmaCompileErased a b- [26, a] -> valuN FixityInRenamingModule a- [27, a] -> valuN NotInScopeW a- [28, a, b] -> valuN ClashesViaRenaming a b- [29, a] -> valuN RecordFieldWarning a- [30, a] -> valuN UselessPatternDeclarationForRecord a- [31] -> valuN EmptyWhere- [32, a] -> valuN AsPatternShadowsConstructorOrPatternSynonym a- [33, a] -> valuN DuplicateUsing a- [34, a] -> valuN UselessHiding a- [35, a, b] -> valuN UselessPragma a b- [36, a, b, c] -> valuN RewriteAmbiguousRules a b c- [37, a, b, c] -> valuN RewriteMissingRule a b c- [38, a] -> valuN ParseWarning a- [39] -> valuN UselessTactic- [40, a] -> valuN UnsupportedIndexedMatch a- [41, a] -> valuN OptionWarning a- [42, a] -> valuN PlentyInHardCompileTimeMode a- [43] -> valuN NotAffectedByOpaque- [44, a] -> valuN UnfoldTransparentName a- [45] -> valuN UselessOpaque- [46, a, b] -> valuN InlineNoExactSplit a b- [47, a] -> valuN FaceConstraintCannotBeHidden a- [48, a] -> valuN FaceConstraintCannotBeNamed a- [49, a, b] -> valuN PatternShadowsConstructor a b- [50, a] -> valuN ConfluenceCheckingIncompleteBecauseOfMeta a- [51, a] -> valuN BuiltinDeclaresIdentifier a- [52] -> valuN ConfluenceForCubicalNotSupported- [53, a, b] -> valuN IllegalRewriteRule a b- [54, a, b] -> valuN MissingTypeSignatureForOpaque a b- [55, a, b] -> valuN ConflictingPragmaOptions a b- [56, a, b] -> valuN CustomBackendWarning a b- [57, a] -> valuN CoinductiveEtaRecord a- [58, a, b, c, d] -> valuN WithClauseProjectionFixityMismatch a b c d- [59, a, b] -> valuN InvalidDisplayForm a b- [60, a, b] -> valuN NotARewriteRule a b- [61, a, b] -> valuN PragmaCompileWrongName a b- [62, a] -> valuN PragmaCompileUnparsable a- [63, a, b] -> valuN PragmaCompileWrong a b- [64, a, b, c] -> valuN PragmaExpectsUnambiguousConstructorOrFunction a b c- [65, a, b, c] -> valuN PragmaExpectsUnambiguousProjectionOrFunction a b c- [66, a, b] -> valuN PragmaExpectsDefinedSymbol a b- [67, a] -> valuN UnfoldingWrongName a+ N3 0 a b -> valuN UnreachableClauses a b+ N3 1 a b -> valuN OldBuiltin a b+ N1 2 -> valuN EmptyRewritePragma+ N2 3 a -> valuN UselessPublic a+ N2 4 a -> valuN UselessInline a+ N2 5 a -> valuN DuplicateRecordDirective a+ N4 6 a b c -> valuN DeprecationWarning a b c+ N2 7 a -> valuN NicifierIssue a+ N2 8 a -> valuN InversionDepthReached a+ N2 9 a -> valuN UserWarning a+ N1 10 -> valuN AbsurdPatternRequiresAbsentRHS+ N5 11 a b c d -> valuN ModuleDoesntExport a b c d+ N2 12 a -> valuN LibraryWarning a+ N3 13 a b -> valuN CoverageNoExactSplit a b+ N2 14 a -> valuN CantGeneralizeOverSorts a+ N2 15 a -> valuN IllformedAsClause a+ N1 16 -> valuN WithoutKFlagPrimEraseEquality+ N3 17 a b -> valuN InstanceWithExplicitArg a b+ N2 18 a -> valuN InfectiveImport a+ N2 19 a -> valuN CoInfectiveImport a+ N2 20 a -> valuN InstanceNoOutputTypeName a+ N2 21 a -> valuN InstanceArgWithExplicitArg a+ N2 22 a -> valuN WrongInstanceDeclaration a+ N5 23 a b c d -> valuN RewriteNonConfluent a b c d+ N4 24 a b c -> valuN RewriteMaybeNonConfluent a b c+ N3 25 a b -> valuN PragmaCompileErased a b+ N2 26 a -> valuN FixityInRenamingModule a+ N2 27 a -> valuN NotInScopeW a+ N3 28 a b -> valuN ClashesViaRenaming a b+ N2 29 a -> valuN RecordFieldWarning a+ N2 30 a -> valuN UselessPatternDeclarationForRecord a+ N1 31 -> valuN EmptyWhere+ N2 32 a -> valuN AsPatternShadowsConstructorOrPatternSynonym a+ N2 33 a -> valuN DuplicateUsing a+ N2 34 a -> valuN UselessHiding a+ N3 35 a b -> valuN UselessPragma a b+ N4 36 a b c -> valuN RewriteAmbiguousRules a b c+ N4 37 a b c -> valuN RewriteMissingRule a b c+ N2 38 a -> valuN ParseWarning a+ N1 39 -> valuN UselessTactic+ N2 40 a -> valuN UnsupportedIndexedMatch a+ N2 41 a -> valuN OptionWarning a+ N2 42 a -> valuN PlentyInHardCompileTimeMode a+ N1 43 -> valuN NotAffectedByOpaque+ N2 44 a -> valuN UnfoldTransparentName a+ N1 45 -> valuN UselessOpaque+ N3 46 a b -> valuN InlineNoExactSplit a b+ N2 47 a -> valuN FaceConstraintCannotBeHidden a+ N2 48 a -> valuN FaceConstraintCannotBeNamed a+ N3 49 a b -> valuN PatternShadowsConstructor a b+ N2 50 a -> valuN ConfluenceCheckingIncompleteBecauseOfMeta a+ N2 51 a -> valuN BuiltinDeclaresIdentifier a+ N1 52 -> valuN ConfluenceForCubicalNotSupported+ N3 53 a b -> valuN IllegalRewriteRule a b+ N3 54 a b -> valuN MissingTypeSignatureForOpaque a b+ N3 55 a b -> valuN ConflictingPragmaOptions a b+ N3 56 a b -> valuN CustomBackendWarning a b+ N2 57 a -> valuN CoinductiveEtaRecord a+ N5 58 a b c d -> valuN WithClauseProjectionFixityMismatch a b c d+ N3 59 a b -> valuN InvalidDisplayForm a b+ N3 60 a b -> valuN NotARewriteRule a b+ N3 61 a b -> valuN PragmaCompileWrongName a b+ N2 62 a -> valuN PragmaCompileUnparsable a+ N3 63 a b -> valuN PragmaCompileWrong a b+ N4 64 a b c -> valuN PragmaExpectsUnambiguousConstructorOrFunction a b c+ N4 65 a b c -> valuN PragmaExpectsUnambiguousProjectionOrFunction a b c+ N3 66 a b -> valuN PragmaExpectsDefinedSymbol a b+ N2 67 a -> valuN UnfoldingWrongName a -- TODO: linearity -- [68, a, b, c] -> valuN FixingQuantity a b c- [69, a, b, c] -> valuN FixingRelevance a b c- [70, a] -> valuN UnusedVariablesInDisplayForm a- [71, a, b] -> valuN TooManyPolarities a b- [72, a, b, c] -> valuN FixingCohesion a b c- [73, a, b, c] -> valuN FixingPolarity a b c- [74] -> valuN RewritesNothing+ N4 69 a b c -> valuN FixingRelevance a b c+ N2 70 a -> valuN UnusedVariablesInDisplayForm a+ N3 71 a b -> valuN TooManyPolarities a b+ N4 72 a b c -> valuN FixingCohesion a b c+ N4 73 a b c -> valuN FixingPolarity a b c+ N1 74 -> valuN RewritesNothing+ N3 75 a b -> valuN UnusedImports a b+ N2 76 a -> valuN DefinitionBeforeDeclaration a+ N3 77 a b -> valuN IgnoringRew a b+ N3 78 a b -> valuN InferredLocalRewrite a b+ N1 79 -> valuN ShouldBeEtaRecordPattern+ N2 80 a -> valuN UnguardedEtaRecordW a _ -> malformed instance EmbPrj UselessPublicReason +instance EmbPrj ContextEntry where+ icod_ (CtxVar a b) = icodeN 0 CtxVar a b++ value = vcase $ \case+ N3 0 a b -> valuN CtxVar a b+ _ -> malformed++instance EmbPrj Context where+ icod_ (Context a) = icodeN 0 Context a++ value = vcase $ \case+ N2 0 a -> valuN Context a+ _ -> malformed++instance EmbPrj SerialisableRewriteSource where+ icod_ = \case+ LocalRewrite a b c -> icodeN 0 LocalRewrite a b c+ GlobalRewrite a -> icodeN 1 GlobalRewrite a++ value = vcase $ \case+ N4 0 a b c -> valuN LocalRewrite a b c+ N2 1 a -> valuN GlobalRewrite a+ _ -> malformed+ instance EmbPrj IllegalRewriteRuleReason where icod_ = \case LHSNotDefinitionOrConstructor -> icodeN 0 LHSNotDefinitionOrConstructor VariablesNotBoundByLHS a -> icodeN 1 VariablesNotBoundByLHS a VariablesBoundMoreThanOnce a -> icodeN 2 VariablesBoundMoreThanOnce a LHSReduces a b -> icodeN 3 LHSReduces a b- -- 4 was HeadSymbolIsProjection+ VariablesBoundInSingleton a -> icodeN 4 VariablesBoundInSingleton a HeadSymbolIsProjectionLikeFunction a -> icodeN 5 HeadSymbolIsProjectionLikeFunction a HeadSymbolIsTypeConstructor a -> icodeN 6 HeadSymbolIsTypeConstructor a HeadSymbolContainsMetas a -> icodeN 7 HeadSymbolContainsMetas a@@ -240,46 +283,62 @@ BeforeFunctionDefinition -> icodeN 13 BeforeFunctionDefinition BeforeMutualFunctionDefinition a -> icodeN 14 BeforeMutualFunctionDefinition a DuplicateRewriteRule -> icodeN 15 DuplicateRewriteRule+ LocalRewriteOutsideTelescope -> icodeN 16 LocalRewriteOutsideTelescope value = vcase $ \case- [0] -> valuN LHSNotDefinitionOrConstructor- [1, a] -> valuN VariablesNotBoundByLHS a- [2, a] -> valuN VariablesBoundMoreThanOnce a- [3, a, b] -> valuN LHSReduces a b- -- 4 was HeadSymbolIsProjection- [5, a] -> valuN HeadSymbolIsProjectionLikeFunction a- [6, a] -> valuN HeadSymbolIsTypeConstructor a- [7, a] -> valuN HeadSymbolContainsMetas a- [8, a, b] -> valuN ConstructorParametersNotGeneral a b- [9, a] -> valuN ContainsUnsolvedMetaVariables a- [10, a] -> valuN BlockedOnProblems a- [11, a] -> valuN RequiresDefinitions a- [12] -> valuN DoesNotTargetRewriteRelation- [13] -> valuN BeforeFunctionDefinition- [14, a] -> valuN BeforeMutualFunctionDefinition a- [15] -> valuN DuplicateRewriteRule- _ -> malformed+ N1 0 -> valuN LHSNotDefinitionOrConstructor+ N2 1 a -> valuN VariablesNotBoundByLHS a+ N2 2 a -> valuN VariablesBoundMoreThanOnce a+ N3 3 a b -> valuN LHSReduces a b+ N2 4 a -> valuN VariablesBoundInSingleton a+ N2 5 a -> valuN HeadSymbolIsProjectionLikeFunction a+ N2 6 a -> valuN HeadSymbolIsTypeConstructor a+ N2 7 a -> valuN HeadSymbolContainsMetas a+ N3 8 a b -> valuN ConstructorParametersNotGeneral a b+ N2 9 a -> valuN ContainsUnsolvedMetaVariables a+ N2 10 a -> valuN BlockedOnProblems a+ N2 11 a -> valuN RequiresDefinitions a+ N1 12 -> valuN DoesNotTargetRewriteRelation+ N1 13 -> valuN BeforeFunctionDefinition+ N2 14 a -> valuN BeforeMutualFunctionDefinition a+ N1 15 -> valuN DuplicateRewriteRule+ N1 16 -> valuN LocalRewriteOutsideTelescope+ _ -> malformed instance EmbPrj OptionWarning where icod_ = \case- OptionRenamed a b -> icodeN 0 OptionRenamed a b- WarningProblem a -> icodeN 1 WarningProblem a+ OptionRenamed a b -> icodeN 0 OptionRenamed a b+ WarningProblem a -> icodeN 1 WarningProblem a+ LocalRewritingConfluenceCheck -> icodeN 2 LocalRewritingConfluenceCheck value = vcase $ \case- [0, a, b] -> valuN OptionRenamed a b- [1, a] -> valuN WarningProblem a- _ -> malformed+ N3 0 a b -> valuN OptionRenamed a b+ N2 1 a -> valuN WarningProblem a+ N1 2 -> valuN LocalRewritingConfluenceCheck+ _ -> malformed instance EmbPrj WarningModeError where icod_ = \case Unknown a -> icodeN 0 Unknown a NoNoError a -> icodeN 1 NoNoError a+ NoUnusedImportsAll -> icodeN 2 NoUnusedImportsAll value = vcase $ \case- [0, a] -> valuN Unknown a- [1, a] -> valuN NoNoError a- _ -> malformed+ N2 0 a -> valuN Unknown a+ N2 1 a -> valuN NoNoError a+ N1 2 -> valuN NoUnusedImportsAll+ _ -> malformed +instance EmbPrj OpenBracket where+ icod_ = \case+ OpenIdiomBracket a b -> icodeN 0 OpenIdiomBracket a b+ OpenDoubleBrace a b -> icodeN 1 OpenDoubleBrace a b++ value = vcase \case+ N3 0 a b -> valuN OpenIdiomBracket a b+ N3 1 a b -> valuN OpenDoubleBrace a b+ _ -> malformed+ instance EmbPrj ParseWarning where icod_ = \case OverlappingTokensWarning a -> icodeN 0 OverlappingTokensWarning a@@ -288,15 +347,17 @@ UnknownAttribute a b -> icodeN 3 UnknownAttribute a b UnknownPolarity a b -> icodeN 4 UnknownPolarity a b MisplacedAttributes a b -> icodeN 5 MisplacedAttributes a b+ MismatchedBrackets a b -> icodeN 6 MismatchedBrackets a b value = vcase $ \case- [0, a] -> valuN OverlappingTokensWarning a- [1, a, b] -> valuN UnsupportedAttribute a b- [2, a, b] -> valuN MultipleAttributes a b- [3, a, b] -> valuN UnknownAttribute a b- [4, a, b] -> valuN UnknownPolarity a b- [5, a, b] -> valuN MisplacedAttributes a b- _ -> malformed+ N2 0 a -> valuN OverlappingTokensWarning a+ N3 1 a b -> valuN UnsupportedAttribute a b+ N3 2 a b -> valuN MultipleAttributes a b+ N3 3 a b -> valuN UnknownAttribute a b+ N3 4 a b -> valuN UnknownPolarity a b+ N3 5 a b -> valuN MisplacedAttributes a b+ N3 6 a b -> valuN MismatchedBrackets a b+ _ -> malformed instance EmbPrj RecordFieldWarning where icod_ = \case@@ -304,18 +365,23 @@ W.TooManyFields a b c -> icodeN 1 W.TooManyFields a b c value = vcase $ \case- [0, a] -> valuN W.DuplicateFields a- [1, a, b, c] -> valuN W.TooManyFields a b c- _ -> malformed+ N2 0 a -> valuN W.DuplicateFields a+ N4 1 a b c -> valuN W.TooManyFields a b c+ _ -> malformed instance EmbPrj DeclarationWarning where icod_ (DeclarationWarning a b) = icodeN' DeclarationWarning a b value = vcase $ \case- [a, b] -> valuN DeclarationWarning a b- _ -> malformed+ N2 a b -> valuN DeclarationWarning a b+ _ -> malformed instance EmbPrj DeclarationWarning' where icod_ = \case+ -- Andreas, 2026-02-14:+ -- UnknownNamesInFixityDecl and UnknownNamesInPolarityPragmas are now error warnings,+ -- so the following two cases are impossible.+ -- We leave them in as long as they are not a nuisance for maintenance,+ -- should we decide in the future to revert them to non-error-warnings. UnknownNamesInFixityDecl a -> icodeN 0 UnknownNamesInFixityDecl a UnknownNamesInPolarityPragmas a -> icodeN 1 UnknownNamesInPolarityPragmas a PolarityPragmasButNotPostulates a -> icodeN 2 PolarityPragmasButNotPostulates a@@ -345,13 +411,12 @@ OpenImportAbstract r kwr a -> icodeN 26 OpenImportAbstract r kwr a OpenImportPrivate r kwr kwr' a -> icodeN 27 OpenImportPrivate r kwr kwr' a EmptyConstructor a -> icodeN 28 EmptyConstructor a- -- 29 removed- -- 30 removed+ DivergentModalityInClause ai1 ai2 -> icodeN 29 DivergentModalityInClause ai1 ai2+ InvalidTacticAttribute r -> icodeN 30 InvalidTacticAttribute r InvalidConstructorBlock a -> icodeN 31 InvalidConstructorBlock a MissingDataDeclaration a -> icodeN 32 MissingDataDeclaration a HiddenGeneralize r -> icodeN 33 HiddenGeneralize r UselessMacro r -> icodeN 34 UselessMacro r- SafeFlagEta {} -> __IMPOSSIBLE__ SafeFlagInjective {} -> __IMPOSSIBLE__ SafeFlagNoCoverageCheck {} -> __IMPOSSIBLE__ SafeFlagNoPositivityCheck {} -> __IMPOSSIBLE__@@ -360,44 +425,54 @@ SafeFlagPolarity {} -> __IMPOSSIBLE__ SafeFlagTerminating {} -> __IMPOSSIBLE__ EmptyPolarityPragma r -> icodeN 35 EmptyPolarityPragma r+ UselessImport r -> icodeN 36 UselessImport r+ InvalidDataOrRecDefParameter r a b c -> icodeN 37 InvalidDataOrRecDefParameter r a b c+ InvalidRewriteAttribute r -> icodeN 38 InvalidTacticAttribute r+ InvalidEtaEqualityPragma r -> icodeN 39 InvalidEtaEqualityPragma r+ FixityDeclarationForNonOperator r a -> icodeN 40 FixityDeclarationForNonOperator r a value = vcase $ \case- [0, a] -> valuN UnknownNamesInFixityDecl a- [1, a] -> valuN UnknownNamesInPolarityPragmas a- [2, a] -> valuN PolarityPragmasButNotPostulates a- [3, a] -> valuN UselessPrivate a- [4, a] -> valuN UselessAbstract a- [5, a] -> valuN UselessInstance a- [6, a] -> valuN EmptyMutual a- [7, a] -> valuN EmptyAbstract a- [8, a] -> valuN EmptyPrivate a- [9, a] -> valuN EmptyInstance a- [10,a] -> valuN EmptyMacro a- [11,a] -> valuN EmptyPostulate a- [12,a] -> valuN InvalidTerminationCheckPragma a- [13,a] -> valuN InvalidNoPositivityCheckPragma a- [14,a] -> valuN InvalidCatchallPragma a- [15,a] -> valuN InvalidNoUniverseCheckPragma a- [16,a] -> valuN UnknownFixityInMixfixDecl a- [17,a] -> valuN MissingDefinitions a- [18,r,a] -> valuN NotAllowedInMutual r a- [19,r] -> valuN PragmaNoTerminationCheck r- [20,a] -> valuN EmptyGeneralize a- [21,a] -> valuN PragmaCompiled a- [22,a] -> valuN EmptyPrimitive a- [23,r] -> valuN EmptyField r- [24,nrs] -> valuN ShadowingInTelescope nrs- [25,r] -> valuN InvalidCoverageCheckPragma r- [26,r,kwr,a] -> valuN OpenImportAbstract r kwr a- [27,r,kwr,kwr',a] -> valuN OpenImportPrivate r kwr kwr' a- [28,r] -> valuN EmptyConstructor r- -- 29 removed- -- 30 removed- [31,r] -> valuN InvalidConstructorBlock r- [32,r] -> valuN MissingDataDeclaration r- [33,r] -> valuN HiddenGeneralize r- [34,r] -> valuN UselessMacro r- [35,r] -> valuN EmptyPolarityPragma r+ N2 0 a -> valuN UnknownNamesInFixityDecl a+ N2 1 a -> valuN UnknownNamesInPolarityPragmas a+ N2 2 a -> valuN PolarityPragmasButNotPostulates a+ N2 3 a -> valuN UselessPrivate a+ N2 4 a -> valuN UselessAbstract a+ N2 5 a -> valuN UselessInstance a+ N2 6 a -> valuN EmptyMutual a+ N2 7 a -> valuN EmptyAbstract a+ N2 8 a -> valuN EmptyPrivate a+ N2 9 a -> valuN EmptyInstance a+ N2 10 a -> valuN EmptyMacro a+ N2 11 a -> valuN EmptyPostulate a+ N2 12 a -> valuN InvalidTerminationCheckPragma a+ N2 13 a -> valuN InvalidNoPositivityCheckPragma a+ N2 14 a -> valuN InvalidCatchallPragma a+ N2 15 a -> valuN InvalidNoUniverseCheckPragma a+ N2 16 a -> valuN UnknownFixityInMixfixDecl a+ N2 17 a -> valuN MissingDefinitions a+ N3 18 r a -> valuN NotAllowedInMutual r a+ N2 19 r -> valuN PragmaNoTerminationCheck r+ N2 20 a -> valuN EmptyGeneralize a+ N2 21 a -> valuN PragmaCompiled a+ N2 22 a -> valuN EmptyPrimitive a+ N2 23 r -> valuN EmptyField r+ N2 24 nrs -> valuN ShadowingInTelescope nrs+ N2 25 r -> valuN InvalidCoverageCheckPragma r+ N4 26 r kwr a -> valuN OpenImportAbstract r kwr a+ N5 27 r kwr kwr' a -> valuN OpenImportPrivate r kwr kwr' a+ N2 28 r -> valuN EmptyConstructor r+ N3 29 a b -> valuN DivergentModalityInClause a b+ N2 30 r -> valuN InvalidTacticAttribute r+ N2 31 r -> valuN InvalidConstructorBlock r+ N2 32 r -> valuN MissingDataDeclaration r+ N2 33 r -> valuN HiddenGeneralize r+ N2 34 r -> valuN UselessMacro r+ N2 35 r -> valuN EmptyPolarityPragma r+ N2 36 r -> valuN UselessImport r+ N5 37 r a b c -> valuN InvalidDataOrRecDefParameter r a b c+ N2 38 r -> valuN InvalidRewriteAttribute r+ N2 39 r -> valuN InvalidEtaEqualityPragma r+ N3 40 r a -> valuN FixityDeclarationForNonOperator r a _ -> malformed instance EmbPrj OpenOrImport@@ -407,23 +482,35 @@ LibWarning a b -> icodeN 0 LibWarning a b value = vcase $ \case- [0, a, b] -> valuN LibWarning a b+ N3 0 a b -> valuN LibWarning a b _ -> malformed instance EmbPrj LibWarning' where icod_ = \case UnknownField a -> icodeN 0 UnknownField a+ LibraryVersionConflict a b c -> icodeN 1 LibraryVersionConflict a b c value = vcase $ \case- [0, a] -> valuN UnknownField a+ N2 0 a -> valuN UnknownField a+ N4 1 a b c -> valuN LibraryVersionConflict a b c _ -> malformed +instance EmbPrj LibFilePos where+ icod_ (LibFilePos a b c) = icodeN' LibFilePos a b c++ value = valueN LibFilePos++instance EmbPrj LibDepNode where+ icod_ (LibDepNode a b) = icodeN' LibDepNode a b++ value = valueN LibDepNode+ instance EmbPrj ExecutablesFile where icod_ = \case ExecutablesFile a b -> icodeN 0 ExecutablesFile a b value = vcase $ \case- [0, a, b] -> valuN ExecutablesFile a b+ N3 0 a b -> valuN ExecutablesFile a b _ -> malformed instance EmbPrj LibPositionInfo where@@ -431,26 +518,105 @@ LibPositionInfo a b c -> icodeN 0 LibPositionInfo a b c value = vcase $ \case- [0, a, b, c] -> valuN LibPositionInfo a b c+ N4 0 a b c -> valuN LibPositionInfo a b c _ -> malformed +-- Andreas, 2025-08-01, PR #8040:+-- We serialize Doc as DocTree, fixing the layout,+-- but preserving the annotations. instance EmbPrj Doc where- icod_ d = icodeN' (undefined :: String -> Doc) (render d)-- value = valueN text+ icod_ d = icodeN' (undefined :: DocTree -> Doc) (DocTree.renderToTree d)+ value = valueN DocTree.prettyDocTree 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+ valu N0 = valuN Infective+ valu (N1 0) = valuN Coinfective+ valu _ = malformed instance EmbPrj PragmaOptions where- icod_ (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 iii jjj kkk lll mmm nnn ooo ppp qqq rrr sss) =- 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 iii jjj kkk lll mmm nnn ooo ppp qqq rrr sss+ icod_ o = icodeN' PragmaOptions+ (_optShowImplicit o)+ (_optShowGeneralized o)+ (_optShowIrrelevant o)+ (_optUseUnicode o)+ (_optVerbose o)+ (_optProfiling o)+ (_optIrrelevance o)+ (_optProp o)+ (_optLevelUniverse o)+ (_optTwoLevel o)+ (_optAllowUnsolved o)+ (_optAllowIncompleteMatch o)+ (_optPositivityCheck o)+ (_optTerminationCheck o)+ (_optTerminationDepth o)+ (_optUniverseCheck o)+ (_optOmegaInOmega o)+ (_optCumulativity o)+ (_optSizedTypes o)+ (_optGuardedness o)+ (_optInjectiveTypeConstructors o)+ (_optUniversePolymorphism o)+ (_optIrrelevantProjections o)+ (_optExperimentalIrrelevance o)+ (_optWithoutK o)+ (_optCubicalCompatible o)+ (_optCopatterns o)+ (_optPatternMatching o)+ (_optExactSplit o)+ (_optHiddenArgumentPuns o)+ (_optEta o)+ (_optForcing o)+ (_optProjectionLike o)+ (_optErasure o)+ (_optErasedMatches o)+ (_optEraseRecordParameters o)+ (_optRewriting o)+ (_optLocalRewriting o)+ (_optCubical o)+ (_optGuarded o)+ (_optFirstOrder o)+ (_optRequireUniqueMetaSolutions o)+ (_optPostfixProjections o)+ (_optKeepPatternVariables o)+ (_optInferAbsurdClauses o)+ (_optInstanceSearchDepth o)+ (_optBacktrackingInstances o)+ (_optQualifiedInstances o)+ (_optInversionMaxDepth o)+ (_optSafe o)+ (_optDoubleCheck o)+ (_optSyntacticEquality o)+ (_optWarningMode o)+ (_optCompileMain o)+ (_optCaching o)+ (_optCountClusters o)+ (_optAutoInline o)+ (_optPrintPatternSynonyms o)+ (_optFastReduce o)+ (_optCallByName o)+ (_optConfluenceCheck o)+ (_optCohesion o)+ (_optFlatSplit o)+ (_optPolarity o)+ (_optOccurrence o)+ (_optFunext o)+ (_optPropext o)+ (_optQuotients o)+ (_optImportSorts o)+ (_optLoadPrimitives o)+ (_optAllowExec o)+ (_optSaveMetas o)+ (_optShowIdentitySubstitutions o)+ (_optKeepCoveringClauses o)+ (_optLargeIndices o)+ (_optForcedArgumentRecursion o)+ (_optExperimentalLazyInstances o)+ (_optQuoteMetas o) value = valueN PragmaOptions @@ -469,9 +635,9 @@ icod_ GlobalConfluenceCheck = icodeN 0 GlobalConfluenceCheck value = vcase valu where- valu [] = valuN LocalConfluenceCheck- valu [0] = valuN GlobalConfluenceCheck- valu _ = malformed+ valu N0 = valuN LocalConfluenceCheck+ valu (N1 0) = valuN GlobalConfluenceCheck+ valu _ = malformed instance EmbPrj WarningMode where icod_ (WarningMode a b) = icodeN' WarningMode a b@@ -485,9 +651,9 @@ instance EmbPrj CutOff where icod_ = \case DontCutOff -> icodeN' DontCutOff- CutOff a -> icodeN 0 CutOff a+ CutOff a -> icodeN 0 CutOff a value = vcase valu where- valu [] = valuN DontCutOff- valu [0,a] = valuN CutOff a- valu _ = malformed+ valu N0 = valuN DontCutOff+ valu (N2 0 a) = valuN CutOff a+ valu _ = malformed
+ src/full/Agda/TypeChecking/Serialise/Instances/General.hs view
@@ -0,0 +1,355 @@+{-# LANGUAGE UndecidableInstances, MagicHash #-}++{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-}++-- | Serializing types that are not Agda-specific.++module Agda.TypeChecking.Serialise.Instances.General where++import Agda.Utils.Monad+import Control.Monad.Reader (asks, ReaderT(..), runReaderT)++import qualified Data.Foldable as Fold+import Data.Hashable+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HMap+import Data.Int (Int32)+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Strict.Tuple (Pair(..))+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Tree (Tree)+import qualified Data.Tree as Tree+import Data.Typeable+import Data.Void+import Data.Word (Word32, Word64)+import Data.HashSet (HashSet)+import qualified Data.HashSet as HSet++import Agda.TypeChecking.Serialise.Base++import Agda.Utils.BiMap (BiMap)+import qualified Agda.Utils.BiMap as BiMap+import Agda.Utils.DocTree qualified as DocTree+import Agda.Utils.List1 (List1)+import qualified Agda.Utils.List1 as List1+import Agda.Utils.List2 (List2)+import qualified Agda.Utils.List2 as List2+import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.SmallSet (SmallSet(..))+import Agda.Utils.Set1 (Set1)+import qualified Agda.Utils.Set1 as Set1+import Agda.Utils.Trie (Trie(..))+import Agda.Utils.VarSet (VarSet(..))+import Agda.Utils.WithDefault+import qualified Agda.Utils.MinimalArray.Lifted as AL++---------------------------------------------------------------------------+-- Base types++instance EmbPrj Void where+ icod_ = absurd+ value = vcase valu where valu _ = malformed++instance EmbPrj () where+ icod_ () = pure 0++ value 0 = pure ()+ value _ = malformed++instance EmbPrj Bool where+ icod_ False = pure 0+ icod_ True = pure 1++ value 0 = pure False+ value 1 = pure True+ value _ = malformed++instance EmbPrj Char where+ icod_ c = return $! fromIntegral $ fromEnum c+ value i = return $! toEnum $ fromInteger $ toInteger i++-- Numeric types++instance EmbPrj Double where+ icod_ = icodeDouble+ value i = flip AL.unsafeIndex (fromIntegral i) <$!> asks doubleA++-- Andreas, Agda Hackathon 2024-10-15+-- Are we sure we never use an Int that does not fit into 32 bits?+instance EmbPrj Int where+ icod_ i = return $! fromIntegral i+ value i = return $! fromIntegral i++instance EmbPrj Int32 where+ icod_ i = return $! fromIntegral i+ value i = return $! fromIntegral i++instance EmbPrj Integer where+ icod_ = icodeInteger+ value i = flip AL.unsafeIndex (fromIntegral i) <$!> asks integerA++instance EmbPrj Word32 where+ icod_ i = return i+ value i = return i++instance EmbPrj Word64 where+ icod_ i = icodeN' (undefined :: Word32 -> Word32 -> Word32) (word32 q) (word32 r)+ where (q, r) = quotRem i (2 ^ 32)+ word32 :: Word64 -> Word32+ word32 = fromIntegral++ value = vcase valu where+ valu (N2 a b) = return $! n * fromIntegral a + fromIntegral b+ valu _ = malformed+ n = 2 ^ 32++-- Text types++instance {-# OVERLAPPING #-} EmbPrj String where+ icod_ = icodeString+ value i = flip AL.unsafeIndex (fromIntegral i) <$!> asks stringA++instance EmbPrj TL.Text where+ icod_ = icodeLText+ value i = flip AL.index (fromIntegral i) <$!> asks lTextA++instance EmbPrj T.Text where+ icod_ = icodeSText+ value i = flip AL.index (fromIntegral i) <$!> asks sTextA++---------------------------------------------------------------------------+-- Non-recursive types++instance (EmbPrj a, EmbPrj b) => EmbPrj (a, b) where+ icod_ (a, b) = icodeN' (,) a b++ value = valueN (,)++instance (EmbPrj a, EmbPrj b) => EmbPrj (Pair a b) where+ icod_ (a :!: b) = icodeN' (:!:) a b++ value = valueN (:!:)++instance (EmbPrj a, EmbPrj b, EmbPrj c) => EmbPrj (a, b, c) where+ icod_ (a, b, c) = icodeN' (,,) a b c++ value = valueN (,,)++instance (EmbPrj a, EmbPrj b) => EmbPrj (Either a b) where+ icod_ (Left x) = icodeN 0 Left x+ icod_ (Right x) = icodeN 1 Right x++ value = vcase valu where+ valu (N2 0 x) = valuN Left x+ valu (N2 1 x) = valuN Right x+ valu _ = malformed++instance EmbPrj a => EmbPrj (Maybe a) where+ icod_ Nothing = icodeN' Nothing+ icod_ (Just x) = icodeN' Just x++ value = vcase valu where+ valu N0 = valuN Nothing+ valu (N1 x) = valuN Just x+ valu _ = malformed++instance EmbPrj a => EmbPrj (Strict.Maybe a) where+ icod_ m = icode (Strict.toLazy m)+ value m = Strict.toStrict <$!> value m++instance (EmbPrj a, Typeable b) => EmbPrj (WithDefault' a b) where+ icod_ = \case+ Default -> icodeN' Default+ Value b -> icodeN' Value b++ value = vcase $ \case+ N0 -> valuN Default+ N1 a -> valuN Value a+ _ -> malformed++---------------------------------------------------------------------------+-- Sequences++{-# INLINABLE icodeList #-}+icodeList :: EmbPrj a => [a] -> S Node+icodeList as = ReaderT \r -> case as of+ [] -> pure N0+ a:[] -> runReaderT (N1 <$!> icode a) r+ a:b:[] -> runReaderT (N2 <$!> icode a <*!> icode b) r+ a:b:c:[] -> runReaderT (N3 <$!> icode a <*!> icode b <*!> icode c) r+ a:b:c:d:[] -> runReaderT (N4 <$!> icode a <*!> icode b <*!> icode c <*!> icode d) r+ a:b:c:d:e:[] -> runReaderT (N5 <$!> icode a <*!> icode b+ <*!> icode c <*!> icode d <*!> icode e) r+ a:b:c:d:e:f:as -> runReaderT (N6 <$!> icode a <*!> icode b <*!> icode c+ <*!> icode d <*!> icode e <*!> icode f <*!> icodeList as) r++valueList :: EmbPrj a => Node -> R [a]+valueList as = ReaderT \r -> case as of+ N0 -> pure []+ N1 a -> flip runReaderT r do+ !a <- value a+ pure [a]+ N2 a b -> flip runReaderT r do+ !a <- value a+ !b <- value b+ pure [a, b]+ N3 a b c -> flip runReaderT r do+ !a <- value a+ !b <- value b+ !c <- value c+ pure [a, b, c]+ N4 a b c d -> flip runReaderT r do+ !a <- value a+ !b <- value b+ !c <- value c+ !d <- value d+ pure [a, b, c, d]+ N5 a b c d e -> flip runReaderT r do+ !a <- value a+ !b <- value b+ !c <- value c+ !d <- value d+ !e <- value e+ pure [a, b, c, d, e]+ N6 a b c d e f as -> flip runReaderT r do+ !a <- value a+ !b <- value b+ !c <- value c+ !d <- value d+ !e <- value e+ !f <- value f+ !as <- valueList as+ pure (a:b:c:d:e:f:as)++instance {-# OVERLAPPABLE #-} EmbPrj a => EmbPrj [a] where+ {-# INLINE icod_ #-}+ icod_ xs = icodeNode =<< icodeList xs where+ {-# INLINE value #-}+ value = vcase valueList++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+ value = maybe malformed return . List2.fromListMaybe <=< value++instance EmbPrj a => EmbPrj (Seq a) where+ icod_ s = icode (Fold.foldr' (:) [] s)+ value s = Seq.fromList <$!> value s++instance EmbPrj a => EmbPrj (Tree a) where+ icod_ (Tree.Node a b) = icodeN' Tree.Node a b++ value = valueN Tree.Node++data KVS a b = Cons a b !(KVS a b) | Nil++icodeListPair :: EmbPrj k => EmbPrj v => KVS k v -> S Node+icodeListPair as = ReaderT \r -> case as of+ Nil ->+ pure N0+ Cons a b Nil -> flip runReaderT r $+ N2 <$!> icode a <*!> icode b+ Cons a b (Cons c d Nil) -> flip runReaderT r $+ N4 <$!> icode a <*!> icode b <*!> icode c <*!> icode d+ Cons a b (Cons c d (Cons e f as)) -> flip runReaderT r $+ N6 <$!> icode a <*!> icode b <*!> icode c+ <*!> icode d <*!> icode e <*!> icode f <*!> icodeListPair as++{-# INLINABLE valueListPair #-}+valueListPair :: EmbPrj k => EmbPrj v => Node -> R [(k, v)]+valueListPair as = ReaderT \r -> case as of+ N0 -> pure []+ N2 a b -> flip runReaderT r do+ !a <- value a+ !b <- value b+ pure [(a, b)]+ N4 a b c d -> flip runReaderT r do+ !a <- value a+ !b <- value b+ !c <- value c+ !d <- value d+ pure [(a, b), (c, d)]+ N6 a b c d e f as -> flip runReaderT r do+ !a <- value a+ !b <- value b+ !c <- value c+ !d <- value d+ !e <- value e+ !f <- value f+ !as <- valueListPair as+ pure ((a, b):(c, d):(e, f):as)+ _ -> malformedIO++---------------------------------------------------------------------------+-- Maps++instance (EmbPrj k, EmbPrj v, EmbPrj (BiMap.Tag v)) =>+ EmbPrj (BiMap k v) where+ icod_ m = icode (BiMap.toDistinctAscendingLists m)+ value m = BiMap.fromDistinctAscendingLists <$!> value m++instance (Hashable k, EmbPrj k, EmbPrj v) => EmbPrj (HashMap k v) where+ icod_ m = icodeNode =<< icodeListPair (HMap.foldrWithKey' (\ k v !acc -> Cons k v acc) Nil m)+ value = vcase ((HMap.fromList <$!>) . valueListPair)++instance (Ord a, EmbPrj a, EmbPrj b) => EmbPrj (Map a b) where+ icod_ m = icodeNode =<< icodeListPair (Map.foldrWithKey' (\ k v !acc -> Cons k v acc) Nil m)+ value = vcase ((Map.fromAscList <$!>) . valueListPair)++---------------------------------------------------------------------------+-- Sets++instance EmbPrj IntSet where+ icod_ s = icode (IntSet.foldr' (:) [] s)+ value s = IntSet.fromDistinctAscList <$!> value s++instance (EmbPrj a) => EmbPrj (Set a) where+ icod_ s = icode (Set.foldr' (:) [] s)+ value s = Set.fromDistinctAscList <$!> value s++instance (Hashable a, EmbPrj a) => EmbPrj (HashSet a) where+ icod_ s = icode (Fold.foldr' (:) [] s)+ value s = HSet.fromList <$!> value s++instance (EmbPrj a) => EmbPrj (Set1 a) where+ icod_ s = icode (Set1.foldr' (:) [] s)+ value s = Set1.fromDistinctAscList <$!> value s++instance Typeable a => EmbPrj (SmallSet a) where+ icod_ (SmallSet a) = icodeN' SmallSet a+ value = valueN SmallSet++instance EmbPrj VarSet where+ icod_ = icodeVarSet+ value i = flip AL.index (fromIntegral i) <$!> asks varSetA++---------------------------------------------------------------------------+-- Trees++instance (Ord a, EmbPrj a, EmbPrj b) => EmbPrj (Trie a b) where+ icod_ (Trie a b) = icodeN' Trie a b+ value = valueN Trie++instance EmbPrj a => EmbPrj (DocTree.DocTree a) where+ icod_ = \case+ DocTree.Text a -> icodeN' DocTree.Text a+ DocTree.Node a b -> icodeN' DocTree.Node a b++ value = vcase \case+ N1 a -> valuN DocTree.Text a+ N2 a b -> valuN DocTree.Node a b+ _ -> malformed
src/full/Agda/TypeChecking/Serialise/Instances/Highlighting.hs view
@@ -1,24 +1,25 @@-{-# OPTIONS_GHC -Wunused-imports #-} +{-# OPTIONS_GHC -Wunused-imports #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Agda.TypeChecking.Serialise.Instances.Highlighting where +import Control.Monad.Reader import qualified Data.Map.Strict as Map-import Data.Strict.Tuple (Pair(..))-import Data.Word (Word32) -import qualified Agda.Interaction.Highlighting.Range as HR+import Agda.Utils.Monad+import Agda.Utils.Range (Range(..)) import qualified Agda.Interaction.Highlighting.Precise as HP-import qualified Agda.Utils.RangeMap as RM+import Agda.Utils.RangeMap (PairInt(..))+import qualified Agda.Utils.RangeMap as RM import Agda.TypeChecking.Serialise.Base import Agda.TypeChecking.Serialise.Instances.Common () --instance only -instance EmbPrj HR.Range where- icod_ (HR.Range a b) = icodeN' HR.Range a b+instance EmbPrj Range where+ icod_ (Range a b) = icodeN' Range a b - value = valueN HR.Range+ value = valueN Range instance EmbPrj HP.NameKind where icod_ HP.Bound = icodeN' HP.Bound@@ -35,19 +36,19 @@ icod_ HP.Generalizable = icodeN 11 () value = vcase valu where- valu [] = valuN HP.Bound- valu [1 , a] = valuN HP.Constructor a- valu [2] = valuN HP.Datatype- valu [3] = valuN HP.Field- valu [4] = valuN HP.Function- valu [5] = valuN HP.Module- valu [6] = valuN HP.Postulate- valu [7] = valuN HP.Primitive- valu [8] = valuN HP.Record- valu [9] = valuN HP.Argument- valu [10] = valuN HP.Macro- valu [11] = valuN HP.Generalizable- valu _ = malformed+ valu N0 = valuN HP.Bound+ valu (N2 1 a) = valuN HP.Constructor a+ valu (N1 2) = valuN HP.Datatype+ valu (N1 3) = valuN HP.Field+ valu (N1 4) = valuN HP.Function+ valu (N1 5) = valuN HP.Module+ valu (N1 6) = valuN HP.Postulate+ valu (N1 7) = valuN HP.Primitive+ valu (N1 8) = valuN HP.Record+ valu (N1 9) = valuN HP.Argument+ valu (N1 10) = valuN HP.Macro+ valu (N1 11) = valuN HP.Generalizable+ valu _ = malformed instance EmbPrj HP.Aspect where icod_ HP.Comment = icodeN 0 ()@@ -61,20 +62,22 @@ icod_ HP.Background = icodeN 7 () icod_ HP.Markup = icodeN 8 () icod_ HP.Hole = icodeN 9 ()+ icod_ (HP.URL a) = icodeN 10 HP.URL a value = vcase valu where- valu [0] = valuN HP.Comment- valu [1] = valuN HP.Keyword- valu [2] = valuN HP.String- valu [3] = valuN HP.Number- valu [] = valuN HP.Symbol- valu [4] = valuN HP.PrimitiveType- valu [5, mk, b] = valuN HP.Name mk b- valu [6] = valuN HP.Pragma- valu [7] = valuN HP.Background- valu [8] = valuN HP.Markup- valu [9] = valuN HP.Hole- valu _ = malformed+ valu (N1 0) = valuN HP.Comment+ valu (N1 1) = valuN HP.Keyword+ valu (N1 2) = valuN HP.String+ valu (N1 3) = valuN HP.Number+ valu N0 = valuN HP.Symbol+ valu (N1 4) = valuN HP.PrimitiveType+ valu (N3 5 mk b) = valuN HP.Name mk b+ valu (N1 6) = valuN HP.Pragma+ valu (N1 7) = valuN HP.Background+ valu (N1 8) = valuN HP.Markup+ valu (N1 9) = valuN HP.Hole+ valu (N2 10 a) = valuN HP.URL a+ valu _ = malformed instance EmbPrj HP.OtherAspect where icod_ HP.Error = pure 0@@ -82,7 +85,7 @@ icod_ HP.DottedPattern = pure 2 icod_ HP.UnsolvedMeta = pure 3 icod_ HP.TerminationProblem = pure 4- icod_ HP.IncompletePattern = pure 5+ -- 5 is unused icod_ HP.TypeChecks = pure 6 icod_ HP.UnsolvedConstraint = pure 7 icod_ HP.PositivityProblem = pure 8@@ -101,7 +104,7 @@ 2 -> pure HP.DottedPattern 3 -> pure HP.UnsolvedMeta 4 -> pure HP.TerminationProblem- 5 -> pure HP.IncompletePattern+ -- 5 is unused 6 -> pure HP.TypeChecks 7 -> pure HP.UnsolvedConstraint 8 -> pure HP.PositivityProblem@@ -125,28 +128,52 @@ value = valueN HP.DefinitionSite -instance EmbPrj a => EmbPrj (RM.RangeMap a) where- -- 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 Empty (Map.toAscList f) where- convert :: Node -> [(Int, RM.PairInt a)] -> S Node- convert !ys [] = return ys- convert ys ((start, RM.PairInt (end :!: entry)):xs) = do- !start <- icode start- !end <- icode end- !entry <- icode entry- convert (Cons start (Cons end (Cons entry ys))) xs+data KVS a = Cons !Int !Int a !(KVS a) | Nil - value = vcase (fmap (RM.RangeMap . Map.fromDistinctAscList) . convert []) where- convert :: [(Int, RM.PairInt a)] -> [Word32] -> R [(Int, RM.PairInt a)]- 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+toAscList' :: RM.RangeMap a -> KVS a+toAscList' (RM.RangeMap x) =+ Map.foldrWithKey'+ (\a (b :!: c) !acc -> Cons a b c acc)+ Nil x++{-# INLINABLE icodRM #-}+icodRM :: EmbPrj a => KVS a -> S Node+icodRM xs = ReaderT \r -> case xs of+ Nil ->+ pure N0+ Cons a b c Nil -> flip runReaderT r $+ N3 <$!> icode a <*!> icode b <*!> icode c+ Cons a b c (Cons d e f xs) -> flip runReaderT r $+ N6 <$!> icode a <*!> icode b <*!> icode c+ <*!> icode d <*!> icode e <*!> icode f <*!> icodRM xs++{-# INLINABLE valueRM #-}+valueRM :: EmbPrj a => Node -> R [(Int, PairInt a)]+valueRM as = ReaderT \r -> case as of+ N0 ->+ pure []+ N3 a b c -> flip runReaderT r do+ !a <- value a+ !b <- value b+ !c <- value c+ pure [(a, b :!: c)]+ N6 a b c d e f as -> flip runReaderT r do+ !a <- value a+ !b <- value b+ !c <- value c+ !d <- value d+ !e <- value e+ !f <- value f+ !as <- valueRM as+ pure ((a, b :!: c):(d, e :!: f):as)+ _ -> malformedIO++-- We serialize as a flat list of triples+instance EmbPrj a => EmbPrj (RM.RangeMap a) where+ {-# INLINE icod_ #-}+ icod_ x = icodeNode =<< icodRM (toAscList' x) where+ {-# INLINE value #-}+ value = vcase (\n -> RM.RangeMap . Map.fromDistinctAscList <$!> valueRM n) where instance EmbPrj HP.TokenBased where icod_ HP.TokenBased = pure 0
src/full/Agda/TypeChecking/Serialise/Instances/Internal.hs view
@@ -1,13 +1,14 @@ +{-# OPTIONS_GHC -Wunused-imports #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Agda.TypeChecking.Serialise.Instances.Internal where import qualified Data.HashSet as HashSet import Control.Monad-import Control.Monad.IO.Class import Agda.Syntax.Internal as I+import Agda.Syntax.Common ( IsHIT(..) ) import Agda.Syntax.Position as P import Agda.TypeChecking.Serialise.Base@@ -25,7 +26,7 @@ import Agda.Utils.Impossible instance EmbPrj a => EmbPrj (Dom a) where- icod_ (Dom a c d e f) = icodeN' Dom a c d e f+ icod_ (Dom a c d e f g) = icodeN' Dom a c d e f g value = valueN Dom @@ -49,8 +50,8 @@ icod_ (ExtendTel a b) = icodeN' ExtendTel a b value = vcase valu where- valu [] = valuN EmptyTel- valu [a, b] = valuN ExtendTel a b+ valu N0 = valuN EmptyTel+ valu (N2 a b) = valuN ExtendTel a b valu _ = malformed instance EmbPrj Permutation where@@ -65,27 +66,18 @@ instance EmbPrj a => EmbPrj (Elim' a) where icod_ (Apply a) = icodeN' Apply a- icod_ (IApply x y a) = icodeN 0 IApply x y a- icod_ (Proj a b) = icodeN 0 Proj a b+ icod_ (IApply x y a) = icodeN' IApply x y a+ icod_ (Proj a b) = icodeN' Proj a b value = vcase valu where- valu [a] = valuN Apply a- valu [0,x,y,a] = valuN IApply x y a- valu [0, a, b] = valuN Proj a b- valu _ = malformed+ valu (N1 a) = valuN Apply a+ valu (N3 x y a) = valuN IApply x y a+ valu (N2 a b) = valuN Proj a b+ valu _ = malformed -instance EmbPrj I.DataOrRecord where- icod_ = \case- IsData -> icodeN' IsData- IsRecord pm -> icodeN' IsRecord pm - value = vcase $ \case- [] -> valuN IsData- [pm] -> valuN IsRecord pm- _ -> malformed- instance EmbPrj I.ConHead where- icod_ (ConHead a b c d) = icodeN' ConHead a b c d+ icod_ (ConHead a b c d e) = icodeN' ConHead a b c d e value = valueN ConHead @@ -99,12 +91,23 @@ icod_ (Abs a b) = icodeN' Abs a b value = vcase valu where- valu [a, b] = valuN Abs a b- valu [0, a, b] = valuN NoAbs a b- valu _ = malformed+ valu (N2 a b) = valuN Abs a b+ valu (N3 0 a b) = valuN NoAbs a b+ valu _ = malformed +instance EmbPrj I.DummyTermKind where+ icod_ (DummyNamed a) = icodeN' DummyNamed a+ icod_ (DummyBrave a) = icodeN 0 DummyBrave a++ value = vcase valu where+ valu (N1 a) = valuN DummyNamed a+ valu (N2 0 a) = valuN DummyBrave a+ valu _ = malformed+ instance EmbPrj I.Term where- icod_ (Var a []) = icodeN' (\ a -> Var a []) a+ icod_ (Var a []) = case cacheVar a of+ Just a -> pure a+ Nothing -> icodeN' (\a -> Var a []) a icod_ (Var a b) = icodeN 0 Var a b icod_ (Lam a b) = icodeN 1 Lam a b icod_ (Lit a ) = icodeN 2 Lit a@@ -117,20 +120,22 @@ icod_ (Level a ) = icodeN 9 Level a icod_ (Dummy a b) = icodeN 10 Dummy a b - value = vcase valu where- valu [a] = valuN var a- valu [0, a, b] = valuN Var a b- valu [1, a, b] = valuN Lam a b- valu [2, a] = valuN Lit a- 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+ value x = case uncacheVar x of+ Just t -> pure t+ Nothing -> flip vcase x \case+ N1 a -> valuN var a+ N3 0 a b -> valuN Var a b+ N3 1 a b -> valuN Lam a b+ N2 2 a -> valuN Lit a+ N3 3 a b -> valuN Def a b+ N4 4 a b c -> valuN Con a b c+ N3 5 a b -> valuN Pi a b+ N3 6 a b -> valuN MetaV a b+ N2 7 a -> valuN Sort a+ N2 8 a -> valuN DontCare a+ N2 9 a -> valuN Level a+ N3 10 a b -> valuN Dummy a b+ _ -> malformed instance EmbPrj Level where icod_ (Max a b) = icodeN' Max a b@@ -154,34 +159,44 @@ instance EmbPrj I.Sort where icod_ = \case- Univ a b -> icodeN 0 Univ a b- SizeUniv -> icodeN 2 SizeUniv- Inf a b -> icodeN 3 Inf a b- PiSort a b c -> icodeN 4 PiSort a b c- FunSort a b -> icodeN 5 FunSort a b- UnivSort a -> icodeN 6 UnivSort a- DefS a b -> icodeN 7 DefS a b- LockUniv -> icodeN 9 LockUniv- IntervalUniv -> icodeN 10 IntervalUniv- MetaS a b -> icodeN 11 MetaS a b- DummyS s -> icodeN 12 DummyS s- LevelUniv -> icodeN 13 LevelUniv+ Univ a b -> icodeN 0 Univ a b+ SizeUniv -> icodeN 2 SizeUniv+ Inf a b -> icodeN 3 Inf a b+ PiSort a b c d -> icodeN 4 PiSort a b c d+ FunSort a b -> icodeN 5 FunSort a b+ UnivSort a -> icodeN 6 UnivSort a+ DefS a b -> icodeN 7 DefS a b+ LockUniv -> icodeN 9 LockUniv+ IntervalUniv -> icodeN 10 IntervalUniv+ MetaS a b -> icodeN 11 MetaS a b+ DummyS s -> icodeN 12 DummyS s+ LevelUniv -> icodeN 13 LevelUniv value = vcase valu where- valu [0, a, b] = valuN Univ a b- valu [2] = valuN SizeUniv- valu [3, a, b] = valuN Inf a b- valu [4, a, b, c] = valuN PiSort a b c- valu [5, a, b] = valuN FunSort a b- valu [6, a] = valuN UnivSort a- valu [7, a, b] = valuN DefS a b- valu [9] = valuN LockUniv- valu [10] = valuN IntervalUniv- valu [11, a, b] = valuN MetaS a b- valu [12, s] = valuN DummyS s- valu [13] = valuN LevelUniv- valu _ = malformed+ valu (N3 0 a b) = valuN Univ a b+ valu (N1 2) = valuN SizeUniv+ valu (N3 3 a b) = valuN Inf a b+ valu (N5 4 a b c d) = valuN PiSort a b c d+ valu (N3 5 a b) = valuN FunSort a b+ valu (N2 6 a) = valuN UnivSort a+ valu (N3 7 a b) = valuN DefS a b+ valu (N1 9) = valuN LockUniv+ valu (N1 10) = valuN IntervalUniv+ valu (N3 11 a b) = valuN MetaS a b+ valu (N2 12 s) = valuN DummyS s+ valu (N1 13) = valuN LevelUniv+ valu _ = malformed +instance EmbPrj a => EmbPrj (BlockedDepCheck a) where+ icod_ = \case+ CodomainSortOld a -> icodeN 0 CodomainSortOld a+ CodomainSortSame -> icodeN 1 CodomainSortSame++ value = vcase valu where+ valu (N2 0 a) = valuN CodomainSortOld a+ valu (N1 1) = valuN CodomainSortSame+ valu _ = malformed+ instance EmbPrj DisplayForm where icod_ (Display a b c) = icodeN' Display a b c @@ -204,11 +219,11 @@ icod_ (DWithApp a b c) = icodeN 4 DWithApp a b c value = vcase valu where- valu [a, b] = valuN DTerm' a b- valu [1, a, b] = valuN DDot' a b- valu [2, a, b, c] = valuN DCon a b c- valu [3, a, b] = valuN DDef a b- valu [4, a, b, c] = valuN DWithApp a b c+ valu (N2 a b) = valuN DTerm' a b+ valu (N3 1 a b) = valuN DDot' a b+ valu (N4 2 a b c) = valuN DCon a b c+ valu (N3 3 a b) = valuN DDef a b+ valu (N4 4 a b c) = valuN DWithApp a b c valu _ = malformed instance EmbPrj MutualId where@@ -224,8 +239,8 @@ value = valueN InstanceInfo instance EmbPrj Definition where- icod_ (Defn a b c d e f g h i j k l m n o blocked r s) =- icodeN' Defn a b (P.killRange c) d e f g h i j k l m n o (ossify blocked) r s+ icod_ (Defn a b c d e f g h i j k l m n o blocked r s t) =+ icodeN' Defn a b (P.killRange c) d e f g h i j k l m n o (ossify blocked) r s t where -- Andreas, 2024-01-02, issue #7044: -- After serialization, a definition can never be unblocked,@@ -238,19 +253,19 @@ value = valueN Defn instance EmbPrj NotBlocked where- icod_ ReallyNotBlocked = icodeN' ReallyNotBlocked- icod_ (StuckOn a) = icodeN 0 StuckOn a- icod_ Underapplied = icodeN 1 Underapplied- icod_ AbsurdMatch = icodeN 2 AbsurdMatch+ icod_ ReallyNotBlocked = icodeN' ReallyNotBlocked+ icod_ (StuckOn a) = icodeN 0 StuckOn a+ icod_ Underapplied = icodeN 1 Underapplied+ icod_ AbsurdMatch = icodeN 2 AbsurdMatch 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, a] = valuN MissingClauses a- valu _ = malformed+ valu N0 = valuN ReallyNotBlocked+ valu (N2 0 a) = valuN StuckOn a+ valu (N1 1) = valuN Underapplied+ valu (N1 2) = valuN AbsurdMatch+ valu (N2 3 a) = valuN MissingClauses a+ valu _ = malformed -- Andreas, 2024-01-02, issue #7044. -- We only serialize 'neverUnblock';@@ -269,8 +284,10 @@ icod_ = icod_ . blockedToMaybe value = blockedFromMaybe <.> value +instance EmbPrj DefSing where+ instance EmbPrj NLPat where- icod_ (PVar a b) = icodeN 0 PVar a b+ icod_ (PVar a b c) = icodeN 0 PVar a b c icod_ (PDef a b) = icodeN 1 PDef a b icod_ (PLam a b) = icodeN 2 PLam a b icod_ (PPi a b) = icodeN 3 PPi a b@@ -279,13 +296,13 @@ icod_ (PTerm a) = icodeN 6 PTerm a value = vcase valu where- valu [0, a, b] = valuN PVar a b- valu [1, a, b] = valuN PDef a b- valu [2, a, b] = valuN PLam a b- valu [3, a, b] = valuN PPi a b- valu [4, a] = valuN PSort a- valu [5, a, b] = valuN PBoundVar a b- valu [6, a] = valuN PTerm a+ valu (N4 0 a b c) = valuN PVar a b c+ valu (N3 1 a b) = valuN PDef a b+ valu (N3 2 a b) = valuN PLam a b+ valu (N3 3 a b) = valuN PPi a b+ valu (N2 4 a) = valuN PSort a+ valu (N3 5 a b) = valuN PBoundVar a b+ valu (N2 6 a) = valuN PTerm a valu _ = malformed instance EmbPrj NLPType where@@ -304,21 +321,46 @@ icod_ PLevelUniv = icodeN 7 PLevelUniv value = vcase valu where- valu [0, a] = valuN PType a- valu [1, a] = valuN PProp a- 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 [7] = valuN PLevelUniv- valu _ = malformed+ valu (N2 0 a) = valuN PType a+ valu (N2 1 a) = valuN PProp a+ valu (N3 2 f a) = valuN PInf f a+ valu (N1 3) = valuN PSizeUniv+ valu (N1 4) = valuN PLockUniv+ valu (N1 5) = valuN PIntervalUniv+ valu (N2 6 a) = valuN PSSet a+ valu (N1 7) = valuN PLevelUniv+ valu _ = malformed +instance EmbPrj GlobalRewriteRule where+ icod_ (GlobalRewriteRule a b c d e f g h) =+ icodeN' GlobalRewriteRule a b c d e f g h++ value = valueN GlobalRewriteRule++instance EmbPrj LocalEquation where+ icod_ (LocalEquation a b c d) = icodeN' LocalEquation a b c d++ value = valueN LocalEquation++instance EmbPrj RewriteHead where+ icod_ (RewDefHead a) = icodeN 0 RewDefHead a+ icod_ (RewVarHead a) = icodeN 1 RewVarHead a++ value = vcase valu where+ valu (N2 0 a) = valuN RewDefHead a+ valu (N2 1 a) = valuN RewVarHead a+ valu _ = malformed+ instance EmbPrj RewriteRule where- icod_ (RewriteRule a b c d e f g h) = icodeN' RewriteRule a b c d e f g h+ icod_ (RewriteRule a b c d e) = icodeN' RewriteRule a b c d e value = valueN RewriteRule +instance EmbPrj RewDom where+ icod_ (RewDom a b) = icodeN' RewDom a b++ value = valueN RewDom+ instance EmbPrj Projection where icod_ (Projection a b c d e) = icodeN' Projection a b c d e @@ -359,13 +401,29 @@ value 1 = return NotForced value _ = malformed +instance EmbPrj IsPathCons where+ icod_ PathCons = return 0+ icod_ PointCons = return 1++ value 0 = return PathCons+ value 1 = return PointCons+ value _ = malformed++instance EmbPrj IsHIT where+ icod_ YesHIT = return 0+ icod_ NotHIT = return 1++ value 0 = return YesHIT+ value 1 = return NotHIT+ value _ = malformed+ instance EmbPrj NumGeneralizableArgs where icod_ NoGeneralizableArgs = icodeN' NoGeneralizableArgs icod_ (SomeGeneralizableArgs a) = icodeN' SomeGeneralizableArgs a value = vcase valu where- valu [] = valuN NoGeneralizableArgs- valu [a] = valuN SomeGeneralizableArgs a+ valu N0 = valuN NoGeneralizableArgs+ valu (N1 a) = valuN SomeGeneralizableArgs a valu _ = malformed instance EmbPrj DoGeneralize where@@ -395,14 +453,13 @@ value _ = malformed instance EmbPrj EtaEquality where- icod_ (Specified a) = icodeN 0 Specified a- icod_ (Inferred a) = icodeN 1 Inferred a-+ icod_ (EtaEquality a b) = icodeN' EtaEquality a b value = vcase valu where- valu [0,a] = valuN Specified a- valu [1,a] = valuN Inferred a- valu _ = malformed+ valu (N2 a b) = valuN EtaEquality a b+ valu _ = malformed +instance EmbPrj EtaProvenance+ instance EmbPrj ProjectionLikenessMissing instance EmbPrj BuiltinSort where@@ -413,47 +470,55 @@ SortLevelUniv -> icodeN 3 SortLevelUniv value = vcase \case- [0, a] -> valuN SortUniv a- [1, a] -> valuN SortOmega a- [2] -> valuN SortIntervalUniv- [3] -> valuN SortLevelUniv+ (N2 0 a) -> valuN SortUniv a+ (N2 1 a) -> valuN SortOmega a+ (N1 2) -> valuN SortIntervalUniv+ (N1 3) -> valuN SortLevelUniv+ _ -> malformed++instance EmbPrj a => EmbPrj (IsWithFunction a) where+ icod_ NoWithFunction = icodeN' NoWithFunction+ icod_ (WithFunction a) = icodeN' WithFunction a++ value = vcase \case+ N0 -> valuN NoWithFunction+ N1 a -> valuN WithFunction a _ -> malformed instance EmbPrj Defn where icod_ (Axiom a) = icodeN 0 Axiom a icod_ (Function a b s t u c d e f g h i j k) = icodeN 1 (\ a b s -> Function a b s t) a b s u c d e f g h i j k- 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 k) = icodeN 4 Constructor a b c d e f g h i j k+ icod_ (Datatype a b c d e f g h i j k) = icodeN 2 Datatype a b c d e f g h i j k+ icod_ (Record a b c d e f g h i j k l m n) = icodeN 3 Record a b c d e f g h i j k l m n+ icod_ (Constructor a b c d e f g h i j k l) = icodeN 4 Constructor a b c d e f g h i j k l icod_ (Primitive a b c d e f) = icodeN 5 Primitive a b c d e f icod_ (PrimitiveSort a b) = icodeN 6 PrimitiveSort a b icod_ AbstractDefn{} = __IMPOSSIBLE__ icod_ (GeneralizableVar a) = icodeN 7 GeneralizableVar a- icod_ (DataOrRecSig a) = icodeN 8 DataOrRecSig a- -- Andreas, 2024-10-27- -- DataOrRecSig is possible via unquoteDecl in meta-programming, see #7576+ icod_ DataOrRecSig{} = __IMPOSSIBLE__+ -- Andreas, 2026-10-19, issue #8851:+ -- unquoteDecl no longer leaves a DataOrRecSig behind (see #7576). - value = vcase valu where- valu [0, a] = valuN Axiom a- valu [1, a, b, s, u, c, d, e, f, g, h, i, j, k]- = valuN (\ a b s -> Function a b s Nothing) a b s u c d e f g h i j k- 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, k] = valuN Constructor a b c d e f g h i j k- valu [5, a, b, c, d, e, f] = valuN Primitive a b c d e f- valu [6, a, b] = valuN PrimitiveSort a b- valu [7, a] = valuN GeneralizableVar a- valu [8, a] = valuN DataOrRecSig a- valu _ = malformed+ value = vcase \case+ N2 0 a -> valuN Axiom a+ N6 1 a b s u c (N6 d e f g h i (N2 j k)) -> valuN (\ a b s -> Function a b s Nothing)+ a b s u c d e f g h i j k+ N6 2 a b c d e (N6 f g h i j k N0) -> valuN Datatype a b c d e f g h i j k+ N6 3 a b c d e (N6 f g h i j k (N3 l m n)) -> valuN Record a b c d e f g h i j k l m n+ N6 4 a b c d e (N6 f g h i j k (N1 l)) -> valuN Constructor a b c d e f g h i j k l+ N6 5 a b c d e (N1 f) -> valuN Primitive a b c d e f+ N3 6 a b -> valuN PrimitiveSort a b+ N2 7 a -> valuN GeneralizableVar a+ _ -> malformed instance EmbPrj LazySplit where icod_ StrictSplit = icodeN' StrictSplit icod_ LazySplit = icodeN 0 LazySplit value = vcase valu where- valu [] = valuN StrictSplit- valu [0] = valuN LazySplit- valu _ = malformed+ valu N0 = valuN StrictSplit+ valu (N1 0) = valuN LazySplit+ valu _ = malformed instance EmbPrj SplitTag where icod_ (SplitCon c) = icodeN 0 SplitCon c@@ -461,18 +526,18 @@ icod_ SplitCatchall = icodeN' SplitCatchall value = vcase valu where- valu [] = valuN SplitCatchall- valu [0, c] = valuN SplitCon c- valu [1, l] = valuN SplitLit l- valu _ = malformed+ valu N0 = valuN SplitCatchall+ valu (N2 0 c) = valuN SplitCon c+ valu (N2 1 l) = valuN SplitLit l+ valu _ = malformed instance EmbPrj a => EmbPrj (SplitTree' a) where icod_ (SplittingDone a) = icodeN' SplittingDone a icod_ (SplitAt a b c) = icodeN 0 SplitAt a b c value = vcase valu where- valu [a] = valuN SplittingDone a- valu [0, a, b, c] = valuN SplitAt a b c+ valu (N1 a) = valuN SplittingDone a+ valu (N4 0 a b c) = valuN SplitAt a b c valu _ = malformed instance EmbPrj FunctionFlag@@ -501,24 +566,27 @@ value = valueN (\id uf -> let !unfolding = HashSet.fromList uf in OpaqueBlock id unfolding mempty Nothing) +instance EmbPrj ClauseRecursive+ instance EmbPrj CompiledClauses where- icod_ (Fail a) = icodeN' Fail a- icod_ (Done a b) = icodeN' Done a (P.killRange b)- icod_ (Case a b) = icodeN 2 Case a b+ icod_ = \case+ Fail a -> icodeN' Fail a+ Done no mr a b -> icodeN' Done no mr a (P.killRange b)+ Case a b -> icodeN' Case a b - value = vcase valu where- valu [a] = valuN Fail a- valu [a, b] = valuN Done a b- valu [2, a, b] = valuN Case a b- valu _ = malformed+ value = vcase \case+ (N1 a) -> valuN Fail a+ (N4 no mr a b) -> valuN Done no mr a b+ (N2 a b) -> valuN Case a b+ _ -> malformed instance EmbPrj a => EmbPrj (FunctionInverse' a) where icod_ NotInjective = icodeN' NotInjective icod_ (Inverse a) = icodeN' Inverse a value = vcase valu where- valu [] = valuN NotInjective- valu [a] = valuN Inverse a+ valu N0 = valuN NotInjective+ valu (N1 a) = valuN Inverse a valu _ = malformed instance EmbPrj TermHead where@@ -529,12 +597,12 @@ icod_ UnknownHead = icodeN 4 UnknownHead value = vcase valu where- valu [] = valuN SortHead- valu [1] = valuN PiHead- valu [2, a] = valuN ConsHead a- valu [3, a] = valuN VarHead a- valu [4] = valuN UnknownHead- valu _ = malformed+ valu N0 = valuN SortHead+ valu (N1 1) = valuN PiHead+ valu (N2 2 a) = valuN ConsHead a+ valu (N2 3 a) = valuN VarHead a+ valu (N1 4) = valuN UnknownHead+ 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@@ -542,10 +610,14 @@ value = valueN Clause instance EmbPrj I.ConPatternInfo where- icod_ (ConPatternInfo a b c d e) = icodeN' ConPatternInfo a b c d e+ icod_ (ConPatternInfo a b c d e f) = icodeN' ConPatternInfo a b c d e f value = valueN ConPatternInfo +instance EmbPrj MatchPrio where+ icod_ (MatchPrio n) = icodeN' MatchPrio n+ value = valueN MatchPrio+ instance EmbPrj I.DBPatVar where icod_ (DBPatVar a b) = icodeN' DBPatVar a b @@ -556,49 +628,53 @@ value = valueN PatternInfo +instance EmbPrj I.LitPatternInfo where+ icod_ (LitPatternInfo a b) = icodeN' LitPatternInfo a b+ value = valueN LitPatternInfo+ instance EmbPrj I.PatOrigin where- icod_ PatOSystem = icodeN' PatOSystem- icod_ PatOSplit = icodeN 1 PatOSplit- icod_ (PatOVar a) = icodeN 2 PatOVar a- icod_ PatODot = icodeN 3 PatODot- icod_ PatOWild = icodeN 4 PatOWild- icod_ PatOCon = icodeN 5 PatOCon- icod_ PatORec = icodeN 6 PatORec- icod_ PatOLit = icodeN 7 PatOLit- icod_ PatOAbsurd = icodeN 8 PatOAbsurd+ icod_ PatOSystem = icodeN' PatOSystem+ icod_ PatOSplit = icodeN 1 PatOSplit+ icod_ (PatOVar a) = icodeN 2 PatOVar a+ icod_ PatODot = icodeN 3 PatODot+ icod_ PatOWild = icodeN 4 PatOWild+ icod_ PatOCon = icodeN 5 PatOCon+ icod_ PatORec = icodeN 6 PatORec+ icod_ PatOLit = icodeN 7 PatOLit+ icod_ PatOAbsurd = icodeN 8 PatOAbsurd icod_ (PatOSplitArg a) = icodeN 9 PatOSplitArg a value = vcase valu where- valu [] = valuN PatOSystem- valu [1] = valuN PatOSplit- valu [2, a] = valuN PatOVar a- valu [3] = valuN PatODot- valu [4] = valuN PatOWild- valu [5] = valuN PatOCon- valu [6] = valuN PatORec- valu [7] = valuN PatOLit- valu [8] = valuN PatOAbsurd- valu [9, a] = valuN PatOSplitArg a- valu _ = malformed+ valu N0 = valuN PatOSystem+ valu (N1 1) = valuN PatOSplit+ valu (N2 2 a) = valuN PatOVar a+ valu (N1 3) = valuN PatODot+ valu (N1 4) = valuN PatOWild+ valu (N1 5) = valuN PatOCon+ valu (N1 6) = valuN PatORec+ valu (N1 7) = valuN PatOLit+ valu (N1 8) = valuN PatOAbsurd+ valu (N2 9 a) = valuN PatOSplitArg a+ valu _ = malformed instance EmbPrj a => EmbPrj (I.Pattern' a) where- icod_ (VarP a b ) = icodeN 0 VarP a b- icod_ (ConP a b c) = icodeN 1 ConP a b c- icod_ (LitP a b ) = icodeN 2 LitP a b- icod_ (DotP a b ) = icodeN 3 DotP a b- icod_ (ProjP a b ) = icodeN 4 ProjP a b+ icod_ (VarP a b ) = icodeN 0 VarP a b+ icod_ (ConP a b c) = icodeN 1 ConP a b c+ icod_ (LitP a b ) = icodeN 2 LitP a b+ icod_ (DotP a b ) = icodeN 3 DotP a b+ icod_ (ProjP a b ) = icodeN 4 ProjP a b icod_ (IApplyP a b c d) = icodeN 5 IApplyP a b c d- icod_ (DefP a b c) = icodeN 6 DefP a b c+ icod_ (DefP a b c) = icodeN 6 DefP a b c value = vcase valu where- valu [0, a, b] = valuN VarP a b- valu [1, a, b, c] = valuN ConP a b c- valu [2, a, b] = valuN LitP a b- valu [3, a, b] = valuN DotP a b- valu [4, a, b] = valuN ProjP a b- valu [5, a, b, c, d] = valuN IApplyP a b c d- valu [6, a, b, c] = valuN DefP a b c- valu _ = malformed+ valu (N3 0 a b) = valuN VarP a b+ valu (N4 1 a b c) = valuN ConP a b c+ valu (N3 2 a b) = valuN LitP a b+ valu (N3 3 a b) = valuN DotP a b+ valu (N3 4 a b) = valuN ProjP a b+ valu (N5 5 a b c d) = valuN IApplyP a b c d+ valu (N4 6 a b c) = valuN DefP a b c+ valu _ = malformed instance EmbPrj a => EmbPrj (Builtin a) where icod_ (Prim a) = icodeN' Prim a@@ -606,10 +682,10 @@ 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+ valu (N1 a) = valuN Prim a+ valu (N2 1 a) = valuN Builtin a+ valu (N2 2 a) = valuN BuiltinRewriteRelations a+ valu _ = malformed instance EmbPrj a => EmbPrj (Substitution' a) where icod_ IdS = icodeN' IdS@@ -620,12 +696,12 @@ icod_ (Lift a b) = icodeN 2 Lift a b value = vcase valu where- 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 N0 = valuN IdS+ valu (N1 a) = valuN EmptyS a+ valu (N2 a b) = valuN (:#) a b+ valu (N4 0 a b c) = valuN Strengthen a b c+ valu (N3 1 a b) = valuN Wk a b+ valu (N3 2 a b) = valuN Lift a b valu _ = malformed instance EmbPrj Instantiation where@@ -638,9 +714,9 @@ value = vcase valu where- valu [] = valuN CmpEq- valu [0] = valuN CmpLeq- valu _ = malformed+ valu N0 = valuN CmpEq+ valu (N1 0) = valuN CmpLeq+ valu _ = malformed instance EmbPrj a => EmbPrj (Judgement a) where icod_ (HasType a b c) = icodeN' HasType a b c@@ -648,8 +724,8 @@ value = vcase valu where- valu [a, b, c] = valuN HasType a b c- valu [a, b] = valuN IsSort a b+ valu (N3 a b c) = valuN HasType a b c+ valu (N2 a b) = valuN IsSort a b valu _ = malformed instance EmbPrj RemoteMetaVariable where@@ -665,13 +741,13 @@ icod_ SortK = icodeN 5 SortK value = vcase valu where- valu [0, x, y] = valuN RigidK x y- valu [1, x, y] = valuN LocalK x y- valu [2, h] = valuN PiK h- valu [3] = valuN FlexK- valu [4] = valuN ConstK- valu [5] = valuN SortK- valu _ = malformed+ valu (N3 0 x y) = valuN RigidK x y+ valu (N3 1 x y) = valuN LocalK x y+ valu (N2 2 h) = valuN PiK h+ valu (N1 3) = valuN FlexK+ valu (N1 4) = valuN ConstK+ valu (N1 5) = valuN SortK+ valu _ = malformed instance (EmbPrj a, Ord a) => EmbPrj (DiscrimTree a) where icod_ EmptyDT = icodeN' EmptyDT@@ -679,7 +755,7 @@ icod_ (CaseDT i k s) = icodeN' CaseDT i k s value = vcase valu where- valu [] = valuN EmptyDT- valu [a] = valuN DoneDT a- valu [i, k, s] = valuN CaseDT i k s- valu _ = malformed+ valu N0 = valuN EmptyDT+ valu (N1 a) = valuN DoneDT a+ valu (N3 i k s) = valuN CaseDT i k s+ valu _ = malformed
+ src/full/Agda/TypeChecking/Serialise/Node.hs view
@@ -0,0 +1,133 @@++{-# LANGUAGE Strict, MagicHash, AllowAmbiguousTypes, UnboxedTuples, CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wno-redundant-bang-patterns #-}++module Agda.TypeChecking.Serialise.Node where++import GHC.Exts+import GHC.Word+import Agda.Utils.Serialize+import Agda.Utils.Word+import Agda.Utils.Hash (combineWord)+import Data.Hashable+import Data.Bits++#include "MachDeps.h"++-- | Constructor tag (maybe omitted) and argument indices.+data Node+ = N0+ | N1# !Word32+ | N2# !Word64+ | N3# !Word64 !Word32+ | N4# !Word64 !Word64+ | N5# !Word64 !Word64 !Word32+ | N6# !Word64 !Word64 !Word64 !Node+ deriving (Show)++pattern N1 :: Word32 -> Node+pattern N1 a = N1# a+{-# INLINE N1 #-}++pattern N2 :: Word32 -> Word32 -> Node+pattern N2 a b <- N2# (splitW64 -> (a, b)) where+ N2 a b = N2# (packW64 a b)+{-# INLINE N2 #-}++pattern N3 :: Word32 -> Word32 -> Word32 -> Node+pattern N3 a b c <- N3# (splitW64 -> (a, b)) c where+ N3 a b c = N3# (packW64 a b) c+{-# INLINE N3 #-}++pattern N4 :: Word32 -> Word32 -> Word32 -> Word32 -> Node+pattern N4 a b c d <- N4# (splitW64 -> (a, b)) (splitW64 -> (c, d)) where+ N4 a b c d = N4# (packW64 a b) (packW64 c d)+{-# INLINE N4 #-}++pattern N5 :: Word32 -> Word32 -> Word32 -> Word32 -> Word32 -> Node+pattern N5 a b c d e <- N5# (splitW64 -> (a, b)) (splitW64 -> (c, d)) e where+ N5 a b c d e = N5# (packW64 a b) (packW64 c d) e+{-# INLINE N5 #-}++pattern N6 :: Word32 -> Word32 -> Word32 -> Word32 -> Word32 -> Word32 -> Node -> Node+pattern N6 a b c d e f n <- N6# (splitW64 -> (a, b)) (splitW64 -> (c, d)) (splitW64 -> (e, f)) n where+ N6 a b c d e f n = N6# (packW64 a b) (packW64 c d) (packW64 e f) n+{-# INLINE N6 #-}+{-# complete N0, N1, N2, N3, N4, N5, N6 #-}++instance Eq Node where+ N0 == N0 = True+ N1# a == N1# a' = a == a'+ N2# ab == N2# ab' = ab == ab'+ N3# ab c == N3# ab' c' = ab == ab' && c == c'+ N4# ab cd == N4# ab' cd' = ab == ab' && cd == cd'+ N5# ab cd e == N5# ab' cd' e' = ab == ab' && cd == cd' && e == e'+ N6# ab cd ef n == N6# ab' cd' ef' n' =+ ab == ab' && cd == cd' && ef == ef' && n == n'+ _ == _ = False++instance Hashable Node where+ -- Adapted from https://github.com/tkaitchuck/aHash/wiki/AHash-fallback-algorithm+ hashWithSalt h n = fromIntegral (go (fromIntegral h) n) where++ go :: Word -> Node -> Word+ go h N0 = h+ go h (N1# a) = h `combineWord` fromIntegral a+ go h (N2# a) = h `combineWord` fromIntegral a+ go h (N3# a b) = h `combineWord` fromIntegral a `combineWord` fromIntegral b+ go h (N4# a b) = h `combineWord` fromIntegral a `combineWord` fromIntegral b+ go h (N5# a b c) = h `combineWord` fromIntegral a `combineWord` fromIntegral b+ `combineWord` fromIntegral c+ go h (N6# a b c n) = let h' = h `combineWord` fromIntegral a+ `combineWord` fromIntegral b `combineWord` fromIntegral c+ in go h' n++--------------------------------------------------------------------------------++instance Serialize Node where+ size = go SIZEOF_HSINT where+ go :: Int -> Node -> Int+ go !acc = \case+ N0 -> acc+ N1#{} -> acc + SIZEOF_WORD32+ N2#{} -> acc + SIZEOF_WORD64+ N3#{} -> acc + SIZEOF_WORD64 + SIZEOF_WORD32+ N4#{} -> acc + SIZEOF_WORD64 + SIZEOF_WORD64+ N5#{} -> acc + SIZEOF_WORD64 + SIZEOF_WORD64 + SIZEOF_WORD32+ N6# _ _ _ n -> go (acc + SIZEOF_WORD64 + SIZEOF_WORD64 + SIZEOF_WORD64) n++ put n = Put \hd s -> let+ setHeader :: Int -> Addr# -> Put+ setHeader n hd = Put \p s -> case unPut (put n) hd s of+ (# _, s #) -> (# p, s #)++ go :: Node -> Int -> Addr# -> Put+ go n l hd = Put \p s -> case n of+ N0 -> unPut (setHeader l hd) p s+ N1# a -> unPut (put a <> setHeader (l + 1) hd) p s+ N2# ab -> unPut (put ab <> setHeader (l + 2) hd) p s+ N3# ab c -> unPut (put ab <> put c <> setHeader (l + 3) hd) p s+ N4# ab cd -> unPut (put ab <> put cd <> setHeader (l + 4) hd) p s+ N5# ab cd e -> unPut (put ab <> put cd <> put e <> setHeader (l + 5) hd) p s+ N6# ab cd ef n -> unPut (put ab <> put cd <> put ef <> go n (l + 6) hd) p s++ in unPut (go n 0 hd) (plusAddr# hd SIZEOF_HSINT#) s++ get = do {l <- get; ensure (unsafeShiftL l 2) \_ -> go l} where+ g32 :: Get Word32; {-# INLINE g32 #-}+ g32 = Get \_ p s -> case readWord32OffAddr# p 0# s of+ (# s, x #) -> (# plusAddr# p SIZEOF_WORD32#, s, W32# x #)+ g64 :: Get Word64; {-# INLINE g64 #-}+ g64 = Get \_ p s -> case readWord64OffAddr# p 0# s of+ (# s, x #) -> (# plusAddr# p SIZEOF_WORD64#, s, W64# x #)++ go :: Int -> Get Node+ go l = Get \e p s -> case l of+ 0 -> unGet (pure N0) e p s+ 1 -> unGet (N1# <$> g32) e p s+ 2 -> unGet (N2# <$> g64) e p s+ 3 -> unGet (N3# <$> g64 <*> g32) e p s+ 4 -> unGet (N4# <$> g64 <*> g64) e p s+ 5 -> unGet (N5# <$> g64 <*> g64 <*> g32) e p s+ l -> unGet (N6# <$> g64 <*> g64 <*> g64 <*> go (l - 6)) e p s
src/full/Agda/TypeChecking/SizedTypes.hs view
@@ -27,17 +27,19 @@ import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope-import {-# SOURCE #-} Agda.TypeChecking.CheckInternal (MonadCheckInternal, infer)+import {-# SOURCE #-} Agda.TypeChecking.CheckInternal (infer) import {-# SOURCE #-} Agda.TypeChecking.Constraints () -- instance MonadConstraint TCM import {-# SOURCE #-} Agda.TypeChecking.Conversion+import Agda.TypeChecking.Conversion.Errors -import Agda.Utils.Functor import Agda.Utils.List as List import Agda.Utils.List1 (pattern (:|))+import Agda.Utils.ListInf (ListInf, pattern (:<))+import Agda.Utils.ListInf qualified as ListInf import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null-import qualified Agda.Utils.ProfileOptions as Profile+import qualified Agda.Interaction.Options.ProfileOptions as Profile import Agda.Utils.Singleton import Agda.Utils.Size import Agda.Utils.Tuple@@ -137,10 +139,10 @@ -- Looking for the minimal value for size variable i, -- we can restrict to the last i -- entries, as only these can contain i in an upper bound.- ts <- map ctxEntryType . take i <$> getContext+ ts <- map ctxEntryType . cxTake i <$> getContext -- If we encountered a blocking meta in the context, we cannot -- say ``no'' for sure.- (n, blockers) <- runWriterT $ minSizeValAux ts $ repeat 0+ (n, blockers) <- runWriterT $ minSizeValAux ts $ ListInf.repeat 0 let blocker = unblockOnAll blockers if n > 0 then return True else if blocker == alwaysUnblock@@ -149,12 +151,11 @@ where -- Compute the least valuation for size context ts above the -- given valuation and return its last value.- minSizeValAux :: [Type] -> [Int] -> WriterT (Set Blocker) TCM Int- minSizeValAux _ [] = __IMPOSSIBLE__- minSizeValAux [] (n : _) = return n- minSizeValAux (t : ts) (n : ns) = do+ minSizeValAux :: [Type] -> ListInf Int -> WriterT (Set Blocker) TCM Int+ minSizeValAux [] (n :< _) = return n+ minSizeValAux (t : ts) (n :< ns) = do reportSDoc "tc.size" 60 $- text ("minSizeVal (n:ns) = " ++ show (take (length ts + 2) $ n:ns) +++ text ("minSizeVal (n:ns) = " ++ show (ListInf.take (length ts + 2) $ n :< ns) ++ " t =") <+> (text . show) t -- prettyTCM t -- Wrong context! -- n is the min. value for variable 0 which has type t. let cont = minSizeValAux ts ns@@ -174,8 +175,8 @@ -- Thus, we update the min value for @j@ with function @(max (n+1-m))@. DSizeVar (ProjectedVar j []) m -> do reportSLn "tc.size" 60 $ "minSizeVal upper bound v = " ++ show v- let ns' = List.updateAt j (max $ n + 1 - m) ns- reportSLn "tc.size" 60 $ "minSizeVal ns' = " ++ show (take (length ts + 1) ns')+ let ns' = ListInf.updateAt j (max $ n + 1 - m) ns+ reportSLn "tc.size" 60 $ "minSizeVal ns' = " ++ show (ListInf.take (length ts + 1) ns') minSizeValAux ts ns' DSizeMeta x _ _ -> perhaps (unblockOnMeta x) _ -> cont@@ -185,9 +186,7 @@ isBounded :: PureTCM m => Nat -> m BoundedSize isBounded i = isBoundedSizeType =<< typeOfBV i -isBoundedProjVar- :: (MonadCheckInternal m, PureTCM m)- => ProjectedVar -> m BoundedSize+isBoundedProjVar :: ProjectedVar -> TCM BoundedSize isBoundedProjVar pv = isBoundedSizeType =<< infer (unviewProjectedVar pv) isBoundedSizeType :: PureTCM m => Type -> m BoundedSize@@ -203,10 +202,7 @@ -- In @boundedSizeMetaHook v tel a@, @tel@ includes the current context. boundedSizeMetaHook :: ( MonadConstraint m- , MonadTCEnv m- , ReadTCState m , MonadAddContext m- , HasOptions m , HasBuiltins m ) => Term -> Telescope -> Type -> m ()@@ -233,13 +229,12 @@ -- like @Size< i =< Size@. -- -- If it does not succeed it reports failure of conversion check.-trySizeUniv- :: MonadConversion m- => Comparison -> CompareAs -> Term -> Term- -> QName -> Elims -> QName -> Elims -> m ()+trySizeUniv ::+ Comparison -> CompareAs -> Term -> Term+ -> QName -> Elims -> QName -> Elims -> TCM () trySizeUniv cmp t m n x els1 y els2 = do- let failure :: forall m a. MonadTCError m => m a- failure = typeError $ UnequalTerms cmp m n t+ let failure :: forall a. TCM a+ failure = failConversion cmp m n t forceInfty u = compareSizes CmpEq (unArg u) =<< primSizeInf -- Get the SIZE built-ins. (size, sizelt) <- maybe failure pure =<< runMaybeT do@@ -298,9 +293,8 @@ -- * Size comparison that might add constraints. ------------------------------------------------------------------------ -{-# SPECIALIZE compareSizes :: Comparison -> Term -> Term -> TCM () #-} -- | Compare two sizes.-compareSizes :: (MonadConversion m) => Comparison -> Term -> Term -> m ()+compareSizes :: Comparison -> Term -> Term -> TCM () compareSizes cmp u v = verboseBracket "tc.conv.size" 10 "compareSizes" $ do reportSDoc "tc.conv.size" 10 $ vcat [ "Comparing sizes"@@ -321,7 +315,7 @@ compareMaxViews cmp us vs -- | Compare two sizes in max view.-compareMaxViews :: (MonadConversion m) => Comparison -> SizeMaxView -> SizeMaxView -> m ()+compareMaxViews :: Comparison -> SizeMaxView -> SizeMaxView -> TCM () compareMaxViews cmp us vs = case (cmp, us, vs) of (CmpLeq, _, (DSizeInf :| _)) -> return () (cmp, u :| [], v :| []) -> compareSizeViews cmp u v@@ -332,7 +326,7 @@ compareMaxViews CmpLeq vs us -- | @compareBelowMax u vs@ checks @u <= max vs@. Precondition: @size vs >= 2@-compareBelowMax :: (MonadConversion m) => DeepSizeView -> SizeMaxView -> m ()+compareBelowMax :: DeepSizeView -> SizeMaxView -> TCM () compareBelowMax u vs = verboseBracket "tc.conv.size" 45 "compareBelowMax" $ do reportSDoc "tc.conv.size" 45 $ sep [ pretty u@@ -353,7 +347,7 @@ where alt c1 c2 = c1 `catchError` const c2 -compareSizeViews :: (MonadConversion m) => Comparison -> DeepSizeView -> DeepSizeView -> m ()+compareSizeViews :: Comparison -> DeepSizeView -> DeepSizeView -> TCM () compareSizeViews cmp s1' s2' = do reportSDoc "tc.conv.size" 45 $ hsep [ "compareSizeViews"@@ -367,7 +361,7 @@ u <- unDeepSizeView s1 v <- unDeepSizeView s2 cont u v- failure = withUnView $ \ u v -> typeError $ UnequalTerms cmp u v AsSizes+ failure = withUnView $ \ u v -> failConversion cmp u v AsSizes continue cmp = withUnView $ compareAtom cmp AsSizes case (cmp, s1, s2) of (CmpLeq, _, DSizeInf) -> return ()@@ -394,17 +388,17 @@ -- | If 'envAssignMetas' then postpone as constraint, otherwise, fail hard. -- Failing is required if we speculatively test several alternatives.-giveUp :: (MonadConversion m) => Comparison -> Type -> Term -> Term -> m ()+giveUp :: Comparison -> Type -> Term -> Term -> TCM () giveUp cmp size u v =- ifM (asksTC envAssignMetas)+ ifM (viewTC eAssignMetas) {-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)+ {-else-} (failConversion cmp u v AsSizes) -- | Checked whether a size constraint is trivial (like @X <= X+1@).-trivial :: (MonadConversion m) => Term -> Term -> m Bool+trivial :: Term -> Term -> TCM Bool trivial u v = do a@(e , n ) <- oldSizeExpr u b@(e', n') <- oldSizeExpr v@@ -544,10 +538,10 @@ oldComputeSizeConstraints cs = catMaybes <$> mapM oldComputeSizeConstraint leqs where -- get the constraints plus contexts they are defined in- gammas = map (envContext . clEnv . theConstraint) cs- ls = map (clValue . theConstraint) cs+ gammas = map' (view eContext . clEnv . theConstraint) cs+ ls = map' (clValue . theConstraint) cs -- compute the longest context (common water level)- ns = map size gammas+ ns = map' size gammas waterLevel = maximum ns -- lift all constraints to live in the longest context -- (assuming this context is an extension of the shorter ones)@@ -574,7 +568,7 @@ -- | Turn a term with de Bruijn indices into a size expression with offset. -- -- Throws a 'patternViolation' if the term isn't a proper size expression.-oldSizeExpr :: (PureTCM m, MonadBlock m) => Term -> m (OldSizeExpr, Int)+oldSizeExpr :: Term -> TCM (OldSizeExpr, Int) oldSizeExpr u = do u <- reduce u -- Andreas, 2009-02-09. -- This is necessary to surface the solutions of metavariables.@@ -582,7 +576,7 @@ s <- sizeView u case s of SizeInf -> patternViolation neverUnblock- SizeSuc u -> mapSnd (+ 1) <$> oldSizeExpr u+ SizeSuc u -> second (+ 1) <$> oldSizeExpr u OtherSize u -> case u of Var i [] -> return (Rigid i, 0) MetaV m es | Just xs <- mapM isVar es, fastDistinct xs
src/full/Agda/TypeChecking/SizedTypes/Solve.hs view
@@ -57,7 +57,6 @@ import Data.Foldable (forM_) import qualified Data.Foldable as Fold 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@@ -99,6 +98,7 @@ import Agda.Utils.Singleton import Agda.Utils.Size import qualified Agda.Utils.VarSet as VarSet+import Agda.Utils.VarSet (VarSet) import Agda.Utils.Impossible @@ -163,7 +163,7 @@ -- Convert each constraint in the cluster to the largest context. -- (Keep fingers crossed). - enterClosure (Fold.maximumBy (compare `on` (length . envContext . clEnv)) $ fmap theConstraint cs) $ \ _ -> do+ enterClosure (Fold.maximumBy (compare `on` (length . view eContext . clEnv)) $ fmap theConstraint cs) $ \ _ -> do -- Get all constraints that can be cast to the longest context. cs' :: [ProblemConstraint] <- List1.catMaybes <$> do mapM (runMaybeT . castConstraintToCurrentContext) cs@@ -241,8 +241,8 @@ castConstraintToCurrentContext' :: Closure TCM.Constraint -> MaybeT TCM TCM.Constraint castConstraintToCurrentContext' cl = do- let modN = envCurrentModule $ clEnv cl- delta = envContext $ clEnv cl+ let modN = view eCurrentModule $ clEnv cl+ delta = view eContext $ clEnv cl -- The module telescope of the constraint. -- The constraint could come from the module telescope of the top level module. -- In this case, it does not live in any module!@@ -302,14 +302,16 @@ -- Γ ⊢ c[σ] return $ applySubst sigma c where- raiseMaybe n c = do- -- Fine if we have to weaken or strengthening is safe.- guard $- n >= 0 ||- -- Are all free variables at least -n?- IntSet.null (fst $ IntSet.split (-n) $ allFreeVars c)- return $ raise n c+ raiseMaybe n c+ -- We are always fine to weaken.+ | n >= 0 = pure $ raise n c+ | otherwise =+ case VarSet.lookupMin $ freeVarSet c of+ Nothing -> pure $ raise n c+ Just k | -n < k -> pure $ raise n c+ | otherwise -> mzero +{-# SPECIALIZE allFreeVarIgnoreAll :: (Int -> Bool) -> TCM.Constraint -> Bool #-} -- | A hazardous hack, may the Gods have mercy on us. --@@ -322,7 +324,7 @@ castConstraintToCurrentContext c = do -- The checkpoint of the contraint let cl = theConstraint c- cp = envCurrentCheckpoint $ clEnv cl+ cp = view eCurrentCheckpoint $ clEnv cl sigma <- caseMaybeM (viewTC $ eCheckpoints . key cp) (do -- We are not in a descendant of the constraint checkpoint.@@ -331,15 +333,16 @@ let findInGamma ce = -- match by name (hazardous) -- This is one of the seven deadly sins (not respecting alpha).- List.findIndex (((==) `on` ctxEntryName) ce) gamma- let delta = envContext $ clEnv cl- cand = map findInGamma delta+ List.findIndex (((==) `on` ctxEntryName) ce) (cxEntries gamma)+ let delta = view eContext $ clEnv cl+ cand = map findInGamma $ cxEntries delta -- The domain of our substitution let coveredVars = VarSet.fromList $ catMaybes $ zipWith ($>) cand [0..] -- Check that all the free variables of the constraint are contained in -- coveredVars. -- We ignore the free variables occurring in sorts.- guard $ getAll $ runFree (All . (`VarSet.member` coveredVars)) IgnoreAll (clValue cl)+ -- guard $ getAll $ runFree (All . (`VarSet.member` coveredVars)) IgnoreAll (clValue cl)+ guard $ allFreeVarIgnoreAll (`VarSet.member` coveredVars) (clValue cl) -- Turn cand into a substitution. -- Since we ignored the free variables in sorts, we better patch up -- the substitution with some dummy term rather than __IMPOSSIBLE__.@@ -513,7 +516,7 @@ [ text $ " xs = " ++ show xs , text $ " u = " ++ show u ]- ifM (isFrozen m `or2M` (not <$> asksTC envAssignMetas)) (return Set.empty) $ do+ ifM (isFrozen m `or2M` (not <$> viewTC eAssignMetas)) (return Set.empty) $ do assignMeta n m t xs u return $ Set.singleton m -- WRONG:@@ -550,7 +553,7 @@ reportSDoc "tc.size.solve" 30 $ prettyTCM (MetaV m []) <+> "is frozen, cannot set it to ∞" return False- ifM (isFrozen m `or2M` do not <$> asksTC envAssignMetas) no $ {-else-} do+ ifM (isFrozen m `or2M` do not <$> viewTC eAssignMetas) no $ {-else-} do reportSDoc "tc.size.solve" 20 $ "solution " <+> prettyTCM (MetaV m []) <+> " := " <+> prettyTCM inf@@ -573,7 +576,7 @@ caseMaybe msizelt (return []) $ \ sizelt -> do -- Traverse the context from newest to oldest de Bruijn Index catMaybes <$> do- forM (zip [0..] gamma) $ \case+ forM (cxWithIndex (,) gamma) $ \case (i, CtxVar x a) -> do -- Get name and type of variable i. let s = prettyShow x@@ -676,7 +679,7 @@ -- | Turn a constraint over de Bruijn indices into a size constraint. computeSizeConstraint :: ProblemConstraint -> TCM (Maybe HypSizeConstraint) computeSizeConstraint c = do- let cxt = envContext $ clEnv $ theConstraint c+ let cxt = view eContext $ clEnv $ theConstraint c unsafeModifyContext (const cxt) $ do case clValue $ theConstraint c of ValueCmp CmpLeq _ u v -> do
src/full/Agda/TypeChecking/SizedTypes/Syntax.hs view
@@ -190,7 +190,7 @@ type CTrans r f = Constraint' r f -> Maybe [Constraint' r f] -- | Returns 'Nothing' if the constraint is contradictory.-simplify1 :: (Pretty f, Pretty r, Eq r) => CTrans r f -> CTrans r f+simplify1 :: (Eq r) => CTrans r f -> CTrans r f simplify1 test c = do let err = Nothing case c of
src/full/Agda/TypeChecking/SizedTypes/Utils.hs view
@@ -2,21 +2,21 @@ module Agda.TypeChecking.SizedTypes.Utils where -import Data.IORef import qualified Debug.Trace as Debug import System.IO.Unsafe import Agda.Utils.Function+import qualified Agda.Utils.IORef.Strict as Strict {-# NOINLINE debug #-}-debug :: IORef Bool-debug = unsafePerformIO $ newIORef False+debug :: Strict.IORef Bool+debug = unsafePerformIO $ Strict.newIORef False setDebugging :: Bool -> IO ()-setDebugging = writeIORef debug+setDebugging = Strict.writeIORef debug trace :: String -> a -> a-trace s = applyWhen (unsafePerformIO $ readIORef debug) $ Debug.trace s+trace s = applyWhen (unsafePerformIO $ Strict.readIORef debug) $ Debug.trace s traceM :: Applicative f => String -> f () traceM s = trace s $ pure ()
src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs view
@@ -949,7 +949,7 @@ -- | Check that after substitution of the solution, -- constraints are implied by hypotheses. verifySolution- :: (Ord r, Ord f, Pretty r, Pretty f, Show r, Show f)+ :: (Ord r, Ord f, Pretty r, Pretty f) => HypGraph r f -> [Constraint' r f] -> Solution r f
src/full/Agda/TypeChecking/Sort.hs view
@@ -27,7 +27,7 @@ import Data.Functor import Data.Maybe -import Agda.Interaction.Options (optCumulativity, optRewriting)+import Agda.Interaction.Options (optCumulativity) import Agda.Syntax.Common import Agda.Syntax.Internal@@ -41,6 +41,7 @@ import Agda.TypeChecking.Monad.Context import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Monad.MetaVars (metaType)+import Agda.TypeChecking.Monad.Options ( isLevelUniverseEnabled ) import Agda.TypeChecking.Monad.Pure import Agda.TypeChecking.Monad.Signature (HasConstInfo(..), applyDef) import Agda.TypeChecking.Pretty@@ -59,7 +60,7 @@ -- straight away, return that. Otherwise, return @UnivSort s@ and add a -- constraint to ensure we can compute the sort eventually. inferUnivSort- :: (PureTCM m, MonadConstraint m)+ :: (PureTCM m) => Sort -> m Sort inferUnivSort s = do s <- reduce s@@ -72,8 +73,7 @@ -- addConstraint $ HasBiggerSort s return $ UnivSort s -{-# SPECIALIZE sortFitsIn :: Sort -> Sort -> TCM () #-}-sortFitsIn :: MonadConversion m => Sort -> Sort -> m ()+sortFitsIn :: Sort -> Sort -> TCM () sortFitsIn a b = do b' <- inferUnivSort a ifM (optCumulativity <$> pragmaOptions)@@ -83,51 +83,25 @@ hasBiggerSort :: Sort -> TCM () hasBiggerSort = void . inferUnivSort -{-# SPECIALIZE inferPiSort :: Dom Type -> Abs Sort -> TCM Sort #-}+{-# SPECIALIZE inferPiSort :: Dom Type -> Abs Type -> TCM Sort #-} -- | Infer the sort of a Pi type. -- If we can compute the sort straight away, return that.--- Otherwise, return a 'PiSort' and add a constraint to ensure we can compute the sort eventually.----inferPiSort :: (PureTCM m, MonadConstraint m)+-- Otherwise, return a 'PiSort'.+-- Note that this function does NOT check PTS constraints, use 'hasPTSRule' for that+inferPiSort :: (MonadConstraint m) => Dom Type -- ^ Domain of the Pi type.- -> Abs Sort -- ^ (Dependent) sort of the codomain of the Pi type.+ -> Abs Type -- ^ (Dependent) codomain of the Pi type. -> m Sort -- ^ Sort of the Pi type.-inferPiSort a s = do- s1' <- reduceB $ getSort a- s2' <- mapAbstraction a reduceB s- let s1 = ignoreBlocking s1'- let s2 = ignoreBlocking <$> s2'- --Jesper, 2018-04-23: disabled PTS constraints for now,- --this assumes that piSort can only be blocked by unsolved metas.- --Arthur Adjedj, 2023-02-27, Turned PTS back on,- --piSort can now be blocked by Leveluniv- case piSort' (unEl <$> a) s1 s2 of- Right s -> return s- Left b -> do- let b' = unblockOnEither (getBlocker s1') (getBlocker $ unAbs s2')- addConstraint (unblockOnEither b b') $ HasPTSRule a s2- return $ PiSort (unEl <$> a) s1 s2+inferPiSort a b = piSortM (unEl <$> a) (getSort a) (getSort <$> b) -{-# SPECIALIZE inferFunSort :: Dom Type -> Sort -> TCM Sort #-}+{-# SPECIALIZE inferFunSort :: Dom Type -> Type -> TCM Sort #-} -- | As @inferPiSort@, but for a nondependent function type. ---inferFunSort :: (PureTCM m, MonadConstraint m)+inferFunSort :: (MonadConstraint m) => Dom Type -- ^ Domain of the function type.- -> Sort -- ^ Sort of the codomain of the function type.+ -> Type -- ^ Sort of the codomain of the function type. -> m Sort -- ^ Sort of the function type.-inferFunSort a s = do- s1' <- reduceB $ getSort a- s2' <- reduceB s- let s1 = ignoreBlocking s1'- let s2 = ignoreBlocking s2'- case funSort' s1 s2 of- Right s -> return s- Left b -> do- let b' = unblockOnEither (getBlocker s1') (getBlocker s2')- addConstraint (unblockOnEither b b') $ HasPTSRule a (NoAbs "_" s2)- return $ FunSort s1 s2- -- Andreas, 2023-05-20: I made inferFunSort step-by-step analogous to inferPiSort.- -- Unifying them seems unfeasible, though; too much parametrization...+inferFunSort a b = funSortM (getSort a) (getSort b) -- | @hasPTSRule a x.s@ checks that we can form a Pi-type @(x : a) -> b@ where @b : s@. --@@ -136,24 +110,27 @@ reportSDoc "tc.conv.sort" 35 $ vcat [ "hasPTSRule" , "a =" <+> prettyTCM a- , "s =" <+> prettyTCM (unAbs s)+ , "s =" <+> underAbstraction a s prettyTCM ]- if alwaysValidCodomain $ unAbs s+ -- If @LevelUniv@ is disabled then all pi sorts are valid.+ hasLevelUniv <- isLevelUniverseEnabled+ if not hasLevelUniv || alwaysValidCodomain (unAbs s) then yes else do- sb <- reduceB =<< inferPiSort a s+ sb <- reduceB =<< piSortM (unEl <$> a) (getSort a) s case sb of Blocked b t | neverUnblock == b -> no sb t+ | otherwise -> postpone b NotBlocked _ t@FunSort{} -> no sb t NotBlocked _ t@PiSort{} -> no sb t- _ -> yes+ NotBlocked{} -> yes where -- Do we end in a standard sort (Prop, Type, SSet)? alwaysValidCodomain = \case Inf{} -> True Univ{} -> True FunSort _ s -> alwaysValidCodomain s- PiSort _ _ s -> alwaysValidCodomain $ unAbs s+ PiSort _ _ _ s -> alwaysValidCodomain $ unAbs s _ -> False yes = do@@ -161,18 +138,19 @@ no sb t = do reportSDoc "tc.conv.sort" 35 $ "hasPTSRule fails on" <+> prettyTCM sb typeError $ InvalidTypeSort t+ postpone b = addConstraint b $ HasPTSRule a s -- | Recursively check that an iterated function type constructed by @telePi@ -- is well-sorted.-checkTelePiSort :: Type -> TCM ()--- Jesper, 2019-07-27: This is currently doing nothing (see comment in inferPiSort)-checkTelePiSort (El s (Pi a b)) = do- -- Since the function type is assumed to be constructed by @telePi@,- -- we already know that @s == piSort (getSort a) (getSort <$> b)@,- -- so we just check that this sort is well-formed.- hasPTSRule a (getSort <$> b)- underAbstraction a b checkTelePiSort-checkTelePiSort _ = return ()+checkTelePiSort :: Telescope -> Sort -> TCM ()+checkTelePiSort tel s = void $ loop tel+ where+ loop :: Telescope -> TCM Sort+ loop EmptyTel = return s+ loop (ExtendTel a atel) = do+ s' <- mapAbstraction a loop atel+ hasPTSRule a s'+ piSortM (unEl <$> a) (getSort $ unDom a) s' ifIsSort :: (MonadReduce m, MonadBlock m) => Type -> (Sort -> m a) -> m a -> m a ifIsSort t yes no = do@@ -201,20 +179,19 @@ -- -- Precondition: given term is a well-sorted type. sortOf- :: forall m. (PureTCM m, MonadBlock m, MonadConstraint m)+ :: forall m. (PureTCM m, MonadConstraint m) => Term -> m Sort sortOf t = do reportSDoc "tc.sort" 60 $ "sortOf" <+> prettyTCM t- sortOfT =<< elimView EvenLone t+ sortOfT =<< elimView LoneProjectionLikeToLambda t where sortOfT :: Term -> m Sort sortOfT = \case Pi adom b -> do- let a = unEl $ unDom adom- sa <- sortOf a+ sa <- sortOf $ unEl $ unDom adom sb <- mapAbstraction adom (sortOf . unEl) b- inferPiSort (adom $> El sa a) sb+ piSortM (unEl <$> adom) sa sb Sort s -> return $ univSort s Var i es -> do a <- typeOfBV i@@ -230,7 +207,7 @@ Lit{} -> __IMPOSSIBLE__ Level{} -> __IMPOSSIBLE__ DontCare{} -> __IMPOSSIBLE__- Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s+ Dummy s _ -> __IMPOSSIBLE_VERBOSE__ (show s) sortOfE :: Type -> (Elims -> Term) -> Elims -> m Sort sortOfE a hd [] = ifIsSort a return __IMPOSSIBLE__@@ -250,7 +227,7 @@ Blocked m _ -> patternViolation m -- Not IMPOSSIBLE because of possible non-confluent rewriting (see #5531)- _ -> ifM (optRewriting <$> pragmaOptions)+ _ -> ifM anyRewritingOption {-then-} (patternViolation neverUnblock) {-else-} __IMPOSSIBLE__ @@ -273,6 +250,6 @@ {-# INLINE sortOfType #-} -- | Reconstruct the minimal sort of a type (ignoring the sort annotation). sortOfType- :: forall m. (PureTCM m, MonadBlock m,MonadConstraint m)+ :: forall m. (PureTCM m, MonadConstraint m) => Type -> m Sort sortOfType = sortOf . unEl
src/full/Agda/TypeChecking/Substitute.hs view
@@ -1,10 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeApplications #-}- {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -ddump-simpl -dsuppress-all -ddump-to-file #-}- -- | This module contains the definition of hereditary substitution -- and application operating on internal syntax which is in β-normal -- form (β including projection reductions).@@ -19,7 +16,7 @@ , Substitution'(..), Substitution ) where -import Control.Arrow (first, second)+import Prelude hiding ( zip, zipWith ) import Data.Coerce import Data.Function (on)@@ -32,12 +29,14 @@ import Debug.Trace (trace) import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty import Agda.Syntax.Position import Agda.Syntax.Internal import Agda.Syntax.Internal.Pattern import qualified Agda.Syntax.Abstract as A import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Options import Agda.TypeChecking.Free as Free import Agda.TypeChecking.CompiledClause import Agda.TypeChecking.Positivity.Occurrence as Occ@@ -47,33 +46,36 @@ import Agda.Utils.Either import Agda.Utils.Empty-import Agda.Utils.Function (applyWhen)+import Agda.Utils.Function (applyWhen, applyUnless, ($$!)) import Agda.Utils.Functor+import Agda.Utils.Impossible import Agda.Utils.List import Agda.Utils.List1 (List1, pattern (:|)) import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.ListInf as ListInf import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Monad import Agda.Utils.Permutation-import Agda.Syntax.Common.Pretty+import Agda.Utils.Singleton import Agda.Utils.Size import Agda.Utils.Tuple--import Agda.Utils.Impossible+import Agda.Utils.VarSet (VarSet)+import qualified Agda.Utils.VarSet as VarSet+import Agda.Utils.Zip +{-# INLINE applyTermE #-} -- | Apply @Elims@ while using the given function to report ill-typed -- redexes. -- Recursive calls for @applyE@ and @applySubst@ happen at type @t@ to -- propagate the same strategy to subtrees.-{-# SPECIALIZE applyTermE :: (Empty -> Term -> Elims -> Term) -> Term -> Elims -> Term #-}-{-# SPECIALIZE applyTermE :: (Empty -> Term -> Elims -> Term) -> BraveTerm -> Elims -> BraveTerm #-} applyTermE :: forall t. (Coercible Term t, Apply t, EndoSubst t) => (Empty -> Term -> Elims -> Term) -> t -> Elims -> t-applyTermE err' m [] = m-applyTermE err' m es = coerce $+applyTermE err' = \m es -> case es of+ [] -> m+ es -> coerce $ case coerce m of- Var i es' -> Var i (es' ++ es)+ Var i es' -> Var i $! es' ++! es Def f es' -> defApp f es' es -- remove projection redexes Con c ci args -> conApp @t err' c ci args es Lam _ b ->@@ -81,15 +83,16 @@ 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__- MetaV x es' -> MetaV x (es' ++ es)+ MetaV x es' -> MetaV x $! es' ++! es Lit{} -> err __IMPOSSIBLE__ Level{} -> err __IMPOSSIBLE__ Pi _ _ -> err __IMPOSSIBLE__ Sort s -> Sort $ s `applyE` es- Dummy s es' -> Dummy s (es' ++ es)+ Dummy s es' -> Dummy s $! es' ++! es DontCare mv -> dontCare $ mv `app` es -- Andreas, 2011-10-02 -- need to go under DontCare, since "with" might resurrect irrelevant term where+ {-# INLINE app #-} app :: Coercible t a => a -> Elims -> Term app u es = coerce $ (coerce u :: t) `applyE` es err e = err' e (coerce m) es@@ -98,8 +101,9 @@ applyE = applyTermE absurd instance Apply BraveTerm where- applyE = applyTermE (\ _ t es -> Dummy "applyE" (Apply (defaultArg t) : es))+ applyE = applyTermE (\ _ t es -> Dummy (DummyBrave t) es) +{-# INLINE canProject #-} -- | If @v@ is a record or constructed value, @canProject f v@ -- returns its field @f@. canProject :: QName -> Term -> Maybe (Arg Term)@@ -107,43 +111,80 @@ case v of -- 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- -- Andreas, 2018-06-12, issue #2170- -- The ArgInfo from the ConHead is more accurate (relevance subtyping!).- setArgInfo (getArgInfo fld) <.> isApplyElim =<< listToMaybe (drop i vs)+ (Con (ConHead _ _ _ _ fs) _ vs) ->+ findWithIndex' ((f ==) . unArg) fs Nothing \fld i -> do+ -- Jesper, 2019-10-17: dont unfold irrelevant projections+ guard $ not $ isIrrelevant fld+ -- Andreas, 2018-06-12, issue #2170+ -- The ArgInfo from the ConHead is more accurate (relevance subtyping!).+ setArgInfo (getArgInfo fld) <.> isApplyElim =<< listToMaybe (drop i vs) _ -> Nothing +{-# INLINE conApp #-} -- | Eliminate a constructed term.-conApp :: forall t. (Coercible t Term, Apply t) => (Empty -> Term -> Elims -> Term) -> ConHead -> ConInfo -> Elims -> Elims -> Term-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 :: forall t. (Coercible t Term, Apply t)+ => (Empty -> Term -> Elims -> Term) -> ConHead -> ConInfo -> Elims -> Elims -> Term+conApp fallback ch@(ConHead c _ _ _ fs) ci args topEs = go topEs where++ -- print a message when we can't project "f" field+ {-# INLINE traceProjFailure #-}+ traceProjFailure :: forall a. QName -> a -> a+ traceProjFailure f err = go c f fs args topEs err where+ {-# NOINLINE go #-} -- Noinline because we don't want GHC to lift thunks out from the definition.+ -- And we abstract over all free vars because we don't want GHC to make a closure+ -- for go.+ go c f fs args es err =+ let argsBeforeProj = takeWhile' (\case Proj{} -> False; _ -> True) (args ++! es)+ in trace (concat [ "conApp: constructor ", prettyShow c- , unlines $ " with fields" : map ((" " ++) . prettyShow) fs- , unlines $ " and args" : map ((" " ++) . prettyShow) args+ , unlines $ " with fields" : map' ((" " ++!) . prettyShow) fs+ , unlines $ " and args" : map' ((" " ++!) . prettyShow) argsBeforeProj , " projected by ", prettyShow f- ]- isApply e = fromMaybe (failure __IMPOSSIBLE__) $ isApplyElim e- 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- in- case findWithIndex ((f ==) . unArg) fs of- Nothing -> failure $ stuck __IMPOSSIBLE__ `app` es- Just (fld, i) -> let- -- Andreas, 2018-06-12, issue #2170- -- We safe-guard the projected value by DontCare using the ArgInfo stored at the record constructor,- -- since the ArgInfo in the constructor application might be inaccurate because of subtyping.- v = maybe (failure $ stuck __IMPOSSIBLE__) (relToDontCare fld . argToDontCare . isApply) $ listToMaybe $ drop i args- in v `app` es+ ]) err + stuck :: Empty -> Term+ stuck err = fallback err (Con ch ci args) topEs++ go :: Elims -> Term+ go = \case+ [] -> Con ch ci $! args ++! topEs+ Apply{} : es -> go es+ IApply{} : es -> go es+ Proj o f : es -> lookupProj fs args where++ fieldNotFound :: Term+ fieldNotFound = traceProjFailure f $ stuck __IMPOSSIBLE__++ -- attempt to return a projected term+ project :: Arg QName -> Arg Term -> Term+ project fld a =+ -- Andreas, 2018-06-12, issue #2170+ -- We safe-guard the projected value by DontCare using the ArgInfo stored at the record constructor,+ -- since the ArgInfo in the constructor application might be inaccurate because of subtyping.+ let !v = relToDontCare fld (argToDontCare a) in coerce (applyE (coerce v :: t) es)++ -- try to look up the projection+ lookupProj :: [Arg QName] -> Elims -> Term+ lookupProj (fld:fs) (a:args)+ | f == unArg fld = case a of+ Proj{} -> traceProjFailure f __IMPOSSIBLE__ -- Con args never contains Proj+ Apply a -> project fld a+ IApply _ _ a -> project fld (defaultArg a)+ | otherwise = lookupProj fs args+ lookupProj fs [] = lookupFromElims fs topEs -- field is not in the constructor args+ lookupProj [] _ = fieldNotFound++ -- try to look up the projection from the newly supplied Elims+ lookupFromElims :: [Arg QName] -> Elims -> Term+ lookupFromElims (fld:fs) (a:es)+ | f == unArg fld = case a of+ Proj{} -> fieldNotFound -- this happens when we project an under-applied constructor,+ -- so the projection is at the index where the field should be+ Apply a -> project fld a+ IApply _ _ a -> project fld (defaultArg a)+ | otherwise = lookupFromElims fs es+ lookupFromElims _ _ = fieldNotFound+ -- -- Andreas, 2016-07-20 futile attempt to magically fix ProjOrigin -- fallback = v -- in if not $ null es then applyE v es else@@ -179,7 +220,7 @@ defApp :: QName -> Elims -> Elims -> Term defApp f [] (Apply a : es) | Just v <- canProject f (unArg a) = argToDontCare v `applyE` es-defApp f es0 es = Def f $ es0 ++ es+defApp f es0 es = Def f $! es0 ++! es -- protect irrelevant fields (see issue 610) argToDontCare :: Arg Term -> Term@@ -216,8 +257,8 @@ instance Apply Sort where applyE s [] = s applyE s es = case s of- MetaS x es' -> MetaS x $ es' ++ es- DefS d es' -> DefS d $ es' ++ es+ MetaS x es' -> MetaS x $! es' ++! es+ DefS d es' -> DefS d $! es' ++! es _ -> __IMPOSSIBLE__ -- @applyE@ does not make sense for telecopes, definitions, clauses etc.@@ -227,44 +268,44 @@ apply EmptyTel _ = __IMPOSSIBLE__ apply (ExtendTel _ tel) (t : ts) = lazyAbsApp tel (unArg t) `apply` ts - applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ applyE t es = apply t $ mustAllApplyElims es instance Apply Definition where- apply (Defn info x t pol occ gpars df m c inst copy ma nc inj copat blk lang d) args =- Defn info x (piApply t args) (apply pol args) (apply occ args) (drop (length args) gpars) df m c inst copy ma nc inj copat blk lang (apply d args)+ apply (Defn info x t pol occ gpars df m c inst copy ma nc inj copat blk lang hasm d) args =+ Defn info x (piApply t args) (apply pol args) (apply occ args) (drop (length args) gpars)+ df m c inst copy ma nc inj copat blk lang hasm (apply d args) - applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ applyE t es = apply t $ mustAllApplyElims es -instance Apply RewriteRule where+instance Apply GlobalRewriteRule where apply r args =- let newContext = apply (rewContext r) args- sub = liftS (size newContext) $ parallelS $- reverse $ map (PTerm . unArg) args- in RewriteRule- { rewName = rewName r- , rewContext = newContext- , rewHead = rewHead r- , rewPats = applySubst sub (rewPats r)- , rewRHS = applyNLPatSubst sub (rewRHS r)- , rewType = applyNLPatSubst sub (rewType r)- , rewFromClause = rewFromClause r- , rewTopModule = rewTopModule r+ let newContext = apply (grContext r) args+ sub = liftS (size newContext) $ parallelS $ reverse $ map' (PTerm . unArg) args+ in GlobalRewriteRule+ { grName = grName r+ , grContext = newContext+ , grHead = grHead r+ , grPats = applySubst sub (grPats r)+ , grRHS = applyNLPatSubst sub (grRHS r)+ , grType = applyNLPatSubst sub (grType r)+ , grFromClause = grFromClause r+ , grTopModule = grTopModule r } - applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ applyE t es = apply t $ mustAllApplyElims es instance {-# OVERLAPPING #-} Apply [Occ.Occurrence] where apply occ args = List.drop (length args) occ- applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ applyE t es = apply t $ mustAllApplyElims es instance {-# OVERLAPPING #-} Apply [Polarity] where apply pol args = List.drop (length args) pol- applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ applyE t es = apply t $ mustAllApplyElims es instance Apply NumGeneralizableArgs where apply NoGeneralizableArgs args = NoGeneralizableArgs apply (SomeGeneralizableArgs n) args = SomeGeneralizableArgs (n - length args)- applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ applyE t es = apply t $ mustAllApplyElims es -- | Make sure we only drop variable patterns. instance {-# OVERLAPPING #-} Apply [NamedArg (Pattern' a)] where@@ -283,24 +324,24 @@ ProjP{} -> __IMPOSSIBLE__ IApplyP{} -> recurse - applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ applyE t es = apply t $ mustAllApplyElims es instance Apply Projection where apply p args = p { projIndex = projIndex p - size args , projLams = projLams p `apply` args }- applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ applyE t es = apply t $ mustAllApplyElims es instance Apply ProjLams where apply (ProjLams lams) args = ProjLams $ List.drop (length args) lams- applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ applyE t es = apply t $ mustAllApplyElims es instance Apply Defn where apply d [] = d- apply d args@(arg1:args1) = case d of+ apply d args = case d of Axiom{} -> d- DataOrRecSig n -> DataOrRecSig (n - length args)+ DataOrRecSig n eta -> DataOrRecSig (n - length args) eta GeneralizableVar gv -> GeneralizableVar $ apply gv args AbstractDefn d -> AbstractDefn $ apply d args Function{ funClauses = cs, funCompiled = cc, funCovering = cov, funInv = inv@@ -315,34 +356,33 @@ Function{ funClauses = cs, funCompiled = cc, funCovering = cov, funInv = inv , funExtLam = extLam- , funProjection = Right p0 } ->+ , funProjection = Right p0@Projection{ projIndex = n0 } } -> 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 = Right p }- -- case: applied also to record value (n == 0)+ -- case: applied also to record value (and possibly more) | otherwise -> d { funClauses = apply cs args' , funCompiled = apply cc args' , funCovering = apply cov args' , funInv = apply inv args'- , funProjection = if isVar0 then Right p{ projIndex = 0 } else Left MaybeProjection+ , funProjection = if n == 0 && isVar0 then Right p else Left MaybeProjection , funExtLam = modifySystem (\ _ -> __IMPOSSIBLE__) <$> extLam } where- larg = last1 arg1 args1 -- the record value- args' = [larg]- isVar0 = case unArg larg of Var 0 [] -> True; _ -> False+ args' = drop n0 args+ -- if n == 0 then n0 <= length args (which is at least 1) so we can drop all but one+ isVar0 = case map'' unArg $ drop (n0 - 1) args of [Var 0 []] -> True; _ -> False - Datatype{ dataPars = np, dataClause = cl } ->+ Datatype{ dataPars = np, dataClause = v } -> d { dataPars = np - size args- , dataClause = apply cl args+ , dataClause = apply v args }- Record{ recPars = np, recClause = cl, recTel = tel+ Record{ recPars = np, recClause = v, recTel = tel {-, recArgOccurrences = occ-} } -> d { recPars = np - size args- , recClause = apply cl args, recTel = apply tel args+ , recClause = apply v args, recTel = apply tel args -- , recArgOccurrences = List.drop (length args) occ } Constructor{ conPars = np } ->@@ -351,14 +391,14 @@ d { primClauses = apply cs args } PrimitiveSort{} -> d - applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ applyE t es = apply t $ mustAllApplyElims es instance Apply PrimFun where apply (PrimFun x ar occs def) args =- PrimFun x (ar - n) (drop n occs) $ \ vs -> def (args ++ vs)+ PrimFun x (ar - n) (drop n occs) $ \ vs -> def $! args ++! vs where n = size args- applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ applyE t es = apply t $ mustAllApplyElims es instance Apply Clause where -- This one is a little bit tricksy after the parameter refinement change.@@ -382,8 +422,8 @@ -- We have -- Γ ⊢ args, for some outer context Γ -- Δ ⊢ ps, where Δ is the clause telescope (tel)- rargs = map unArg $ reverse args- rps = reverse $ take (length args) ps+ rargs = map'' unArg $ reverse args+ rps = reverse $ take' (length args) ps n = size tel -- This is the new telescope. Created by substituting the args into the@@ -418,7 +458,7 @@ VarP _ (DBPatVar _ i) -> mkSub tm (n - 1) (substP i v' ps) vs `composeS` singletonS i (tm v') where v' = raise (n - 1) v DotP{} -> mkSub tm n ps vs- ConP c _ ps' -> mkSub tm n (ps' ++ ps) (projections c v ++ vs)+ ConP c _ ps' -> (mkSub tm n $! (ps' ++! ps)) $! (projections c v ++! vs) DefP{} -> __IMPOSSIBLE__ LitP{} -> __IMPOSSIBLE__ ProjP{} -> __IMPOSSIBLE__@@ -441,7 +481,7 @@ case namedArg p of VarP _ (DBPatVar _ i) -> newTel (n - 1) (subTel (size tel - 1 - i) v tel) (substP i (raise (n - 1) v) ps) vs DotP{} -> newTel n tel ps vs- ConP c _ ps' -> newTel n tel (ps' ++ ps) (projections c v ++ vs)+ ConP c _ ps' -> (newTel n tel $! ps' ++! ps) $! (projections c v ++! vs) DefP{} -> __IMPOSSIBLE__ LitP{} -> __IMPOSSIBLE__ ProjP{} -> __IMPOSSIBLE__@@ -469,33 +509,33 @@ subTel 0 v (ExtendTel _ tel) = absApp tel v subTel i v (ExtendTel a tel) = ExtendTel a $ subTel (i - 1) (raise 1 v) <$> tel - applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ applyE t es = apply t $ mustAllApplyElims es instance Apply CompiledClauses where apply cc args = case cc of Fail hs -> Fail (drop len hs)- Done hs t+ Done no mr hs t | length hs >= len ->- let sub = parallelS $ map var [0..length hs - len - 1] ++ map unArg args- in Done (List.drop len hs) $ applySubst sub t+ let sub = parallelS $! (map' var [0..length hs - len - 1]) ++! (map'' unArg args)+ in Done no mr (List.drop len hs) $ applySubst sub t | otherwise -> __IMPOSSIBLE__ Case n bs | unArg n >= len -> Case (n <&> \ m -> m - len) (apply bs args) | otherwise -> __IMPOSSIBLE__ where len = length args- applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ applyE t es = apply t $ mustAllApplyElims es instance Apply ExtLamInfo where apply (ExtLamInfo m b sys) args = ExtLamInfo m b (apply sys args)- applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ applyE t es = apply t $ mustAllApplyElims es instance Apply System where -- We assume we apply a system only to arguments introduced by -- lambda lifting. apply (System tel sys) args = if nargs > ntel then __IMPOSSIBLE__- else System newTel (map (map (f -*- id) -*- f) sys)+ else System newTel (map'' (map'' (f *** id) *** f) sys) where f = applySubst sigma@@ -503,9 +543,9 @@ ntel = size tel newTel = apply tel args -- newTel ⊢ σ : tel- sigma = liftS (ntel - nargs) (parallelS (reverse $ map unArg args))+ sigma = liftS (ntel - nargs) (parallelS (reverse $ map'' unArg args)) - applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ applyE t es = apply t $ mustAllApplyElims es instance Apply a => Apply (WithArity a) where apply (WithArity n a) args = WithArity n $ apply a args@@ -521,25 +561,25 @@ apply NotInjective args = NotInjective apply (Inverse inv) args = Inverse $ apply inv args - applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ applyE t es = apply t $ mustAllApplyElims es instance Apply DisplayTerm where- apply (DTerm' v es) args = DTerm' v $ es ++ map Apply args- apply (DDot' v es) args = DDot' v $ es ++ map Apply args- apply (DCon c ci vs) args = DCon c ci $ vs ++ map (fmap DTerm) args- apply (DDef c es) args = DDef c $ es ++ map (Apply . fmap DTerm) args- apply (DWithApp v ws es) args = DWithApp v ws $ es ++ map Apply args+ apply (DTerm' v es) args = DTerm' v $! es ++! (map' Apply args)+ apply (DDot' v es) args = DDot' v $! es ++! (map' Apply args)+ apply (DCon c ci vs) args = DCon c ci $! vs ++! (map' (fmap DTerm) args)+ apply (DDef c es) args = DDef c $! es ++! (map' (Apply . fmap DTerm) args)+ apply (DWithApp v ws es) args = DWithApp v ws $! es ++! (map' Apply args) - applyE (DTerm' v es') es = DTerm' v $ es' ++ es- applyE (DDot' v es') es = DDot' v $ es' ++ es- applyE (DCon c ci vs) es = DCon c ci $ vs ++ map (fmap DTerm) ws- where ws = fromMaybe __IMPOSSIBLE__ $ allApplyElims es- applyE (DDef c es') es = DDef c $ es' ++ map (fmap DTerm) es- applyE (DWithApp v ws es') es = DWithApp v ws $ es' ++ es+ applyE (DTerm' v es') es = DTerm' v $! es' ++! es+ applyE (DDot' v es') es = DDot' v $! es' ++! es+ applyE (DCon c ci vs) es = DCon c ci $! vs ++! map' (fmap DTerm) ws+ where ws = mustAllApplyElims es+ applyE (DDef c es') es = DDef c $! es' ++! map' (fmap DTerm) es+ applyE (DWithApp v ws es') es = DWithApp v ws $! es' ++! es instance {-# OVERLAPPABLE #-} Apply t => Apply [t] where- apply ts args = map (`apply` args) ts- applyE ts es = map (`applyE` es) ts+ apply ts args = map'' (`apply` args) ts+ applyE ts es = map'' (`applyE` es) ts instance Apply t => Apply (Blocked t) where apply b args = fmap (`apply` args) b@@ -571,7 +611,7 @@ instance DoDrop a => Apply (Drop a) where apply x args = dropMore (size args) x- applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ applyE t es = apply t $ mustAllApplyElims es instance DoDrop a => Abstract (Drop a) where abstract tel x = unDrop (size tel) x@@ -579,14 +619,14 @@ instance Apply Permutation where -- The permutation must start with [0..m - 1] -- NB: section (- m) not possible (unary minus), hence (flip (-) m)- apply (Perm n xs) args = Perm (n - m) $ map (flip (-) m) $ drop m xs+ apply (Perm n xs) args = Perm (n - m) $! map' (flip (-) m) $ drop m xs where m = size args - applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ applyE t es = apply t $ mustAllApplyElims es instance Abstract Permutation where- abstract tel (Perm n xs) = Perm (n + m) $ [0..m - 1] ++ map (+ m) xs+ abstract tel (Perm n xs) = Perm (n + m) $! [0..m - 1] ++! (map' (+ m) xs) where m = size tel @@ -600,7 +640,7 @@ piApply t [] = t piApply (El _ (Pi _ b)) (a:args) = lazyAbsApp b (unArg a) `piApply` args piApply t args =- trace ("piApply t = " ++ prettyShow t ++ "\n args = " ++ prettyShow args) __IMPOSSIBLE__+ trace ("piApply t = " ++! prettyShow t ++! "\n args = " ++! prettyShow args) __IMPOSSIBLE__ --------------------------------------------------------------------------- -- * Abstraction@@ -621,25 +661,25 @@ ExtendTel arg xtel `abstract` tel = ExtendTel arg $ xtel <&> (`abstract` tel) instance Abstract Definition where- abstract tel (Defn info x t pol occ gpars df m c inst copy ma nc inj copat blk lang d) =+ abstract tel (Defn info x t pol occ gpars df m c inst copy ma nc inj copat blk lang hasm d) = Defn info x (abstract tel t) (abstract tel pol) (abstract tel occ)- (replicate (size tel) Nothing ++ gpars)- df m c inst copy ma nc inj copat blk lang (abstract tel d)+ (replicate' (size tel) Nothing ++! gpars)+ df m c inst copy ma nc inj copat blk lang hasm (abstract tel d) -- | @tel ⊢ (Γ ⊢ lhs ↦ rhs : t)@ becomes @tel, Γ ⊢ lhs ↦ rhs : t)@ -- we do not need to change lhs, rhs, and t since they live in Γ. -- See 'Abstract Clause'.-instance Abstract RewriteRule where- abstract tel (RewriteRule q gamma f ps rhs t c top) =- RewriteRule q (abstract tel gamma) f ps rhs t c top+instance Abstract GlobalRewriteRule where+ abstract tel (GlobalRewriteRule q gamma f ps rhs t c top) =+ GlobalRewriteRule q (abstract tel gamma) f ps rhs t c top instance {-# OVERLAPPING #-} Abstract [Occ.Occurrence] where abstract tel [] = []- abstract tel occ = replicate (size tel) Mixed ++ occ -- TODO: check occurrence+ abstract tel occ = replicate' (size tel) Mixed ++! occ -- TODO: check occurrence instance {-# OVERLAPPING #-} Abstract [Polarity] where abstract tel [] = []- abstract tel pol = replicate (size tel) Invariant ++ pol -- TODO: check polarity+ abstract tel pol = replicate' (size tel) Invariant ++! pol -- TODO: check polarity instance Abstract NumGeneralizableArgs where abstract tel NoGeneralizableArgs = NoGeneralizableArgs@@ -652,8 +692,8 @@ } instance Abstract ProjLams where- abstract tel (ProjLams lams) = ProjLams $- map (\ !dom -> argFromDom (fst <$> dom)) (telToList tel) ++ lams+ abstract tel (ProjLams lams) = ProjLams $!+ (map' (\ !dom -> argFromDom (fst <$> dom)) (telToList tel)) ++! lams instance Abstract System where abstract tel (System tel1 sys) = System (abstract tel tel1) sys@@ -661,7 +701,7 @@ instance Abstract Defn where abstract tel d = case d of Axiom{} -> d- DataOrRecSig n -> DataOrRecSig (size tel + n)+ DataOrRecSig n eta -> DataOrRecSig (size tel + n) eta GeneralizableVar gv -> GeneralizableVar $ abstract tel gv AbstractDefn d -> AbstractDefn $ abstract tel d Function{ funClauses = cs, funCompiled = cc, funCovering = cov, funInv = inv@@ -680,11 +720,11 @@ -- then abstract over last element of tel (the others are params). if projIndex p > 0 then d { funProjection = Right $ abstract tel p- , funClauses = map (abstractClause EmptyTel) cs+ , funClauses = map' (abstractClause EmptyTel) cs } else d { funProjection = Right $ abstract tel p- , funClauses = map (abstractClause tel1) cs+ , funClauses = map' (abstractClause tel1) cs , funCompiled = abstract tel1 cc , funCovering = abstract tel1 cov , funInv = abstract tel1 inv@@ -696,13 +736,13 @@ -- projection shenanigans. abstractClause tel1 c = (abstract tel1 c) { clauseTel = abstract tel $ clauseTel c } - Datatype{ dataPars = np, dataClause = cl } ->- d { dataPars = np + size tel- , dataClause = abstract tel cl+ Datatype{ dataPars = np, dataClause = v } ->+ d { dataPars = np + size tel+ , dataClause = abstract tel v }- Record{ recPars = np, recClause = cl, recTel = tel' } ->+ Record{ recPars = np, recClause = v, recTel = tel' } -> d { recPars = np + size tel- , recClause = abstract tel cl+ , recClause = abstract tel v , recTel = abstract tel tel' } Constructor{ conPars = np } ->@@ -713,14 +753,14 @@ instance Abstract PrimFun where abstract tel (PrimFun x ar occs def) =- PrimFun x (ar + n) (replicate n Mixed ++ occs) $ \ts ->+ PrimFun x (ar + n) (replicate' n Mixed ++! occs) $ \ts -> def $ drop n ts where n = size tel instance Abstract Clause where abstract tel (Clause rl rf tel' ps b t catchall recursive unreachable ell wm) = Clause rl rf (abstract tel tel')- (namedTelVars m tel ++ ps)+ (namedTelVars m tel ++! ps) b t -- nothing to do for t, since it lives under the telescope catchall@@ -732,11 +772,11 @@ instance Abstract CompiledClauses where abstract tel cc = case cc of- Fail xs -> Fail (hs ++ xs)- Done xs t -> Done (hs ++ xs) t- Case n bs -> Case (n <&> \ i -> i + size tel) (abstract tel bs)+ Fail xs -> Fail (hs ++! xs)+ Done no mr xs t -> Done no mr (hs ++! xs) t+ Case n bs -> Case (n <&> \ i -> i + size tel) (abstract tel bs) where- hs = map (argFromDom . fmap fst) $ telToList tel+ hs = map' (argFromDom . fmap fst) $ telToList tel instance Abstract a => Abstract (WithArity a) where abstract tel (WithArity n a) = WithArity n $ abstract tel a@@ -747,20 +787,21 @@ (abstract tel ls) (abstract tel m) b lz telVars :: Int -> Telescope -> [Arg DeBruijnPattern]-telVars m = map (fmap namedThing) . (namedTelVars m)+telVars m = map' (fmap namedThing) . (namedTelVars m) namedTelVars :: Int -> Telescope -> [NamedArg DeBruijnPattern]-namedTelVars m EmptyTel = []+namedTelVars m EmptyTel = [] namedTelVars m (ExtendTel !dom tel) =- Arg (domInfo dom) (namedDBVarP (m-1) $ absName tel) :- namedTelVars (m-1) (unAbs tel)+ let !rest = namedTelVars (m-1) (unAbs tel) in+ let !this = Arg (domInfo dom) $! (namedDBVarP (m-1) $ absName tel) in+ this : rest instance Abstract FunctionInverse where abstract tel NotInjective = NotInjective abstract tel (Inverse inv) = Inverse $ abstract tel inv instance {-# OVERLAPPABLE #-} Abstract t => Abstract [t] where- abstract tel = map (abstract tel)+ abstract tel = map'' (abstract tel) instance Abstract t => Abstract (Maybe t) where abstract tel x = fmap (abstract tel) x@@ -777,13 +818,14 @@ tel = foldr (\arg@(Arg info x) -> ExtendTel (__DUMMY_TYPE__ <$ domFromArg arg) . Abs x) EmptyTel $ zipWith (<$) names args- names = cycle $ map (stringToArgName . (:[])) ['a'..'z']+ names = ListInf.cycle $ fmap (stringToArgName . singleton) ('a' :| ['b'..'z']) --------------------------------------------------------------------------- -- * Substitution and shifting\/weakening\/strengthening --------------------------------------------------------------------------- -- | If @permute π : [a]Γ -> [a]Δ@, then @applySubst (renaming _ π) : Term Γ -> Term Δ@+-- Assumes that π works on de Bruijn _indices_. renaming :: forall a. DeBruijn a => Impossible -> Permutation -> Substitution' a renaming err p = prependS err gamma $ raiseS $ size p where@@ -792,10 +834,11 @@ -- gamma = safePermute (invertP (-1) p) $ map deBruijnVar [0..] -- | If @permute π : [a]Γ -> [a]Δ@, then @applySubst (renamingR π) : Term Δ -> Term Γ@+-- Assumes that π works on de Bruijn _levels_. renamingR :: DeBruijn a => Permutation -> Substitution' a renamingR p@(Perm n is) = xs ++# raiseS n where- xs = map (\i -> deBruijnVar (n - 1 - i)) (reverse is)+ xs = map' (\i -> deBruijnVar (n - 1 - i)) (reverse is) -- The list xs used to be defined in the following way: --@@ -815,38 +858,96 @@ -- 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)+-- | The permutation should permute the corresponding context. (as de Bruijn _indices_) renameP :: Subst a => Impossible -> Permutation -> a -> a renameP err p = applySubst (renaming err p) +-- | Polymorphic substitution+-- I.e. Substitutions which can be applied to any 'a' where+-- 'DeBruijn (SubstArg a)'+-- Used to encode not-necessarily-surjective renamings ('Permutation' is+-- always assumed to be surjective)+data AnySubstitution = AnySub+ { getSub :: forall a. DeBruijn a => Substitution' a }++-- | Attempts to convert a substitution into a renaming. Returns Nothing if+-- any of the variables in the set are mapped to non-variable terms.+-- Variables not in the set are strengthened-away.+-- Returns a polymorphic substitution.+toRenOn :: DeBruijn a => VarSet -> Substitution' a -> Maybe AnySubstitution+toRenOn vars rho = go 0 rho+ where+ go x IdS = Just $ AnySub $ IdS+ go x (EmptyS i) = Just $ AnySub $ EmptyS i+ go x (t :# rho) = do+ AnySub rho' <- go (x + 1) rho+ if x `VarSet.member` vars+ then do+ y <- deBruijnView t+ Just $ AnySub $ deBruijnVar y :# rho'+ else Just $ AnySub $ Strengthen __IMPOSSIBLE__ 1 rho'+ go x (Strengthen i n rho) = do+ AnySub rho' <- go (x + n) rho+ Just $ AnySub $ Strengthen i n rho'+ go x (Wk n rho) = do+ AnySub rho' <- go x rho+ Just $ AnySub $ Wk n rho'+ go x (Lift n rho) = do+ AnySub rho' <- go (x + n) rho+ Just $ AnySub $ Lift n rho'+ instance EndoSubst a => Subst (Substitution' a) where type SubstArg (Substitution' a) = a applySubst rho sgm = composeS rho sgm -{-# SPECIALIZE applySubstTerm :: Substitution -> Term -> Term #-}-{-# SPECIALIZE applySubstTerm :: Substitution' BraveTerm -> BraveTerm -> BraveTerm #-}+{-# INLINE applySubstTerm #-} applySubstTerm :: forall t. (Coercible t Term, EndoSubst t, Apply t) => Substitution' t -> t -> t applySubstTerm IdS t = t applySubstTerm rho t = coerce $ case coerce t of- Var i es -> coerce $ lookupS rho i `applyE` subE es- Lam h m -> Lam h $ sub @(Abs t) m- Def f es -> defApp f [] $ subE es- Con c ci vs -> Con c ci $ subE vs- MetaV x es -> MetaV x $ subE es+ Var i es -> let !t = lookupS rho i in coerce (t `applyE` subE rho es)+ Lam h m -> Lam h $! sub @(Abs t) rho m+ Def f es -> defApp f [] $! subE rho es+ Con c ci vs -> Con c ci $! subE rho vs+ MetaV x es -> MetaV x $! subE rho es Lit l -> Lit l- Level l -> levelTm $ sub @(Level' t) l- Pi a b -> uncurry Pi $ subPi (a,b)- Sort s -> Sort $ sub @(Sort' t) s- DontCare mv -> dontCare $ sub @t mv- Dummy s es -> Dummy s $ subE es+ Level l -> levelTm $ sub @(Level' t) rho l+ Pi a b -> Pi (sub @(Dom' t (Type'' t t)) rho a) (sub @(Abs (Type'' t t)) rho b)+ -- Pi a b -> Pi (subPiDom rho a) (subPiCod rho b)+ Sort s -> Sort (sub @(Sort' t) rho s)+ DontCare mv -> dontCare (sub @t rho mv)+ Dummy s es -> Dummy s $! subE rho es where- sub :: forall a b. (Coercible b a, SubstWith t a) => b -> b- sub t = coerce $ applySubst rho (coerce t :: a)- subE :: Elims -> Elims- subE = sub @[Elim' t]- subPi :: (Dom Type, Abs Type) -> (Dom Type, Abs Type)- subPi = sub @(Dom' t (Type'' t t), Abs (Type'' t t))+ sub :: forall a b. (Coercible b a, SubstWith t a) => Substitution' t -> b -> b+ sub rho t = coerce (applySubst rho (coerce t :: a)); {-# INLINE sub #-} + {- András, 2026-03-17: when substituting a term, we don't want to create any thunks until we hit the *next*+ inductive layer of terms.+ But apparently, not for Pi, currently! Forcing Pi seems to cost some checking time in stdlib.+ Below's some commented-out definitions for stricter Pi substitution.+ -}++ -- subPiDom :: Substitution' t -> Dom Type -> Dom Type+ -- subPiDom rho (Dom i n f t (El s a)) =+ -- let !i' = setFreeVariables unknownFreeVariables i in+ -- Dom i' n f $$! (sub @(Maybe t) rho t) $$! (El $$! sub @(Sort' t) rho s $$! sub @t rho a)++ -- subPiCod :: Substitution' t -> Abs Type -> Abs Type+ -- subPiCod rho (Abs x (El s a)) =+ -- let !rho' = liftS 1 rho in+ -- Abs x $$! (El $$! sub @(Sort' t) rho' s $$! sub @t rho' a)+ -- subPiCod rho (NoAbs x (El s a)) =+ -- NoAbs x $! (El $$! sub @(Sort' t) rho s $$! sub @t rho a)++ subE :: Substitution' t -> Elims -> Elims+ subE rho [] = []+ subE rho (a:as) = case a of+ Apply (Arg i t) ->+ let !i' | getFreeVariables i == unknownFreeVariables = i+ | otherwise = setFreeVariables unknownFreeVariables i+ in (Apply (Arg i' (sub @t rho t)):) $! subE rho as+ p@Proj{} -> (p :) $! subE rho as+ IApply l r t -> (IApply (sub @t rho l) (sub @t rho r) (sub @t rho t):) $! subE rho as+ instance Subst Term where type SubstArg Term = Term applySubst = applySubstTerm@@ -859,36 +960,61 @@ type SubstArg BraveTerm = BraveTerm applySubst = applySubstTerm -instance (Coercible a Term, Subst a, Subst b, SubstArg a ~ SubstArg b) => Subst (Type'' a b) where+instance (Subst a, Subst b, SubstArg a ~ SubstArg b) => Subst (Type'' a b) where type SubstArg (Type'' a b) = SubstArg a applySubst rho (El s t) = applySubst rho s `El` applySubst rho t -instance (Coercible a Term, Subst a) => Subst (Sort' a) where+instance Subst a => Subst (Sort' a) where type SubstArg (Sort' a) = SubstArg a applySubst rho = \case- Univ u n -> Univ u $ sub n- Inf u n -> Inf u n- SizeUniv -> SizeUniv- LockUniv -> LockUniv- LevelUniv -> LevelUniv- 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- MetaS x es -> MetaS x $ sub es- DefS d es -> DefS d $ sub es- s@DummyS{} -> s+ Univ u n -> Univ u $! applySubst rho n+ Inf u n -> Inf u n+ SizeUniv -> SizeUniv+ LockUniv -> LockUniv+ LevelUniv -> LevelUniv+ IntervalUniv -> IntervalUniv+ PiSort c a s1 s2 -> ((PiSort c' $! applySubst rho a) (applySubst rho s1)) $! applySubst rho s2+ where+ -- Is the substitution a thinning?+ -- (Approximation of injectivity, just for optimisation)+ isThin IdS = True+ isThin (Wk _ rho) = isThin rho+ isThin (Lift _ rho) = isThin rho+ isThin _ = False+ c' = case c of+ CodomainSortSame -> if isThin rho+ -- If the substitution is a thinning, we can keep using the current+ -- codomain sort because thinnings are injective and dependency+ -- is stable under injective substitutions+ then CodomainSortSame+ else CodomainSortOld $! unAbs s2+ CodomainSortOld{} -> c+ FunSort s1 s2 -> FunSort (applySubst rho s1) (applySubst rho s2)+ UnivSort s -> UnivSort $ applySubst rho s+ MetaS x es -> MetaS x $! subE rho es+ DefS d es -> DefS d $! subE rho es+ s@DummyS{} -> s where- sub :: forall b. (Subst b, SubstArg a ~ SubstArg b) => b -> b- sub x = applySubst rho x+ subE :: Substitution' (SubstArg a) -> [Elim' a] -> [Elim' a]+ subE rho [] = []+ subE rho (a:as) = case a of+ Apply (Arg i t) ->+ let !i' | getFreeVariables i == unknownFreeVariables = i+ | otherwise = setFreeVariables unknownFreeVariables i+ in (Apply (Arg i' (applySubst rho t)):) $! subE rho as+ p@Proj{} -> (p :) $! subE rho as+ IApply l r t -> (IApply (applySubst rho l) (applySubst rho r) (applySubst rho t):)+ $! subE rho as instance Subst a => Subst (Level' a) where type SubstArg (Level' a) = SubstArg a- applySubst rho (Max n as) = Max n $ applySubst rho as+ applySubst rho (Max n as) = Max n $! go rho as where+ go rho [] = []+ go rho (Plus x y : as) = (:) $$! (Plus x $$! applySubst rho y) $$! go rho as instance Subst a => Subst (PlusLevel' a) where type SubstArg (PlusLevel' a) = SubstArg a- applySubst rho (Plus n l) = Plus n $ applySubst rho l+ applySubst rho (Plus n l) = Plus n $! applySubst rho l instance Subst Name where type SubstArg Name = Term@@ -901,8 +1027,8 @@ instance Subst Pattern where type SubstArg Pattern = Term applySubst rho = \case- ConP c mt ps -> ConP c (applySubst rho mt) $ applySubst rho ps- DefP o q ps -> DefP o q $ applySubst rho ps+ ConP c mt ps -> ConP c (applySubst rho mt) $! applySubst rho ps+ DefP o q ps -> DefP o q $! applySubst rho ps DotP o t -> DotP o $ applySubst rho t p@(VarP _o _x) -> p p@(LitP _o _l) -> p@@ -918,24 +1044,28 @@ deBruijnVar = BraveTerm . deBruijnVar deBruijnView = deBruijnView . unBrave +-- This instance is a bit of a hack. Whether a variable ought to be mapped to+-- a PVar or a PBoundVar is dependent on context, but here we always assume+-- PVar. instance DeBruijn NLPat where- deBruijnVar i = PVar i []+ deBruijnVar i = PVar MaybeSing i [] deBruijnView = \case- PVar i [] -> Just i- PVar{} -> Nothing- PDef{} -> Nothing- PLam{} -> Nothing- PPi{} -> Nothing- PSort{} -> Nothing- PBoundVar{} -> Nothing -- or... ?- PTerm{} -> Nothing -- or... ?+ PVar s i [] -> Just i+ PVar{} -> Nothing+ PDef{} -> Nothing+ PLam{} -> Nothing+ PPi{} -> Nothing+ PSort{} -> Nothing+ PBoundVar i [] -> Just i+ PBoundVar{} -> Nothing -- or... ?+ PTerm{} -> Nothing -- or... ? applyNLPatSubst :: TermSubst a => Substitution' NLPat -> a -> a applyNLPatSubst = applySubst . fmap nlPatToTerm where nlPatToTerm :: NLPat -> Term nlPatToTerm = \case- PVar i xs -> Var i $ map (Apply . fmap var) xs+ PVar s i xs -> Var i $ map (Apply . fmap var) xs PTerm u -> u PDef f es -> __IMPOSSIBLE__ PLam i u -> __IMPOSSIBLE__@@ -944,24 +1074,31 @@ PBoundVar i es -> __IMPOSSIBLE__ applyNLSubstToDom :: SubstWith NLPat a => Substitution' NLPat -> Dom a -> Dom a-applyNLSubstToDom rho dom = applySubst rho <$> dom{ domTactic = applyNLPatSubst rho $ domTactic dom }+applyNLSubstToDom rho dom =+ applySubst rho <$> (dom & dTactic %~ applyNLPatSubst rho) +-- Assume substitution maps the given variable to a variable+lookupSVar :: EndoSubst a => Substitution' a -> Nat -> Maybe Nat+lookupSVar sub x = deBruijnView $ lookupS sub x+ instance Subst NLPat where type SubstArg NLPat = NLPat applySubst rho = \case- PVar i bvs -> lookupS rho i `applyBV` bvs- PDef f es -> PDef f $ applySubst rho es+ PVar s i bvs -> lookupS rho i `applyBV` bvs+ PDef f es -> PDef f $! applySubst rho es PLam i u -> PLam i $ applySubst rho u PPi a b -> PPi (applyNLSubstToDom rho a) (applySubst rho b) PSort s -> PSort $ applySubst rho s- PBoundVar i es -> PBoundVar i $ applySubst rho es+ -- Bound variables should only ever be substituted for other bound+ -- variables+ PBoundVar i es -> PBoundVar (fromMaybe __IMPOSSIBLE__ $ lookupSVar rho i) $! applySubst rho es PTerm u -> PTerm $ applyNLPatSubst rho u where applyBV :: NLPat -> [Arg Int] -> NLPat applyBV p ys = case p of- PVar i xs -> PVar i (xs ++ ys)- PTerm u -> PTerm $ u `apply` map (fmap var) ys+ PVar s i xs -> PVar s i $! xs ++! ys+ PTerm u -> PTerm $ u `apply` map' (fmap var) ys PDef f es -> __IMPOSSIBLE__ PLam i u -> __IMPOSSIBLE__ PPi a b -> __IMPOSSIBLE__@@ -982,16 +1119,53 @@ PLevelUniv -> PLevelUniv PIntervalUniv -> PIntervalUniv -instance Subst RewriteRule where- type SubstArg RewriteRule = NLPat- applySubst rho (RewriteRule q gamma f ps rhs t c top) =- RewriteRule q (applyNLPatSubst rho gamma)+instance Subst GlobalRewriteRule where+ type SubstArg GlobalRewriteRule = NLPat+ applySubst rho (GlobalRewriteRule q gamma f ps rhs t c top) =+ GlobalRewriteRule q (applyNLPatSubst rho gamma) f (applySubst (liftS n rho) ps) (applyNLPatSubst (liftS n rho) rhs) (applyNLPatSubst (liftS n rho) t) c top where n = size gamma +instance Subst a => Subst (LocalEquation' a) where+ type SubstArg (LocalEquation' a) = SubstArg a+ applySubst rho (LocalEquation gamma lhs rhs t) =+ LocalEquation (applySubst rho gamma)+ (applySubst rho' lhs)+ (applySubst rho' rhs)+ (applySubst rho' t)+ where rho' = liftS (size gamma) rho++instance Subst RewriteHead where+ type SubstArg RewriteHead = Term+ applySubst rho (RewDefHead f) = RewDefHead f+ applySubst rho (RewVarHead x) = RewVarHead $ fromMaybe __IMPOSSIBLE__ $+ deBruijnView $ lookupS rho x++-- | Substitution on local rewrite rules is partial.+applySubstLocalRewrite :: DeBruijn a+ => Substitution' a -> RewriteRule -> Maybe RewriteRule+applySubstLocalRewrite rho rew@(RewriteRule gamma f ps rhs b) =+ case toRenOn (freeVarSet rew) rho of+ Just (AnySub rho') -> do+ let rho'' :: DeBruijn a => Substitution' a+ rho'' = liftS (size gamma) rho'++ Just $ RewriteRule (applySubst rho' gamma)+ (applySubst rho' f)+ (applySubst rho'' ps)+ (applySubst rho'' rhs)+ (applySubst rho'' b)+ Nothing -> Nothing++instance Subst a => Subst (RewDom' a) where+ type SubstArg (RewDom' a) = SubstArg a+ applySubst rho (RewDom eq rew) =+ RewDom (applySubst rho eq)+ (applySubstLocalRewrite rho =<< rew)+ instance Subst a => Subst (Blocked a) where type SubstArg (Blocked a) = SubstArg a applySubst rho b = fmap (applySubst rho) b@@ -999,21 +1173,23 @@ instance Subst DisplayForm where type SubstArg DisplayForm = Term applySubst rho (Display n ps v) =- Display n (applySubst (liftS n rho) ps)- (applySubst (liftS n rho) v)+ let rho' = liftS n rho+ !ps' = applySubst rho' ps in+ Display n ps' (applySubst rho' v) + instance Subst DisplayTerm where type SubstArg DisplayTerm = Term- applySubst rho (DTerm' v es) = DTerm' (applySubst rho v) $ applySubst rho es- applySubst rho (DDot' v es) = DDot' (applySubst rho v) $ applySubst rho es- applySubst rho (DCon c ci vs) = DCon c ci $ applySubst rho vs- applySubst rho (DDef c es) = DDef c $ applySubst rho es+ applySubst rho (DTerm' v es) = DTerm' (applySubst rho v) $! applySubst rho es+ applySubst rho (DDot' v es) = DDot' (applySubst rho v) $! applySubst rho es+ applySubst rho (DCon c ci vs) = DCon c ci $! applySubst rho vs+ applySubst rho (DDef c es) = DDef c $! applySubst rho es applySubst rho (DWithApp v vs es) = uncurry3 DWithApp $ applySubst rho (v, vs, es) instance Subst a => Subst (Tele a) where type SubstArg (Tele a) = SubstArg a applySubst rho EmptyTel = EmptyTel- applySubst rho (ExtendTel t tel) = uncurry ExtendTel $ applySubst rho (t, tel)+ applySubst rho (ExtendTel t tel) = ExtendTel (applySubst rho t) $! applySubst rho tel instance Subst Constraint where type SubstArg Constraint = Term@@ -1027,7 +1203,7 @@ IsEmpty r a -> IsEmpty r (rf a) CheckSizeLtSat t -> CheckSizeLtSat (rf t) FindInstance r m cands -> FindInstance r m (rf cands)- ResolveInstanceHead q -> ResolveInstanceHead (rf q)+ ResolveInstanceHead kwr q -> ResolveInstanceHead kwr (rf q) c@UnBlock{} -> c c@CheckFunDef{} -> c HasBiggerSort s -> HasBiggerSort (rf s)@@ -1038,7 +1214,9 @@ CheckMetaInst m -> CheckMetaInst m CheckType t -> CheckType (rf t) UsableAtModality cc ms mod m -> UsableAtModality cc (rf ms) mod (rf m)+ RewConstraint e -> RewConstraint (rf e) where+ {-# INLINE rf #-} rf :: forall a. TermSubst a => a -> a rf x = applySubst rho x @@ -1051,35 +1229,45 @@ instance Subst a => Subst (Elim' a) where type SubstArg (Elim' a) = SubstArg a applySubst rho = \case- Apply v -> Apply $ applySubst rho v+ Apply v -> Apply (applySubst rho v) IApply x y r -> IApply (applySubst rho x) (applySubst rho y) (applySubst rho r) e@Proj{} -> e instance Subst a => Subst (Abs a) where type SubstArg (Abs a) = SubstArg a- applySubst rho (Abs x a) = Abs x $ applySubst (liftS 1 rho) a- applySubst rho (NoAbs x a) = NoAbs x $ applySubst rho a+ applySubst rho (Abs x a) = Abs x (applySubst (liftS 1 rho) a)+ applySubst rho (NoAbs x a) = NoAbs x (applySubst rho a) instance Subst a => Subst (Arg a) where+ {-# INLINE applySubst #-} type SubstArg (Arg a) = SubstArg a- applySubst IdS arg = arg- applySubst rho arg = setFreeVariables unknownFreeVariables $ fmap (applySubst rho) arg+ applySubst IdS arg = arg+ applySubst rho (Arg i t) =+ let !i' | getFreeVariables i == unknownFreeVariables = i+ | otherwise = setFreeVariables unknownFreeVariables i+ in Arg i' $$! applySubst rho t instance Subst a => Subst (Named name a) where type SubstArg (Named name a) = SubstArg a+ {-# INLINE applySubst #-} applySubst rho = fmap (applySubst rho) instance (Subst a, Subst b, SubstArg a ~ SubstArg b) => Subst (Dom' a b) where type SubstArg (Dom' a b) = SubstArg a + {-# INLINE applySubst #-} applySubst IdS dom = dom- applySubst rho dom = setFreeVariables unknownFreeVariables $- fmap (applySubst rho) dom{ domTactic = applySubst rho (domTactic dom) }- {-# INLINABLE applySubst #-}+ applySubst rho (Dom' inf@(DomInfo i n f t rw) e) =+ let i' | getFreeVariables i == unknownFreeVariables = i+ | otherwise = setFreeVariables unknownFreeVariables i in+ let inf' | Nothing <- t, Nothing <- rw = inf+ | otherwise = DomInfo i' n f (applySubst rho t) (applySubst rho rw) in+ Dom' inf' $$! applySubst rho e+ -- Dom i' n f $$! applySubst rho t $$! applySubst rho rw $$! applySubst rho e instance Subst LetBinding where type SubstArg LetBinding = Term- applySubst rho (LetBinding o v t) = LetBinding o (applySubst rho v) (applySubst rho t)+ applySubst rho (LetBinding isAxiom o v t) = LetBinding isAxiom o (applySubst rho v) (applySubst rho t) instance Subst ContextEntry where type SubstArg ContextEntry = Term@@ -1087,12 +1275,16 @@ instance Subst a => Subst (Maybe a) where type SubstArg (Maybe a) = SubstArg a+ applySubst rho ma = applySubst rho <$!> ma instance Subst a => Subst [a] where type SubstArg [a] = SubstArg a+ applySubst rho [] = []+ applySubst rho (a:as) = let !as' = applySubst rho as in applySubst rho a : as' instance Subst a => Subst (List1 a) where type SubstArg (List1 a) = SubstArg a+ applySubst rho (a :| as) = let !as' = applySubst rho as in applySubst rho a :| as' instance (Ord k, Subst a) => Subst (Map k a) where type SubstArg (Map k a) = SubstArg a@@ -1109,6 +1301,7 @@ instance (Subst a, Subst b, SubstArg a ~ SubstArg b) => Subst (a, b) where type SubstArg (a, b) = SubstArg a+ {-# INLINE applySubst #-} applySubst rho (x,y) = (applySubst rho x, applySubst rho y) instance (Subst a, Subst b, Subst c, SubstArg a ~ SubstArg b, SubstArg b ~ SubstArg c) => Subst (a, b, c) where@@ -1171,10 +1364,10 @@ Just _ -> case p of (VarP _ x) -> VarP i x (DotP _ u) -> DotP i u- (ConP c (ConPatternInfo _ r ft b l) ps)- -> ConP c (ConPatternInfo i r ft b l) ps+ (ConP c (ConPatternInfo _ r ft b l prio) ps)+ -> ConP c (ConPatternInfo i r ft b l prio) ps DefP _ q ps -> DefP i q ps- (LitP _ l) -> LitP i l+ (LitP (LitPatternInfo _ prio) l) -> LitP (LitPatternInfo i prio) l ProjP{} -> __IMPOSSIBLE__ (IApplyP _ t u x) -> IApplyP i t u x @@ -1187,8 +1380,8 @@ useName (dbPatVarName x) $ lookupS rho $ dbPatVarIndex x DotP i u -> DotP i $ applyPatSubst rho u- ConP c ci ps -> ConP c ci {conPType = applyPatSubst rho (conPType ci)} $ applySubst rho ps- DefP i q ps -> DefP i q $ applySubst rho ps+ ConP c ci ps -> ConP c ci {conPType = applyPatSubst rho (conPType ci)} $! applySubst rho ps+ DefP i q ps -> DefP i q $! applySubst rho ps p@(LitP _ _) -> p p@ProjP{} -> p IApplyP i t u x ->@@ -1220,7 +1413,7 @@ case initLast $ getProjLams lams of -- If we have no more abstractions, we must be a record field -- (projection applied already to record value).- Nothing -> if proper then Def d $ map Apply args else __IMPOSSIBLE__+ Nothing -> if proper then Def d $ map' Apply args else __IMPOSSIBLE__ Just (pars, Arg i y) -> let irr = isIrrelevant rel core@@ -1270,7 +1463,7 @@ -- | Turn a typed binding @(x1 .. xn : A)@ into a telescope. bindsToTel' :: (Name -> a) -> [Name] -> Dom Type -> ListTel' a bindsToTel' f [] t = []-bindsToTel' f (x:xs) t = fmap (f x,) t : bindsToTel' f xs (raise 1 t)+bindsToTel' f (x:xs) t = let !rest = bindsToTel' f xs (raise 1 t) in fmap (f x,) t : rest bindsToTel :: [Name] -> Dom Type -> ListTel bindsToTel = bindsToTel' nameToArgName@@ -1285,7 +1478,8 @@ namedBindsToTel :: [NamedArg Name] -> Type -> Telescope namedBindsToTel [] t = EmptyTel namedBindsToTel (x : xs) t =- ExtendTel (t <$ domFromNamedArgName x) $ Abs (nameToArgName $ namedArg x) $ namedBindsToTel xs (raise 1 t)+ let !rest = namedBindsToTel xs (raise 1 t) in+ ExtendTel (t <$ domFromNamedArgName x) (Abs (nameToArgName $ namedArg x) rest) namedBindsToTel1 :: List1 (NamedArg Name) -> Type -> Telescope namedBindsToTel1 = namedBindsToTel . List1.toList@@ -1297,6 +1491,9 @@ forceName (Named Nothing x) = Named (Just $ WithOrigin Inserted $ Ranged (getRange x) $ nameToArgName x) x forceName x = x +domNameFromNamedArgName :: NamedArg Name -> Dom Name+domNameFromNamedArgName x = namedArg x <$ domFromNamedArgName x+ -- ** Abstracting in terms and types mkPiSort :: Dom Type -> Abs Type -> Sort@@ -1365,7 +1562,7 @@ teleNoAbs :: a -> Term -> Term instance TeleNoAbs ListTel where- teleNoAbs tel t = foldr (\ Dom{domInfo = ai, unDom = (x, _)} -> Lam ai . NoAbs x) t tel+ teleNoAbs tel t = foldr (\ d -> Lam (d ^. dInfo) . NoAbs (fst (unDom d))) t tel instance TeleNoAbs Telescope where teleNoAbs tel = teleNoAbs $ telToList tel@@ -1402,6 +1599,8 @@ deriving instance Eq Sort deriving instance Ord Sort+deriving instance Eq a => Eq (BlockedDepCheck a)+deriving instance Ord a => Ord (BlockedDepCheck a) deriving instance Eq Level deriving instance Ord Level deriving instance Eq PlusLevel@@ -1534,13 +1733,13 @@ deriving instance Ord a => Ord (Dom a) -instance (Subst a, Eq a) => Eq (Elim' a) where+instance (Eq a) => Eq (Elim' a) where Apply a == Apply b = a == b Proj _ x == Proj _ y = x == y IApply x y r == IApply x' y' r' = x == x' && y == y' && r == r' _ == _ = False -instance (Subst a, Ord a) => Ord (Elim' a) where+instance (Ord a) => Ord (Elim' a) where Apply a `compare` Apply b = a `compare` b Proj _ x `compare` Proj _ y = x `compare` y IApply x y r `compare` IApply x' y' r' = compare x x' `mappend` compare y y' `mappend` compare r r'@@ -1549,7 +1748,25 @@ Proj{} `compare` _ = LT _ `compare` Proj{} = GT +deriving instance Eq DefSing+deriving instance Eq NLPat+deriving instance Eq NLPType+deriving instance Eq NLPSort+deriving instance Eq LocalEquation+deriving instance Eq RewriteRule+deriving instance Eq RewDom+deriving instance Eq (DomInfo Term) +deriving instance Ord DefSing+deriving instance Ord NLPSort+deriving instance Ord NLPType+deriving instance Ord NLPat+deriving instance Ord LocalEquation+deriving instance Ord RewriteHead+deriving instance Ord RewriteRule+deriving instance Ord RewDom+deriving instance Ord (DomInfo Term)+ --------------------------------------------------------------------------- -- * Sort stuff ---------------------------------------------------------------------------@@ -1630,14 +1847,13 @@ -- | Compute the sort of a function type from the sorts of its domain and codomain. ----- This function should only be called on reduced sorts,--- since the @LevelUniv@ rules should only apply when the sort does not reduce to @Set@.-funSort' :: Sort -> Sort -> Either Blocker Sort+-- The first argument is the value of `isLevelUniverseEnabled`+funSort' :: Bool -> Sort -> Sort -> Either Blocker Sort -- Andreas, 2023-05-12, AIM XXXVI, pri #6623: -- On GHC 8.6 and 8.8 this pattern matching triggers warning -- "Pattern match checker exceeded (2000000) iterations in a case alternative." -- No clue how to turn off this warning, so we have to turn off -Werror for GHC < 8.10.-funSort' = curry \case+funSort' hasLevelUniv a b = case (normLU a, normLU b) of (Univ u a , Univ u' b ) -> Right $ Univ (funUniv u u') $ levelLub a b (Inf ua m , b ) -> sizeOfSort b <&> \ (SizeOfSort ub n) -> Inf (funUniv ua ub) (max m n) (a , Inf ub n ) -> sizeOfSort a <&> \ (SizeOfSort ua m) -> Inf (funUniv ua ub) (max m n)@@ -1676,37 +1892,85 @@ (DummyS{} , _ ) -> Left neverUnblock (_ , DummyS{} ) -> Left neverUnblock -funSort :: Sort -> Sort -> Sort-funSort a b = fromRight (const $ FunSort a b) $ funSort' a b+ where+ normLU = applyUnless hasLevelUniv \case+ LevelUniv -> mkType 0+ s -> s --- | Compute the sort of a pi type from the sorts of its domain--- and codomain.--- This function should only be called on reduced sorts, since the @LevelUniv@ rules should only apply when the sort doesn't reduce to @Set@-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 -> Right $ FunSort s1 $ noabsApp __IMPOSSIBLE__ s2Abs- Just o -> case (sizeOfSort s1 , sizeOfSort s2) of- (Right (SmallSort u1) , Right (SmallSort u2)) -> case o of- StronglyRigid -> Right $ Inf (funUniv u1 u2) 0- Unguarded -> Right $ Inf (funUniv u1 u2) 0- WeaklyRigid -> Right $ Inf (funUniv u1 u2) 0- Flexible ms -> Left $ metaSetToBlocker ms- (Right (LargeSort u1 n) , Right (SmallSort u2)) -> Right $ Inf (funUniv u1 u2) n- (_ , Right LargeSort{} ) ->- -- large sorts cannot depend on variables- __IMPOSSIBLE__- -- (`trace` __IMPOSSIBLE__) $ unlines- -- [ "piSort': unexpected dependency in large codomain s2"- -- , "- a = " ++ prettyShow a- -- , "- s1 = " ++ prettyShow s1- -- , "- s2 = " ++ prettyShow s2- -- , "- s2 (raw) = " ++ show s2- -- ]- (Left blocker , Right _ ) -> Left blocker- (Right _ , Left blocker ) -> Left blocker- (Left blocker1 , Left blocker2 ) -> Left $ unblockOnBoth blocker1 blocker2+funSort :: Bool -> Sort -> Sort -> Sort+funSort hasLevelUniv a b = fromRight (const $ FunSort a b) $ funSort' hasLevelUniv a b +{-# SPECIALISE funSortM' :: Sort -> Sort -> TCM (Either Blocker Sort) #-}+funSortM' :: HasOptions m => Sort -> Sort -> m (Either Blocker Sort)+funSortM' a b = do+ hasLevelUniv <- isLevelUniverseEnabled+ return $ funSort' hasLevelUniv a b++{-# SPECIALISE funSortM :: Sort -> Sort -> TCM Sort #-}+funSortM :: HasOptions m => Sort -> Sort -> m Sort+funSortM a b = do+ hasLevelUniv <- isLevelUniverseEnabled+ return $ funSort hasLevelUniv a b++-- | Compute the sort of a pi type from three inputs:+-- 1. The "raw" domain of the pi type (without the sort)+-- 2. The sort of the domain+-- 3. The sort of the codomain (which lives in an extended context)+--+-- Note that unlike funSort', we don't care whether --level-universe is+-- enabled here. Instead, we just return a FunSort constructor and+-- assume it will be simplified in the next step. See also:+-- * `instance Reduce Sort` in Agda.TypeChecking.Substitute (this file)+-- * `inferPiSort` in Agda.TypeChecking.Sort+piSortB :: Dom Term -> Sort -> Abs Sort -> Either Blocker Sort+piSortB a s1 (NoAbs _ s2) = Right $ FunSort s1 s2+piSortB a s1 s2Abs@(Abs _ s2) = piSortB' CodomainSortSame a s1 s2Abs++-- | Compute the sort of a pi type where the codomain sort is an Abs.+-- Compared to piSortB we an additional argument:+-- 1. The original codomain sort of the pi type (for determing whether the pi+-- is level-dependent)+piSortB' ::+ BlockedDepCheck Sort -> Dom Term -> Sort -> Abs Sort+ -> Either Blocker Sort+piSortB' c a s1 s2Abs =+ case varOccurrenceIn 0 $! codomainSortOld (unAbs s2Abs) c of+ Nothing -> Right $! FunSort s1 $! noabsApp __IMPOSSIBLE__ s2Abs+ Just o -> piSortB'' a s1 s2Abs (varFlexRig o) CodomainNotNormalised++data IsCodomainNormalised = CodomainNormalised | CodomainNotNormalised++-- | Compute the sort of a pi type where the codomain sort is a proper Abs.+-- Compared to piSortB we take two additional arguments:+-- 4. The occurrence of the variable in the (original) codomain sort.+-- 5. Whether we have already tried to remove the dependency by+-- normalising the codomain sort (e.g. with forceNonDep)+piSortB''+ :: Dom Term+ -> Sort+ -> Abs Sort+ -> FlexRig+ -> IsCodomainNormalised+ -> Either Blocker Sort+piSortB'' a s1 NoAbs{} _ _ = __IMPOSSIBLE__+piSortB'' a s1 (Abs x s2) occ norm = case (sizeOfSort s1 , sizeOfSort s2) of+ (Right (SmallSort u1) , Right (SmallSort u2)) -> case occ of+ StronglyRigid -> let !u = funUniv u1 u2 in Right (Inf u 0)+ Unguarded -> let !u = funUniv u1 u2 in Right (Inf u 0)+ -- Jesper, 2026-02-17: A weakly rigid occurrence might disappear after+ -- normalisation (see #8393) so we refrain from making a final verdict here.+ -- unless we are sure further normalisation will not remove the dependency+ WeaklyRigid -> case norm of+ CodomainNormalised -> let !u = funUniv u1 u2 in Right (Inf u 0)+ CodomainNotNormalised -> Left alwaysUnblock+ Flexible ms -> Left $! metaSetToBlocker ms+ (Right (LargeSort u1 n) , Right (SmallSort u2)) -> let !u = funUniv u1 u2 in Right (Inf u n)+ -- large sorts cannot depend on variables+ (_ , Right LargeSort{}) -> __IMPOSSIBLE__+ (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. -- piSort' a bAbs@(Abs _ b) = case occurrence 0 b of@@ -1737,13 +2001,39 @@ -- Flexible _ -> Nothing piSort :: Dom Term -> Sort -> Abs Sort -> Sort-piSort a s1 s2 = fromRight (const $ PiSort a s1 s2) $ piSort' a s1 s2+piSort a s1 s2 = fromRight (const $ PiSort CodomainSortSame a s1 s2) $!+ piSortB a s1 s2 +{-# SPECIALISE piSortM :: Dom Term -> Sort -> Abs Sort -> TCM Sort #-}+piSortM :: HasOptions m =>+ Dom Term -> Sort -> Abs Sort -> m Sort+piSortM va s1 s2 = piSortM'' CodomainSortSame va s1 s2 $! piSortB va s1 s2++{-# SPECIALISE piSortM' :: BlockedDepCheck Sort -> Dom Term -> Sort -> Abs Sort -> TCM Sort #-}+piSortM' :: HasOptions m =>+ BlockedDepCheck Sort -> Dom Term -> Sort -> Abs Sort -> m Sort+piSortM' c va s1 s2 = piSortM'' c va s1 s2 $! piSortB' c va s1 s2++{-# SPECIALISE piSortM'' :: BlockedDepCheck Sort -> Dom Term -> Sort -> Abs Sort -> Either Blocker Sort -> TCM Sort #-}+piSortM'' :: HasOptions m+ => BlockedDepCheck Sort -> Dom Term -> Sort -> Abs Sort+ -> Either Blocker Sort -> m Sort+piSortM'' c va s1 s2 = \case+ Left _ -> return $ PiSort c va s1 s2+ -- Jesper, 2025-09-15: if a PiSort reduces to a FunSort, piSort'+ -- just returns the FunSort without trying to simplify it further.+ -- So if we get a FunSort here we call funSortM in the hopes+ -- of getting a simpler result. But we DON'T call reduce as that+ -- can lead to quadratic behavior, see #8096.+ Right (FunSort s1' s2') -> funSortM s1' s2'+ Right s' -> return s'++ --------------------------------------------------------------------------- -- * Level stuff --------------------------------------------------------------------------- --- ^ Computes @n0 ⊔ a₁ ⊔ a₂ ⊔ ... ⊔ aₙ@ and return its canonical form.+-- | Computes @n0 ⊔ a₁ ⊔ a₂ ⊔ ... ⊔ aₙ@ and return its canonical form. levelMax :: Integer -> [PlusLevel] -> Level levelMax !n0 as0 = Max n as where@@ -1758,10 +2048,10 @@ lmax :: Integer -> [PlusLevel] -> [Level] -> Level lmax m as [] = Max m as- lmax m as (Max n bs : ls) = lmax (max m n) (bs ++ as) ls+ lmax m as (Max n bs : ls) = lmax (max m n) (bs ++! as) ls expandLevel :: Level -> Level- expandLevel (Max m as) = lmax m [] $ map expandPlus as+ expandLevel (Max m as) = lmax m [] $ map'' expandPlus as expandPlus :: PlusLevel -> Level expandPlus (Plus m l) = levelPlus m (expandTm l)@@ -1770,15 +2060,15 @@ expandTm l = atomicLevel l removeSubsumed =- map (\(a, n) -> Plus n a) .+ map' (\(a, n) -> Plus n a) . MapS.toAscList . MapS.fromListWith max .- map (\(Plus n a) -> (a, n))+ map' (\(Plus n a) -> (a, n)) -- | Given two levels @a@ and @b@, compute @a ⊔ b@ and return its -- canonical form. levelLub :: Level -> Level -> Level-levelLub (Max m as) (Max n bs) = levelMax (max m n) $ as ++ bs+levelLub (Max m as) (Max n bs) = levelMax (max m n) $! as ++! bs levelTm :: Level -> Term levelTm l =
src/full/Agda/TypeChecking/Substitute/Class.hs view
@@ -2,16 +2,14 @@ module Agda.TypeChecking.Substitute.Class where -import Control.Arrow ((***), second)-import Control.DeepSeq-import GHC.Generics- import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.TypeChecking.Free import Agda.TypeChecking.Substitute.DeBruijn +import Agda.Utils.Tuple ((***), second)+ import Agda.Utils.Impossible ---------------------------------------------------------------------------@@ -28,7 +26,7 @@ -- Andreas, 2018-06-18, issue #3136 -- This default instance should be removed to get more precise -- crash locations (raise the IMPOSSIBLE in a more specific place).- -- applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+ -- applyE t es = apply t $ mustAllApplyElims es -- precondition: all @es@ are @Apply@s -- | Apply to some default arguments.@@ -74,12 +72,16 @@ -- | Simple constraint alias for a `Subst` instance `a` with arg type `t`. type SubstWith t a = (Subst a, SubstArg a ~ t) --- | `Subst` instance whose agument type is itself+-- | `Subst` instance whose argument type is itself type EndoSubst a = SubstWith a a -- | `Subst` instance whose argument type is `Term` type TermSubst a = SubstWith Term a +-- | `Subst` instance whose argument type is `Nat` (i.e. for things that+-- can be weakened, but do not admit arbitrary substitution)+type WeakSubst a = SubstWith Nat a+ -- | Raise de Bruijn index, i.e. weakening raise :: Subst a => Nat -> a -> a raise = raiseFrom 0@@ -115,12 +117,6 @@ type SubstArg QName = Term applySubst _ q = q --- | Wrapper for types that do not contain variables (so applying a substitution is the identity).--- Useful if you have a structure of types that support substitution mixed with types that don't--- and need to apply a substitution to the full structure.-newtype NoSubst t a = NoSubst { unNoSubst :: a }- deriving (Generic, NFData, Functor)- instance DeBruijn t => Subst (NoSubst t a) where type SubstArg (NoSubst t a) = t applySubst _ x = x@@ -290,20 +286,28 @@ {-# INLINABLE lookupS #-} lookupS :: EndoSubst a => Substitution' a -> Nat -> a-lookupS rho i = case rho of- IdS -> deBruijnVar i+lookupS = lookupS' 0++{-# INLINABLE lookupS' #-}+lookupS' :: EndoSubst a+ => Nat -- ^ Raise the looked up term/thing by this amount.+ -> Substitution' a -- ^ The substitution.+ -> Nat -- ^ Index to lookup in the substitution.+ -> a -- ^ The raised result.+lookupS' w rho i = case rho of+ IdS -> deBruijnVar (w + i) Wk n IdS -> let j = i + n in- if j < 0 then __IMPOSSIBLE__ else deBruijnVar j- Wk n rho -> applySubst (raiseS n) (lookupS rho i)- u :# rho | i == 0 -> u+ if j < 0 then __IMPOSSIBLE__ else deBruijnVar (w + j)+ Wk n rho -> lookupS' (n + w) rho i+ u :# rho | i == 0 -> raise w u | i < 0 -> __IMPOSSIBLE__- | otherwise -> lookupS rho (i - 1)+ | otherwise -> lookupS' w rho (i - 1) Strengthen err n rho | i < 0 -> __IMPOSSIBLE__ | i < n -> throwImpossible err- | otherwise -> lookupS rho (i - n)- Lift n rho | i < n -> deBruijnVar i- | otherwise -> raise n $ lookupS rho (i - n)+ | otherwise -> lookupS' w rho (i - n)+ Lift n rho | i < n -> deBruijnVar (w + i)+ | otherwise -> lookupS' (n + w) rho (i - n) EmptyS err -> throwImpossible err
src/full/Agda/TypeChecking/Substitute/DeBruijn.hs view
@@ -26,6 +26,7 @@ -- | We can substitute @Term@s for variables. instance DeBruijn Term where deBruijnVar = var+ {-# INLINE deBruijnView #-} deBruijnView u = case u of Var i [] -> Just i@@ -34,6 +35,7 @@ instance DeBruijn PlusLevel where deBruijnVar = Plus 0 . deBruijnVar+ {-# INLINE deBruijnView #-} deBruijnView l = case l of Plus 0 a -> deBruijnView a@@ -41,6 +43,7 @@ instance DeBruijn Level where deBruijnVar i = Max 0 [deBruijnVar i]+ {-# INLINE deBruijnView #-} deBruijnView l = case l of Max 0 [p] -> deBruijnView p@@ -50,7 +53,10 @@ deBruijnNamedVar = DBPatVar deBruijnView = Just . dbPatVarIndex - instance DeBruijn a => DeBruijn (Named_ a) where deBruijnNamedVar nm i = unnamed $ deBruijnNamedVar nm i deBruijnView = deBruijnView . namedThing++instance DeBruijn Nat where+ deBruijnVar x = x+ deBruijnView x = Just x
src/full/Agda/TypeChecking/SyntacticEquality.hs view
@@ -1,4 +1,10 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Strict #-}+#if __GLASGOW_HASKELL__ > 902+{-# OPTIONS_GHC -fworker-wrapper-cbv #-}+#endif {-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wno-redundant-bang-patterns #-} -- | A syntactic equality check that takes meta instantiations into account, -- but does not reduce. It replaces@@ -17,22 +23,24 @@ ) where -import Control.Arrow ( (***) )-import Control.Monad ( zipWithM )-import Control.Monad.State ( MonadState(..), StateT, runStateT )+import Control.Monad import Control.Monad.Trans ( lift ) import Agda.Syntax.Common import Agda.Syntax.Internal -import Agda.TypeChecking.Monad ( ReduceM, MonadReduce(..), TCEnv(..), MonadTCEnv(..) )+import Agda.TypeChecking.Monad import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute -import qualified Agda.Utils.Maybe.Strict as Strict-import Agda.Utils.Monad (ifM)-import Agda.Utils.Unsafe (unsafeComparePointers)+import Agda.Utils.ExpandCase+import Agda.Utils.Maybe.Strict qualified as Strict+import Agda.Utils.Monad ( ifM )+import Agda.Utils.Unsafe ( unsafeComparePointers )+import Agda.Utils.Tuple ( (***) )+import Agda.Utils.StrictState + -- | 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@@ -58,9 +66,9 @@ ReduceM a #-} {-# SPECIALIZE checkSyntacticEquality :: Type -> Type ->- (Type -> Type -> ReduceM a) ->- (Type -> Type -> ReduceM a) ->- ReduceM a #-}+ (Type -> Type -> TCM a) ->+ (Type -> Type -> TCM a) ->+ TCM a #-} checkSyntacticEquality :: (Instantiate a, SynEq a, MonadReduce m) => a@@ -76,25 +84,13 @@ {-else-} (uncurry f =<< instantiate (u, v)) where decreaseFuel env =- case envSyntacticEqualityFuel env of+ case env ^. eSyntacticEqualityFuel of Strict.Nothing -> env- Strict.Just n ->- env { envSyntacticEqualityFuel = Strict.Just (pred n) }+ Strict.Just n -> env & eSyntacticEqualityFuel .~ 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)+ :: (SynEq a, MonadReduce m) => a -> a -> (a -> a -> m b) -- ^ Continuation used upon success.@@ -108,8 +104,8 @@ syntacticEqualityFuelRemains :: MonadReduce m => m Bool syntacticEqualityFuelRemains = do- fuel <- envSyntacticEqualityFuel <$> askTC- return $ case fuel of+ fuel <- viewTC eSyntacticEqualityFuel+ return $! case fuel of Strict.Nothing -> True Strict.Just n -> n > 0 @@ -120,123 +116,155 @@ inequal :: a -> SynEqM a inequal a = put False >> return a --- | If inequality is flagged, return, else continue.-ifEqual :: (a -> SynEqM a) -> (a -> SynEqM a)-ifEqual cont a = ifM get (cont a) (return a)- -- Since List2 is only Applicative, not a monad, I cannot -- define a List2T monad transformer, so we do it manually:--(<$$>) :: Functor f => (a -> b) -> f (a, a) -> f (b, b)-f <$$> xx = (f *** f) <$> xx+{-# INLINE (<$$>) #-}+(<$$>) :: Monad f => (a -> b) -> f (a, a) -> f (b, b)+f <$$> aa = do+ (a, a') <- aa+ let b = f a+ let b' = f a'+ pure (b, b') pure2 :: Applicative f => a -> f (a, a) pure2 a = pure (a, a) -(<**>) :: Applicative f => f (a -> b, a -> b) -> f (a, a) -> f (b, b)-ff <**> xx = (uncurry (***)) <$> ff <*> xx+{-# INLINE (<**>) #-}+(<**>) :: Monad f => f (a -> b, a -> b) -> f (a, a) -> f (b, b)+ff <**> aa = do+ (f, f') <- ff+ (a, a') <- aa+ let b = f a+ let b' = f' a'+ pure (b, b') -- | Instantiate full as long as things are equal class SynEq a where synEq :: a -> a -> SynEqM (a, a)++ {-# INLINE synEq' #-} synEq' :: a -> a -> SynEqM (a, a)- synEq' a a' = ifEqual (uncurry synEq) (a, a')+ synEq' a a' = do+ eq <- get+ expand \ret -> if eq then ret $ synEq a a'+ else ret $ pure (a, a') instance SynEq Bool where- synEq x y | x == y = return (x, y)- synEq x y | otherwise = inequal (x, y)+ synEq x y = expand \ret -> if x == y then ret $ pure (x, y) else ret $ inequal (x, y) -- | Syntactic term equality ignores 'DontCare' stuff. instance SynEq Term where- synEq v v' = if unsafeComparePointers v v' then return (v, v') else do- (v, v') <- lift $ instantiate' (v, v')- case (v, v') of- (Var i vs, Var i' vs') | i == i' -> Var i <$$> synEq vs vs'- (Con c i vs, Con c' i' vs') | c == c' -> Con c (bestConInfo i i') <$$> synEq vs vs'- (Def f vs, Def f' vs') | f == f' -> Def f <$$> synEq vs vs'- (MetaV x vs, MetaV x' vs') | x == x' -> MetaV x <$$> synEq vs vs'- (Lit l , Lit l' ) | l == l' -> pure2 $ v- (Lam h b , Lam h' b' ) -> Lam <$$> synEq h h' <**> synEq b b'- (Level l , Level l' ) -> levelTm <$$> synEq l l'- (Sort s , Sort s' ) -> Sort <$$> synEq s s'- (Pi a b , Pi a' b' ) -> Pi <$$> synEq a a' <**> synEq' b b'- (DontCare u, DontCare u' ) -> DontCare <$$> synEq u u'+ synEq v v' = expand \ret -> if unsafeComparePointers v v' then ret $ pure (v, v') else ret do+ v <- lift $ instantiate' v+ v' <- lift $ instantiate' v'+ expand \ret -> case (v, v') of+ -- note Var' on next line: if the Var-s are cacheable, the pointer equality above+ -- suceeds. So here there's no point trying to cache them.+ (Var i vs, Var i' vs') | i == i' -> ret $ Var' i <$$> synEq vs vs'+ (Con c i vs, Con c' i' vs') | c == c' -> ret $ Con c (bestConInfo i i') <$$> synEq vs vs'+ (Def f vs, Def f' vs') | f == f' -> ret $ Def f <$$> synEq vs vs'+ (MetaV x vs, MetaV x' vs') | x == x' -> ret $ MetaV x <$$> synEq vs vs'+ (Lit l , Lit l' ) | l == l' -> ret $ pure2 $ v+ (Lam h b , Lam h' b' ) -> ret $ Lam <$$> synEq h h' <**> synEq b b'+ (Level l , Level l' ) -> ret $ levelTm <$$> synEq l l'+ (Sort s , Sort s' ) -> ret $ Sort <$$> synEq s s'+ (Pi a b , Pi a' b' ) -> ret $ Pi <$$> synEq a a' <**> synEq' b b'+ (DontCare u, DontCare u' ) -> ret $ DontCare <$$> synEq u u' -- Irrelevant things are not syntactically equal. ALT: -- pure (u, u') -- Jesper, 2019-10-21: considering irrelevant things to be -- syntactically equal causes implicit arguments to go -- unsolved, so it is better to go under the DontCare.- (Dummy{} , Dummy{} ) -> pure (v, v')- _ -> inequal (v, v')+ (Dummy{} , Dummy{} ) -> ret $ pure (v, v')+ _ -> ret $ inequal (v, v') instance SynEq Level where- synEq l@(Max n vs) l'@(Max n' vs')- | n == n' = levelMax n <$$> synEq vs vs'- | otherwise = inequal (l, l')+ synEq l l' = expand \ret -> case (l, l') of+ (l@(Max n vs), l'@(Max n' vs'))+ | n == n' -> ret $ levelMax n <$$> synEq vs vs'+ | otherwise -> ret $ inequal (l, l') instance SynEq PlusLevel where- synEq l@(Plus n v) l'@(Plus n' v')- | n == n' = Plus n <$$> synEq v v'- | otherwise = inequal (l, l')+ synEq l l' = expand \ret -> case (l, l') of+ (l@(Plus n v), l'@(Plus n' v'))+ | n == n' -> ret $ Plus n <$$> synEq v v'+ | otherwise -> ret $ inequal (l, l') instance SynEq Sort where- synEq s s' = if unsafeComparePointers s s' then return (s, s') else do- (s, s') <- lift $ instantiate' (s, s')- case (s, s') of- (Univ u l, Univ u' l') | u == u' -> Univ u <$$> synEq l l'- (PiSort a b c, PiSort a' b' c') -> piSort <$$> synEq a a' <**> synEq' b b' <**> synEq' c c'- (FunSort a b, FunSort a' b') -> funSort <$$> synEq a a' <**> synEq' b b'- (UnivSort a, UnivSort a') -> UnivSort <$$> synEq a a'- (SizeUniv, SizeUniv ) -> pure2 s- (LockUniv, LockUniv ) -> pure2 s- (LevelUniv, LevelUniv ) -> pure2 s- (IntervalUniv, IntervalUniv) -> pure2 s- (Inf u m , Inf u' n) | u == u', m == n -> pure2 s- (MetaS x es , MetaS x' es') | x == x' -> MetaS x <$$> synEq es es'- (DefS d es , DefS d' es') | d == d' -> DefS d <$$> synEq es es'- (DummyS{}, DummyS{}) -> pure (s, s')- _ -> inequal (s, s')+ synEq s s' = expand \ret -> if unsafeComparePointers s s' then ret $ pure (s, s') else ret do+ s <- lift $ instantiate' s+ s' <- lift $ instantiate' s'+ expand \ret -> case (s, s') of+ (Univ u l, Univ u' l') | u == u' -> ret $ Univ u <$$> synEq l l'+ (PiSort a b c d, PiSort a' b' c' d') -> ret $ PiSort <$$>+ synEq a a' <**> synEq b b' <**> synEq' c c' <**> synEq' d d'+ (FunSort a b, FunSort a' b') -> ret $ FunSort <$$> synEq a a' <**> synEq' b b'+ (UnivSort a, UnivSort a') -> ret $ UnivSort <$$> synEq a a'+ (SizeUniv, SizeUniv ) -> ret $ pure2 s+ (LockUniv, LockUniv ) -> ret $ pure2 s+ (LevelUniv, LevelUniv ) -> ret $ pure2 s+ (IntervalUniv, IntervalUniv) -> ret $ pure2 s+ (Inf u m , Inf u' n) | u == u', m == n -> ret $ pure2 s+ (MetaS x es , MetaS x' es') | x == x' -> ret $ MetaS x <$$> synEq es es'+ (DefS d es , DefS d' es') | d == d' -> ret $ DefS d <$$> synEq es es'+ (DummyS{}, DummyS{}) -> ret $ pure (s, s')+ _ -> ret $ inequal (s, s') +instance SynEq a => SynEq (BlockedDepCheck a) where+ synEq s s' = expand \ret -> case (s, s') of+ (CodomainSortOld s, CodomainSortOld s') ->+ ret $ CodomainSortOld <$$> synEq s s'+ (CodomainSortSame, CodomainSortSame) ->+ ret $ pure (CodomainSortSame, CodomainSortSame)+ _ -> ret $ inequal (s, s')+ -- | Syntactic equality ignores sorts. instance SynEq Type where- synEq (El s t) (El s' t') = (El s *** El s') <$> synEq t t'+ synEq x y = expand \ret -> case (x, y) of+ (El s t, El s' t') -> ret $ (El s *** El s') <$!> synEq t t' instance SynEq a => SynEq [a] where- synEq as as'- | length as == length as' = unzip <$> zipWithM synEq' as as'- | otherwise = inequal (as, as')+ synEq as as' = expand \ret -> case (as, as') of+ ([], []) -> ret $ pure ([], [])+ (a:as, a':as') -> ret $ (:) <$$> synEq a a' <**> synEq as as'+ (as, as') -> ret $ inequal (as, as') instance (SynEq a, SynEq b) => SynEq (a,b) where- synEq (a,b) (a',b') = (,) <$$> synEq a a' <**> synEq b b'+ synEq x y = expand \ret -> case (x, y) of+ ((a,b), (a',b')) -> ret $ (,) <$$> synEq a a' <**> synEq b b' instance SynEq a => SynEq (Elim' a) where- synEq e e' =+ synEq e e' = expand \ret -> case (e, e') of- (Proj _ f, Proj _ f') | f == f' -> pure2 e- (Apply a, Apply a') -> Apply <$$> synEq a a'+ (Proj _ f, Proj _ f') | f == f' -> ret $ pure2 e+ (Apply a, Apply a') -> ret $ Apply <$$> synEq a a' (IApply u v r, IApply u' v' r')- -> (IApply u v *** IApply u' v') <$> synEq r r'- _ -> inequal (e, e')+ -> ret $ (IApply u v *** IApply u' v') <$!> synEq r r'+ _ -> ret $ inequal (e, e') instance (Subst a, SynEq a) => SynEq (Abs a) where- synEq a a' =+ synEq a a' = expand \ret -> case (a, a') of- (NoAbs x b, NoAbs x' b') -> (NoAbs x *** NoAbs x') <$> synEq b b'- (Abs x b, Abs x' b') -> (Abs x *** Abs x') <$> synEq b b'- (Abs x b, NoAbs x' b') -> Abs x <$$> synEq b (raise 1 b') -- TODO: mkAbs?- (NoAbs x b, Abs x' b') -> Abs x' <$$> synEq (raise 1 b) b'+ (NoAbs x b, NoAbs x' b') -> ret $ (NoAbs x *** NoAbs x') <$!> synEq b b'+ (Abs x b, Abs x' b') -> ret $ (Abs x *** Abs x') <$!> synEq b b'+ (Abs x b, NoAbs x' b') -> ret $ Abs x <$$> synEq b (raise 1 b') -- TODO: mkAbs?+ (NoAbs x b, Abs x' b') -> ret $ Abs x' <$$> synEq (raise 1 b) b' -- NOTE: Do not ignore 'ArgInfo', or test/fail/UnequalHiding will pass. instance SynEq a => SynEq (Arg a) where- synEq (Arg ai a) (Arg ai' a') = Arg <$$> synEq ai ai' <**> synEq a a'+ synEq x y = expand \ret -> case (x, y) of+ ((Arg ai a), (Arg ai' a')) -> ret $ Arg <$$> synEq ai ai' <**> synEq a a' --- Ignore the tactic.+-- Ignore the tactic and elaborated rewrite. instance SynEq a => SynEq (Dom a) where- 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')+ synEq d d' = expand \ret -> case (d, d') of+ (d@(Dom ai x f t r a), d'@(Dom ai' x' f' _ r' a'))+ | x == x' -> ret $ Dom <$$> synEq ai ai' <**> pure2 x <**> synEq f f'+ <**> pure2 t <**> pure (r, r') <**> synEq a a'+ | otherwise -> ret $ inequal (d, d') instance SynEq ArgInfo where- synEq ai@(ArgInfo h r o _ a) ai'@(ArgInfo h' r' o' _ a')- | h == h', sameModality r r', a == a' = pure2 ai- | otherwise = inequal (ai, ai')+ synEq ai ai' = expand \ret -> case (ai, ai') of+ (ai@(ArgInfo h r o _ a), ai'@(ArgInfo h' r' o' _ a'))+ | h == h', sameModality r r', a == a' -> ret $ pure2 ai+ | otherwise -> ret $ inequal (ai, ai')
src/full/Agda/TypeChecking/Telescope.hs view
@@ -5,14 +5,14 @@ import Prelude hiding (null) import Control.Monad+import Control.Monad.Trans.Maybe (MaybeT) -import Data.Bifunctor (first)-import Data.Foldable (find)+import Data.Foldable import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import qualified Data.List as List import Data.Maybe-import Data.Monoid+-- import Data.Monoid import Agda.Syntax.Common import Agda.Syntax.Common.Pretty ( Pretty )@@ -40,24 +40,41 @@ import Agda.Utils.Impossible --- | Flatten telescope: @(Γ : Tel) -> [Type Γ]@+-- | Flatten telescope: @(Γ : Tel) -> [Type Γ]@.+--+-- 'flattenTel' is lazy in both the spine and values of+-- the resulting list. flattenTel :: TermSubst a => Tele (Dom a) -> [Dom a]-flattenTel EmptyTel = []-flattenTel (ExtendTel a tel) = raise (size tel + 1) a : flattenTel (absBody tel)-+flattenTel tel = loop (size tel) tel+ where+ loop ix EmptyTel = []+ loop ix (ExtendTel a (Abs _ tel)) = raise ix a : loop (ix - 1) tel+ loop ix (ExtendTel a (NoAbs _ tel)) = raise ix a : loop ix tel {-# SPECIALIZE flattenTel :: Telescope -> [Dom Type] #-} +-- | Flatten telescope: @(Γ : Tel) -> [Type Γ]@ into a reversed list.+--+-- 'flattenRevTel' is lazy in both the spine and values of+-- the resulting list.+flattenRevTel :: TermSubst a => Tele (Dom a) -> [Dom a]+flattenRevTel tel = loop (size tel) [] tel+ where+ loop ix acc EmptyTel = acc+ loop ix acc (ExtendTel a (Abs _ tel)) = loop (ix - 1) (raise ix a : acc) tel+ loop ix acc (ExtendTel a (NoAbs _ tel)) = loop ix (raise ix a : acc) tel+{-# SPECIALIZE flattenRevTel :: Telescope -> [Dom Type] #-}+ -- | Turn a context into a flat telescope: all entries live in the whole context. -- @ -- (Γ : Context) -> [Type Γ] -- @ flattenContext :: Context -> [ContextEntry]-flattenContext = loop 1 []+flattenContext = loop 1 [] . cxEntries where loop n tel [] = tel loop n tel (ce:ctx) = loop (n + 1) (raise n ce : tel) ctx --- | Order a flattened telescope in the correct dependeny order: Γ ->+-- | Order a flattened telescope in the correct dependency order: Γ -> -- Permutation (Γ -> Γ~) -- -- Since @reorderTel tel@ uses free variable analysis of type in @tel@,@@ -85,8 +102,7 @@ where tel' = unflattenTel' (n - 1) xs tel a' = applySubst rho a- rho = parallelS $- replicate n (withCallerCallStack impossibleTerm)+ rho = strengthenS (withCallerCallStack Impossible) n ([], _ : _) -> __IMPOSSIBLE__ (_ : _, []) -> __IMPOSSIBLE__ @@ -101,14 +117,20 @@ -- | Get the suggested names from a telescope teleNames :: Telescope -> [ArgName]-teleNames = map (fst . unDom) . telToList+teleNames = map' (fst . unDom) . telToList teleArgNames :: Telescope -> [Arg ArgName] teleArgNames = telToArgs +-- | Convert a telescope to a list of 'Arg' in left-to-right order:+--+-- @teleArgs ((a : A) (b : B a) {c : C}) = [a, b, {c}] = [2, 1, {0}]@ teleArgs :: (DeBruijn a) => Tele (Dom t) -> [Arg a]-teleArgs = map argFromDom . teleDoms+teleArgs = map' argFromDom . teleDoms +-- | Convert a telescope to a list of 'Dom' in left-to-right order:+--+-- @teleDoms ((a : A) (b : B a) {c : C}) = [a, b, {c}] = [2, 1, {0}]@ teleDoms :: (DeBruijn a) => Tele (Dom t) -> [Dom a] teleDoms tel = zipWith (\ i dom -> deBruijnVar i <$ dom) (downFrom $ size l) l where l = telToList tel@@ -121,7 +143,7 @@ -- where l = telToList tel teleNamedArgs :: (DeBruijn a) => Tele (Dom t) -> [NamedArg a]-teleNamedArgs = map namedArgFromDom . teleDoms+teleNamedArgs = map' namedArgFromDom . teleDoms {-# INLINABLE tele2NamedArgs #-} -- | A variant of `teleNamedArgs` which takes the argument names (and the argument info)@@ -130,8 +152,9 @@ -- Precondition: the two telescopes have the same length. tele2NamedArgs :: (DeBruijn a) => Telescope -> Telescope -> [NamedArg a] tele2NamedArgs tel0 tel =- [ Arg info (Named (Just $ WithOrigin Inserted $ unranged $ argNameToString argName) (deBruijnNamedVar varName i))- | (i, Dom{domInfo = info, unDom = (argName,_)}, Dom{unDom = (varName,_)}) <- zip3 (downFrom $ size l) l0 l ]+ [ Arg (d1 ^. dInfo) (Named (Just $ WithOrigin Inserted $ unranged $ argNameToString (fst (unDom d1)))+ (deBruijnNamedVar (fst (unDom d2)) i))+ | (i, d1, d2) <- zip3 (downFrom $ size l) l0 l ] where l = telToList tel l0 = telToList tel0@@ -149,26 +172,26 @@ (tel', tel'') = splitTelescopeAt (m - 1) $ absBody tel -- | Permute telescope: permutes or drops the types in the telescope according--- to the given permutation. Assumes that the permutation preserves the+-- to the given permutation (on de Bruijn _levels_). Assumes that the permutation preserves the -- dependencies in the telescope. -- -- For example (Andreas, 2016-12-18, issue #2344): -- @--- tel = (A : Set) (X : _18 A) (i : Fin (_m_23 A X))--- tel (de Bruijn) = 2:Set, 1:_18 @0, 0:Fin(_m_23 @1 @0)--- flattenTel tel = 2:Set, 1:_18 @0, 0:Fin(_m_23 @1 @0) |- [ Set, _18 @2, Fin (_m_23 @2 @1) ]--- perm = 0,1,2 -> 0,1 (picks the first two)--- renaming _ perm = [var 0, var 1, error] -- THE WRONG RENAMING!--- renaming _ (flipP perm) = [error, var 1, var 0] -- The correct renaming!--- apply to flattened tel = ... |- [ Set, _18 @1, Fin (_m_23 @1 @0) ]--- permute perm it = ... |- [ Set, _18 @1 ]--- unflatten (de Bruijn) = 1:Set, 0: _18 @0--- unflatten = (A : Set) (X : _18 A)--- @+-- tel = (A : Set) (X : _18 A) (i : Fin (_m_23 A X))+-- tel (de Bruijn) = 2:Set, 1:_18 @0, 0:Fin(_m_23 @1 @0)+-- flattenTel tel = 2:Set, 1:_18 @0, 0:Fin(_m_23 @1 @0) |- [ Set, _18 @2, Fin (_m_23 @2 @1) ]+-- perm = 0,1,2 -> 0,1 (picks the first two)+-- renaming _ perm = [var 0, var 1, error] -- THE WRONG RENAMING! (levels)+-- renaming _ (reverseP perm) = [error, var 0, var 1] -- The correct renaming! (indices)+-- apply to flattened tel = ... |- [ Set, _18 @1, Fin (_m_23 @1 @0) ]+-- permute perm it = ... |- [ Set, _18 @1 ]+-- unflatten (de Bruijn) = 1:Set, 0: _18 @0+-- unflatten = (A : Set) (X : _18 A)+-- @ permuteTel :: Permutation -> Telescope -> Telescope permuteTel perm tel = let names = permute perm $ teleNames tel- types = permute perm $ renameP impossible (flipP perm) $ flattenTel tel+ types = permute perm $ renameP impossible (reverseP perm) $ flattenTel tel in unflattenTel names types -- | Like 'permuteTel', but start with a context.@@ -178,56 +201,74 @@ -- | Recursively computes dependencies of a set of variables in a given -- telescope. Any dependencies outside of the telescope are ignored.-varDependencies :: Telescope -> IntSet -> IntSet-varDependencies tel = addLocks . allDependencies IntSet.empty+--+-- Note that 'varDependencies' considers a variable to depend on itself.+varDependencies :: Telescope -> VarSet -> VarSet+varDependencies tel = addLocks . allDependencies tel where- addLocks s | IntSet.null s = s- | otherwise = IntSet.union s $ IntSet.fromList $ filter (>= m) locks+ addLocks :: VarSet -> VarSet+ addLocks s =+ case VarSet.lookupMin s of+ Just m ->+ let locks = catMaybes [ deBruijnView (unArg a) | (a :: Arg Term) <- teleArgs tel, IsLock{} <- pure (getLock a)]+ -- 'teleArgs' returns indices in descending order, so both the+ -- 'takeWhile' and 'insertsDesc' are safe.+ in VarSet.insertsDesc (takeWhile (>= m) locks) s+ Nothing ->+ s++ allDependencies :: Telescope -> VarSet -> VarSet+ allDependencies tel vs = loop empty (flattenRevTel tel) (-1) vs where- locks = catMaybes [ deBruijnView (unArg a) | (a :: Arg Term) <- teleArgs tel, IsLock{} <- pure (getLock a)]- m = IntSet.findMin s- n = size tel- ts = flattenTel tel+ -- Idea here is to keep a set @work@ of variables that we still need+ -- to get deps of. At each iteration, we skip backwards through the telescope+ -- and add its direct dependencies to the work set. This only checks dependencies+ -- of each variable once, as telescope elements can't depend on things later in the telescope.+ loop :: VarSet -> [Dom Type] -> Int -> VarSet -> VarSet+ loop !deps telRev prevIx work =+ case VarSet.minView work of+ Nothing -> deps+ Just (ix, work) ->+ case drop (ix - prevIx - 1) telRev of+ [] ->+ -- Ignore all deps outside the telescope+ deps+ (ti:telRev) ->+ loop (VarSet.insert ix deps) telRev ix (VarSet.union (freeVarSet ti) work) - directDependencies :: Int -> IntSet- directDependencies i = allFreeVars $ indexWithDefault __IMPOSSIBLE__ ts (n-1-i) - allDependencies :: IntSet -> IntSet -> IntSet- allDependencies =- IntSet.foldr $ \j soFar ->- if j >= n || j `IntSet.member` soFar- then soFar- else IntSet.insert j $ allDependencies soFar $ directDependencies j -- | Computes the set of variables in a telescope whose type depend on -- one of the variables in the given set (including recursive -- dependencies). Any dependencies outside of the telescope are -- ignored.-varDependents :: Telescope -> IntSet -> IntSet-varDependents tel = allDependents+--+-- Unlike 'varDependencies', a variable is *not* considered to depend on itself.+varDependents :: Telescope -> VarSet -> VarSet+varDependents tel vs =+ loop empty (flattenTel tel) (size tel - 1) vs where- n = size tel- ts = flattenTel tel-- directDependents :: IntSet -> IntSet- directDependents is = IntSet.fromList- [ j | j <- downFrom n- , let tj = indexWithDefault __IMPOSSIBLE__ ts (n-1-j)- , getAny $ runFree (Any . (`IntSet.member` is)) IgnoreNot tj- ]-- allDependents :: IntSet -> IntSet- allDependents is- | null new = empty- | otherwise = new `IntSet.union` allDependents new- where new = directDependents is+ -- Idea here is to keep a set @work@ of variables that we+ -- want to find dependents of. At each iteration, we walk forwards through+ -- the telescope and check if the each telescope contains any of the+ -- variables in the work set. If it does, we add that variable to the work+ -- and dependents set.+ loop :: VarSet -> [Dom Type] -> Int -> VarSet -> VarSet+ loop !deps tel ix work =+ case tel of+ [] -> deps+ (ti:tel) ->+ if anyFreeVar (`VarSet.member` work) ti then+ loop (VarSet.insert ix deps) tel (ix - 1) (VarSet.insert ix work)+ else+ loop deps tel (ix - 1) work -- | A telescope split in two. data SplitTel = SplitTel { firstPart :: Telescope , secondPart :: Telescope , splitPerm :: Permutation- -- ^ The permutation takes us from the original telescope to+ -- ^ The permutation (of de Bruijn _levels_) that takes us from the original telescope to -- @firstPart ++ secondPart@. } @@ -246,16 +287,16 @@ n = size tel is = varDependencies tel fv- isC = IntSet.fromList [0..(n-1)] `IntSet.difference` is+ isC = VarSet.complement n is - perm = Perm n $ map (n-1-) $ VarSet.toDescList is ++ VarSet.toDescList isC+ perm = Perm n $! map' (n-1-) $! VarSet.toDescList is ++! VarSet.toDescList isC ts1 = renameP impossible (reverseP perm) (permute perm ts0) tel' = unflattenTel (permute perm names) ts1 - m = size is- (tel1, tel2) = telFromList -*- telFromList $ splitAt m $ telToList tel'+ m = VarSet.size is+ (tel1, tel2) = telFromList *** telFromList $ splitAt' m $ telToList tel' -- | As splitTelescope, but fails if any additional variables or reordering -- would be needed to make the first part well-typed.@@ -274,25 +315,22 @@ checkDependencies soFar [] = True checkDependencies soFar (j:js) = ok && checkDependencies (IntSet.insert j soFar) js where- t = indexWithDefault __IMPOSSIBLE__ ts0 (n-1-j) -- ts0[n-1-j]- -- Skip the construction of intermediate @IntSet@s in the check @ok@.- -- ok = (allFreeVars t `IntSet.intersection` IntSet.fromAscList [ 0 .. n-1 ])- -- `IntSet.isSubsetOf` soFar- good i = All $ (i < n) `implies` (i `IntSet.member` soFar) where implies = (<=)- ok = getAll $ runFree good IgnoreNot t+ t = indexWithDefault __IMPOSSIBLE__ ts0 (n-1-j) -- ts0[n-1-j]+ good i = (i < n) `implies` (i `IntSet.member` soFar) where implies = (<=)+ ok = allFreeVar good t ok = all (< n) is && checkDependencies IntSet.empty is isC = downFrom n List.\\ is - perm = Perm n $ map (n-1-) $ is ++ isC+ perm = Perm n $ map' (n-1-) $ is ++! isC ts1 = renameP impossible (reverseP perm) (permute perm ts0) tel' = unflattenTel (permute perm names) ts1 m = size is- (tel1, tel2) = telFromList -*- telFromList $ splitAt m $ telToList tel'+ (tel1, tel2) = telFromList *** telFromList $ splitAt' m $ telToList tel' -- | Try to instantiate one variable in the telescope (given by its de Bruijn -- level) with the given value, returning the new telescope and a@@ -304,51 +342,53 @@ -> DeBruijnPattern -- ^ Γ ⊢ u : A -> Maybe (Telescope, -- ⊢ Γ' PatternSubstitution, -- Γ' ⊢ σ : Γ- Permutation) -- Γ ⊢ flipP ρ : Γ'-instantiateTelescope tel k p = guard ok $> (tel', sigma, rho)+ Permutation) -- reordering of Γ applied before instantiating+ -- (works on de Bruijn _levels_)+instantiateTelescope tel k p = guard ok $> (tel', sigma, reverseP perm) where names = teleNames tel ts0 = flattenTel tel n = size tel- j = n-1-k+ j = n-1-k -- de Bruijn index u = patternToTerm p -- Jesper, 2019-12-31: Previous implementation that does some -- unneccessary reordering but is otherwise correct (keep!) -- -- is0 is the part of Γ that is needed to type u- -- is0 = varDependencies tel $ allFreeVars u+ -- is0 = varDependencies tel $ freeVarSet u -- -- is1 is the rest of Γ (minus the variable we are instantiating) -- is1 = IntSet.delete j $ -- IntSet.fromAscList [ 0 .. n-1 ] `IntSet.difference` is0 -- -- we work on de Bruijn indices, so later parts come first- -- is = IntSet.toAscList is1 ++ IntSet.toAscList is0+ -- is = IntSet.toAscList is1 ++! IntSet.toAscList is0 -- -- if u depends on var j, we cannot instantiate -- ok = not $ j `IntSet.member` is0 -- is0 is the part of Γ that is needed to type u- is0 = varDependencies tel $ allFreeVars u+ is0 = varDependencies tel $ freeVarSet u -- is1 is the part of Γ that depends on variable j is1 = varDependents tel $ singleton j -- lasti is the last (rightmost) variable of is0- lasti = if null is0 then n else IntSet.findMin is0+ lasti = fromMaybe n $ VarSet.lookupMin is0 -- we move each variable in is1 to the right until it comes after -- all variables in is0 (i.e. after lasti)- (as,bs) = List.partition (`IntSet.member` is1) [ n-1 , n-2 .. lasti ]- is = reverse $ List.delete j $ bs ++ as ++ downFrom lasti+ (as,bs) = List.partition (`VarSet.member` is1) [ n-1 , n-2 .. lasti ]+ is = reverse $ bs ++! as ++! downFrom lasti+ perm = Perm n is -- works on de Bruijn indices -- if u depends on var j, we cannot instantiate- ok = not $ j `IntSet.member` is0+ ok = not $ j `VarSet.member` is0 - perm = Perm n $ is -- works on de Bruijn indices- rho = reverseP perm -- works on de Bruijn levels+ perm' = deleteP j perm -- works on de Bruijn indices+ permL' = reverseP perm' -- works on de Bruijn levels - p1 = renameP impossible perm p -- Γ' ⊢ p1 : A'- us = map (\i -> maybe p1 deBruijnVar (List.elemIndex i is)) [ 0 .. n-1 ]- sigma = us ++# raiseS (n-1)+ j' = fromMaybe __IMPOSSIBLE__ $ lookupRP perm j+ p1 = renameP impossible perm' p -- Γ' ⊢ p1 : A'+ sigma = singletonS j' p1 `composeS` renaming impossible perm -- Γ' ⊢ σ : Г - ts1 = permute rho $ applyPatSubst sigma ts0- tel' = unflattenTel (permute rho names) ts1+ ts1 = permute permL' $ applyPatSubst sigma ts0+ tel' = unflattenTel (permute permL' names) ts1 -- Γ' -- | Try to eta-expand one variable in the telescope (given by its de Bruijn -- level)@@ -372,8 +412,9 @@ = False , conPType = Just $ argFromDom a , conPLazy = True+ , conPPrio = MatchPrio 0 }- cargs = map (setOrigin Inserted) $ teleNamedArgs delta+ cargs = map' (setOrigin Inserted) $ teleNamedArgs delta cdelta = ConP c cpi cargs -- Γ₁Δ ⊢ c Δ : D pars rho0 = consS cdelta $ raiseS (size delta) -- Γ₁Δ ⊢ ρ₀ : Γ₁(x : D pars) rho = liftS (size ts2) rho0 -- Γ₁ΔΓ₂ρ₀ ⊢ ρ : Γ₁(x : D pars)Γ₂@@ -408,9 +449,23 @@ -- 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+ underAbstractionAbs (dropInvalidRew a) b $+ \b -> telViewUpTo' (n - 1) p b _ -> return $ TelV EmptyTel t+ where+ -- We drop invalidated local rewrite rules+ -- Note that the returned telescope might still contain invalidated+ -- rewrite rules so adding the telescope to the context might fail+ dropInvalidRew a = if invalidRew a then a & dRew .~ Nothing else a +-- | Returns Nothing if there are invalidated local rewrite rules present in+-- the telescope+safeTelViewUpTo' :: (MonadReduce m, MonadAddContext m)+ => Int -> (Dom Type -> Bool) -> Type -> MaybeT m TelView+safeTelViewUpTo' n p t = do+ telv@(TelV tel _) <- telViewUpTo' n p t+ if any invalidRew tel then mzero else pure telv+ {-# INLINE telViewPath #-} telViewPath :: PureTCM m => Type -> m TelView telViewPath = telViewUpToPath (-1)@@ -447,14 +502,14 @@ -- | Turn dimension variables @i@ into dimension expressions @'var' i@. tmBoundary :: Boundary' Int a -> Boundary' Term a-tmBoundary = Boundary . map (first var) . theBoundary+tmBoundary = Boundary . map' (first var) . theBoundary -- | Turn dimension expressions into dimension variables. -- Formally this is a partial operation, but should only be called when the precondition is met. -- -- Precondition: the dimension terms in the boundary are all of the form @'var' i@. varBoundary :: Boundary' Term a -> Boundary' Int a-varBoundary = Boundary . map (first unVar) . theBoundary+varBoundary = Boundary . map' (first unVar) . theBoundary where unVar (Var i []) = i unVar _ = __IMPOSSIBLE__@@ -498,7 +553,8 @@ recurse a b = first (absV a (absName b)) <$> do underAbstractionAbs a b $ \b -> telViewUpToPathBoundary' (n - 1) b addEndPoints xy (telv@(TelV tel _), Boundary cs) =- (telv, Boundary $ (size tel - 1, raise (size tel) xy) : cs)+ let !s = size tel - 1+ in (telv, Boundary $ (s, raise (size tel) xy) : cs) fullBoundary :: Telescope -> Boundary -> Boundary@@ -512,7 +568,7 @@ -- Δ.Γ | PiPath Γ bs A ⊢ teleElims tel bs : b let es = teleElims tel bs l = size tel- in Boundary $ map (\ (i, xy) -> (i, xy `applyE` (drop (l - i) es))) $ theBoundary bs+ in Boundary $ map' (\ (i, xy) -> (i, xy `applyE` (drop (l - i) es))) $ theBoundary bs {-# SPECIALIZE telViewUpToPathBoundary :: Int -> Type -> TCM (TelView, Boundary) #-} -- | @(TelV Γ b, [(i,t_i,u_i)]) <- telViewUpToPathBoundary n a@@@ -537,8 +593,8 @@ -- Δ.Γ ⊢ bs = [ (i=0) -> t_i; (i=1) -> u_i ] : T -- Output: Δ.Γ | PiPath Γ bs A ⊢ es : A teleElims :: DeBruijn a => Telescope -> Boundary' Int a -> [Elim' a]-teleElims tel (Boundary []) = map Apply $ teleArgs tel-teleElims tel (Boundary boundary) = map updateArg $ teleArgs tel+teleElims tel (Boundary []) = map' Apply $ teleArgs tel+teleElims tel (Boundary boundary) = map' updateArg $ teleArgs tel where matchVar i = snd <$> find ((i ==) . fst) boundary updateArg a@(Arg info p) =@@ -724,7 +780,7 @@ piApplyM' err t = piApplyM' err t . namedThing instance PiApplyM a => PiApplyM [a] where- piApplyM' err t = foldl (\ mt v -> mt >>= \t -> (piApplyM' err t v)) (return t)+ piApplyM' err t = foldl' (\ mt v -> mt >>= \t -> (piApplyM' err t v)) (return t) -- | Compute type arity
src/full/Agda/TypeChecking/Telescope/Path.hs view
@@ -18,7 +18,6 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope -import Agda.Utils.Functor import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Size@@ -129,7 +128,7 @@ {-# SPECIALIZE isInterval :: Type -> TCM Bool #-} -- | Check whether a type is the built-in interval type.-isInterval :: (MonadTCM m, MonadReduce m) => Type -> m Bool+isInterval :: (MonadTCM m) => Type -> m Bool isInterval t = liftTCM $ do caseMaybeM (getName' builtinInterval) (return False) $ \ i -> do reduce (unEl t) <&> \case
src/full/Agda/TypeChecking/Unquote.hs view
@@ -2,8 +2,7 @@ import Prelude hiding (null) -import Control.Arrow ( first, second, (&&&) )-import Control.Monad ( (<=<) )+import Control.Monad ( (<=<), filterM ) import Control.Monad.Except ( MonadError(..), ExceptT(..), runExceptT ) import Control.Monad.IO.Class ( MonadIO(..) ) import Control.Monad.Reader ( ReaderT(..), runReaderT )@@ -12,6 +11,7 @@ import Control.Monad.Trans ( lift ) import Data.Char+import Data.Containers.ListUtils ( nubOrd ) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe, mapMaybe)@@ -40,12 +40,12 @@ import Agda.Syntax.Position import Agda.Syntax.Info as Info import Agda.Syntax.Translation.ReflectedToAbstract-import Agda.Syntax.Scope.Base (KindOfName(ConName, DataName)- , scopeLocals, LocalVar(LocalVar), BindingSource(MacroBound) )+import Agda.Syntax.Scope.Base ( scopeLocals, LocalVar(LocalVar), BindingSource(MacroBound) ) import Agda.Syntax.Parser import Agda.Interaction.Library ( ExeName ) import Agda.Interaction.Options ( optTrustedExecutables, optAllowExec )+import Agda.Interaction.Options.Lenses qualified as Lens import qualified Agda.TypeChecking.Monad.Benchmark as Bench import Agda.TypeChecking.Constraints@@ -69,14 +69,14 @@ import {-# SOURCE #-} Agda.TypeChecking.Rules.Decl import Agda.TypeChecking.Rules.Data -import Agda.Utils.CallStack ( HasCallStack )+import Agda.Utils.CallStack ( HasCallStack ) import Agda.Utils.Either import Agda.Utils.Lens-import Agda.Utils.List1 (List1, pattern (:|))-import qualified Agda.Utils.List1 as List1+import Agda.Utils.List1 ( List1, pattern (:|))+import Agda.Utils.List1 qualified as List1 import Agda.Utils.Monad import Agda.Utils.Null-import qualified Agda.Interaction.Options.Lenses as Lens+import Agda.Utils.Tuple ( first, second, (&&&) ) import Agda.Utils.Impossible @@ -96,6 +96,23 @@ -- definitions. Also state snapshot from last commit and whether the state is -- dirty (definitions have been added). type UnquoteState = (Dirty, TCState)++-- | The monad for running reflected 'TC' computations.+--+-- * Reader: the context at the point the meta-program was invoked.+-- New top-level definitions are added in this context (see 'inOriginalContext').+--+-- * State: see 'UnquoteState'.+--+-- * Writer: the names /declared/ by the meta-program via+-- @declareDef@, @declarePostulate@, or @declareData@.+-- Each of these names must also be /defined/ by the time the meta-program finishes;+-- this is checked by 'runUnquoteM'.+-- If a declaration is rolled back (by @runSpeculative@),+-- the name is removed from this list again.+--+-- * Exception: 'UnquoteError's, which are not caught by @catchTC@.+-- type UnquoteM = ReaderT Context (StateT UnquoteState (WriterT [QName] (ExceptT UnquoteError TCM))) type UnquoteRes a = Either UnquoteError ((a, UnquoteState), [QName])@@ -106,33 +123,46 @@ packUnquoteM :: (Context -> UnquoteState -> TCM (UnquoteRes a)) -> UnquoteM a packUnquoteM f = ReaderT $ \ cxt -> StateT $ \ s -> WriterT $ ExceptT $ f cxt s -runUnquoteM :: UnquoteM a -> TCM (Either UnquoteError (a, [QName]))-runUnquoteM m = do+-- | @runUnquoteM xs m@ runs the meta-program @m@.+--+-- If @m@ completes successfully, we check that the names @xs@+-- (e.g. the ones of an @unquoteDecl@ or @unquoteDef@)+-- as well as all the names declared by @m@ have received a definition.+-- Otherwise, we throw a 'MissingDefinition' error.+--+runUnquoteM :: [QName] -> UnquoteM a -> TCM (Either UnquoteError a)+runUnquoteM xs m = do cxt <- getContext s <- getTC pid <- fresh -- Create a fresh problem for the unquote call. Used in tcSolveInstances.- z <- localTC (\ e -> e { envUnquoteProblem = Just pid })- $ solvingProblem pid- $ unpackUnquoteM m cxt (Clean, s)+ z <- localTC (set eUnquoteProblem (Just pid)) $+ solvingProblem pid $ unpackUnquoteM m cxt (Clean, s) case z of Left err -> return $ Left err- Right ((v, _), decls) -> Right (v, decls) <$ mapM_ isDefined decls+ Right ((v, _), decls) -> do+ missing <- filterM isUndefined $ nubOrd $ xs ++ decls+ List1.unlessNull missing \ ys -> unquoteError $ MissingDefinition ys+ return $ Right v where- isDefined x = do- getConstInfo x <&> theDef >>= \case- FunctionDefn FunctionData{ _funClauses = cl } -> when (null cl) $- unquoteError $ MissingDefinition x+ isUndefined :: QName -> TCM Bool+ isUndefined x = getConstInfo' x >>= \case+ -- Names not in the signature have not been declared.+ Left _ -> return True+ Right def -> return case theDef def of+ -- Functions need at least one clause to be defined.+ FunctionDefn FunctionData{ _funClauses = cl } -> null cl+ -- A data or record type that has only been declared but not defined.+ DataOrRecSigDefn {} -> True -- Andreas, 2024-10-11: -- some of the following cases might be __IMPOSSIBLE__- AxiomDefn {} -> return ()- DataOrRecSigDefn {} -> return ()- GeneralizableVar {} -> return ()- AbstractDefn {} -> return ()- DatatypeDefn {} -> return ()- RecordDefn {} -> return ()- ConstructorDefn {} -> return ()- PrimitiveDefn {} -> return ()- PrimitiveSortDefn {} -> return ()+ AxiomDefn {} -> False+ GeneralizableVar {} -> False+ AbstractDefn {} -> False+ DatatypeDefn {} -> False+ RecordDefn {} -> False+ ConstructorDefn {} -> False+ PrimitiveDefn {} -> False+ PrimitiveSortDefn {} -> False liftU1 :: (TCM (UnquoteRes a) -> TCM (UnquoteRes b)) -> UnquoteM a -> UnquoteM b liftU1 f m = packUnquoteM $ \ cxt s -> f (unpackUnquoteM m cxt s)@@ -375,7 +405,7 @@ instance (Unquote a, Unquote b) => Unquote (a, b) where unquote t = do t <- reduceQuotedTerm t- SigmaKit{..} <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit+ SigmaKit{ sigmaCon } <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit case t of Con c _ es | Just [x,y] <- allApplyElims es -> choice@@ -769,7 +799,7 @@ tcFormatErrorParts msg = quoteString . prettyShow <$> renderErrorParts msg tcTypeError :: [ErrorPart] -> TCM a- tcTypeError err = typeError . GenericDocError =<< renderErrorParts err+ tcTypeError err = typeError . UserError =<< renderErrorParts err tcDebugPrint :: Text -> Integer -> [ErrorPart] -> TCM Term tcDebugPrint s n msg = do@@ -870,7 +900,7 @@ tcGetContext = liftTCM $ do r <- isReconstructed let getVar (CtxVar x a) = (nameToArgName x, a)- as <- map getVar <$> getContext+ as <- map getVar . cxEntries <$> getContext as <- etaContract =<< process as if r then do as <- recons (reverse as)@@ -880,7 +910,7 @@ where recons :: [(ArgName, Dom Type)] -> TCM [(ArgName, Dom Type)] recons [] = return []- recons ((s, d@Dom {unDom=t}):ds) = do+ recons ((s, d@(unDom -> t)):ds) = do t <- locallyReduceAllDefs $ reconstructParametersInType t let d' = d{unDom=t} ds' <- addContext (s, d') $ recons ds@@ -898,7 +928,11 @@ locallyScope scopeLocals ((simpleName (T.unpack s') , LocalVar s MacroBound []) :) $ liftU1 (addContext (s, domFromArg a :: Dom Type)) m - tcExtendContext :: Term -> Term -> Term -> UnquoteM Term+ tcExtendContext ::+ Term -- Name of the variable introduced into the context.+ -> Term -- Type of this variable.+ -> Term -- Computation to run in the extended context.+ -> UnquoteM Term -- Result in the original context. tcExtendContext s a m = do s <- unquote s a <- unquote a@@ -906,9 +940,7 @@ v <- evalTCM $ raise 1 m -- 2024-04-20: free variable analysis only really makes sense on normal forms; see #7227 v <- normalise v- when (freeIn 0 v) $ liftTCM $ genericDocError =<<- hcat ["Local variable '", prettyTCM (var 0), "' escaping in result of extendContext:"]- <?> prettyTCM v+ when (freeIn 0 v) . throwError . EscapingVariable =<< buildClosure v return v tcInContext :: Term -> Term -> UnquoteM Term@@ -981,7 +1013,7 @@ reconsTel :: Telescope -> TCM Telescope reconsTel EmptyTel = return EmptyTel reconsTel (ExtendTel _ NoAbs{}) = __IMPOSSIBLE__- reconsTel (ExtendTel (d@Dom{unDom=t}) ds@Abs{unAbs=ts}) = do+ reconsTel (ExtendTel (d@(unDom->t)) ds@Abs{unAbs=ts}) = do t <- locallyReduceAllDefs $ reconstructParametersInType t let d' = d{unDom=t} ts' <- addContext d' $ reconsTel ts@@ -1004,9 +1036,9 @@ a <- locallyReduceAllDefs $ isType_ =<< toAbstract_ a getConstInfo' x >>= \case Left _ -> pure ()- Right def -> typeError $ ClashingDefinition (qnameToConcrete x) (defName def) Nothing+ Right def -> typeError $ ClashingDefinition (qnameToConcrete x) (ClashingQName $ defName def) Nothing addConstant' x i a defn- when (isInstance i) $ addTypedInstance x a+ when (isInstance i) $ addTypedInstance empty x a primUnitUnit tcDeclareDef :: Arg QName -> R.Type -> UnquoteM Term@@ -1030,7 +1062,7 @@ ] getConstInfo' x >>= \case Left _ -> pure ()- Right def -> liftTCM $ typeError $ ClashingDefinition (qnameToConcrete x) (defName def) Nothing+ Right def -> liftTCM $ typeError $ ClashingDefinition (qnameToConcrete x) (ClashingQName $ defName def) Nothing e <- liftTCM $ toAbstract_ t -- The type to be checked with @checkSig@ is without parameters. (tel, e') <- splitPars (fromInteger npars) e@@ -1044,8 +1076,8 @@ Left _ -> throwError $ MissingDeclaration x Right def -> do npars <- case theDef def of- DataOrRecSig n -> return n- _ -> throwError $ DefineDataNotData x+ DataOrRecSig n IsData -> return n+ _ -> throwError $ DefineDataNotData x -- For some reasons, reifying parameters and adding them to the context via -- `addContext` before `toAbstract_` is different from substituting the type after@@ -1076,7 +1108,7 @@ [ "checking datatype: " <+> prettyTCM x <+> " with constructors:" , nest 2 (vcat (map prettyTCM conNames)) ]- liftTCM $ checkDataDef i x YesUniverseCheck (A.DataDefParams Set.empty lams) as+ liftTCM $ checkDataDef i x YesPositivityCheck YesUniverseCheck (A.DataDefParams Set.empty lams) as liftTCM primUnitUnit where addDummy :: Int -> R.Type -> R.Type@@ -1129,13 +1161,16 @@ tcRunSpeculative :: Term -> UnquoteM Term tcRunSpeculative mu = do oldState <- getTC- u <- reduce =<< evalTCM mu- case u of- Con _ _ [Apply (Arg { unArg = x }), Apply (Arg { unArg = b })] -> do- unlessM (unquote b) $ putTC oldState- return x- _ -> liftTCM $ typeError . GenericDocError =<<- "Should be a pair: " <+> prettyTCM u+ -- If we roll back, we also forget the names declared in the speculative run.+ pass do+ u <- reduce =<< evalTCM mu+ case u of+ Con _ _ [Apply (Arg { unArg = x }), Apply (Arg { unArg = b })] -> do+ ifM (unquote b) (return (x, id)) do+ putTC oldState+ return (x, const [])+ _ -> liftTCM $ typeError . UserError =<<+ "Should be a pair: " <+> prettyTCM u tcGetInstances :: MetaId -> UnquoteM Term tcGetInstances m = liftTCM (getInstanceCandidates m) >>= \case@@ -1149,8 +1184,8 @@ tcSolveInstances = liftTCM $ do locallyTCState stPostponeInstanceSearch (const False) $ do -- Steal instance constraints (TODO: not all!)- current <- asksTC envActiveProblems- topPid <- fromMaybe __IMPOSSIBLE__ <$> asksTC envUnquoteProblem+ current <- viewTC eActiveProblems+ topPid <- fromMaybe __IMPOSSIBLE__ <$> viewTC eUnquoteProblem let steal pc@(PConstr pids u c) | isInstance pc , Set.member topPid pids = PConstr (Set.union current pids) u c
src/full/Agda/TypeChecking/Warnings.hs view
@@ -26,11 +26,12 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Data.Maybe ( catMaybes )-import Data.Semigroup ( Semigroup, (<>) )+import Data.Text qualified as Text import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Debug-import Agda.TypeChecking.Monad.Caching+import Agda.TypeChecking.Monad.Caching ( areWeCaching )+import {-# SOURCE #-} Agda.TypeChecking.Monad.State () -- instance MonadFileId TCM import {-# SOURCE #-} Agda.TypeChecking.Pretty ( MonadPretty, prettyTCM, vcat, ($$) ) import {-# SOURCE #-} Agda.TypeChecking.Pretty.Call import {-# SOURCE #-} Agda.TypeChecking.Pretty.Warning ( prettyWarning )@@ -39,11 +40,14 @@ import qualified Agda.Syntax.Common.Pretty as P import Agda.Syntax.Position import Agda.Syntax.Parser+import Agda.Syntax.Internal.Blockers (neverUnblock) import Agda.Interaction.Options import Agda.Interaction.Options.Warnings import {-# SOURCE #-} Agda.Interaction.Highlighting.Generate (highlightWarning) +import Agda.Version ( docsUrl )+ import Agda.Utils.CallStack ( CallStack, HasCallStack, withCallerCallStack ) import Agda.Utils.Function ( applyUnless ) import Agda.Utils.Lens@@ -55,7 +59,6 @@ import Agda.Utils.Impossible - -- * The warning monad --------------------------------------------------------------------------- @@ -78,13 +81,18 @@ instance (MonadWarning m, Monoid w) => MonadWarning (WriterT w m) instance MonadWarning TCM where- addWarning enabled tcwarn = do- stTCWarnings `modifyTCLens` Set.insert tcwarn- -- Andreas, 2025-04-01, issue #6994, no highlighting for disabled warnings- when enabled $ highlightWarning tcwarn+ addWarning enabled tcwarn = ifImpureConv+ (do stTCWarnings `modifyTCLens` Set.insert tcwarn+ -- Andreas, 2025-04-01, issue #6994, no highlighting for disabled warnings+ when enabled $ highlightWarning tcwarn)+ (case classifyWarning (tcWarning tcwarn) of+ ErrorWarnings -> patternViolation neverUnblock+ AllWarnings -> return ()) -- * Raising warnings ---------------------------------------------------------------------------+warnUrl :: String -> String+warnUrl = docsUrl . ("tools/command-line-options.html#cmdoption-arg-" ++) {-# SPECIALIZE warning'_ :: CallStack -> Warning -> TCM TCWarning #-} warning'_ :: (MonadWarning m) => CallStack -> Warning -> m TCWarning@@ -101,12 +109,13 @@ InteractionMetaBoundaries rs -> getRange rs _ -> r let wn = warningName w- let ws = warningName2String wn+ let ws = warningNameToString wn+ let wref = P.href (Text.pack (warnUrl ws)) (P.text ws) p <- vcat [ pure $ P.hsep- [ if null r' then mempty else P.pretty r' P.<> P.colon- , if wn `elem` errorWarnings then "error:" P.<+> P.brackets (P.text ws)- else P.text $ "warning: -W[no]" ++ ws+ [ if null r' then mempty else P.pretty r' <> P.colon+ , if wn `elem` errorWarnings then "error:" P.<+> P.brackets wref+ else "warning: -W[no]" <> wref -- Only benign warnings can be deactivated with -WnoXXX. ] , prettyWarning w@@ -162,7 +171,7 @@ -- | Raise every 'WARNING_ON_USAGE' connected to a name. {-# SPECIALIZE raiseWarningsOnUsage :: QName -> TCM () #-}-raiseWarningsOnUsage :: (MonadWarning m, ReadTCState m) => QName -> m ()+raiseWarningsOnUsage :: (MonadWarning m) => QName -> m () raiseWarningsOnUsage d = do -- In case we find a defined name, we start by checking whether there's -- a warning attached to it
src/full/Agda/TypeChecking/With.hs view
@@ -101,7 +101,7 @@ splitTelForWith delta t vtys = let -- Split the telescope into the part needed to type the with arguments -- and all the other stuff.- fv = allFreeVars vtys+ fv = freeVarSet vtys SplitTel delta1 delta2 perm = splitTelescope fv delta -- Δ₁Δ₂ ⊢ π : Δ@@ -389,7 +389,8 @@ ] -- Andreas, 2015-11-09 Issue 1710: self starts with parent-function, not with-function!- (ps', strippedPats) <- runWriterT $ strip (Def parent []) t psi qs+ (ps', strippedPats) <- runWriterT $ addContext delta $+ strip (Def parent []) t psi qs unless (null strippedPats) $ reportSDoc "tc.with.strip" 50 $ nest 2 $ "strippedPats:" <+> vcat [ prettyA p <+> "=" <+> prettyTCM v <+> ":" <+> prettyTCM a | A.ProblemEq p v a <- strippedPats ] let psp = permute perm ps'@@ -464,9 +465,9 @@ ] case namedArg q of ProjP o d -> case A.isProjP p of- Just (o', AmbQ ds) -> do+ Just (o', ambP) -> do -- We assume here that neither @o@ nor @o'@ can be @ProjSystem@.- when (o /= o') $ setCurrentRange p0 $ addContext delta do+ when (o /= o') $ setCurrentRange p0 $ do reportSLn "tc.with.strip" 90 $ "p0 = " ++ show p0 reportSLn "tc.with.strip" 80 $ "getRange p0 = " ++ prettyShow (getRange p0) warning $ WithClauseProjectionFixityMismatch p0 o' q o@@ -474,7 +475,7 @@ -- We disambiguate the projection in the with clause -- to the projection in the parent clause. d <- liftTCM $ getOriginalProjection d- found <- existsM ds $ \ d' -> liftTCM $ (Just d ==) . fmap projOrig <$> isProjection d'+ found <- existsM (getAmbiguous ambP) $ \ d' -> liftTCM $ (Just d ==) . fmap projOrig <$> isProjection d' if not found then mismatch else do (self1, t1, ps) <- liftTCM $ do t <- reduce t@@ -531,9 +532,8 @@ case appView e of -- If dot-pattern is an application of the constructor, try to preserve the -- arguments.- Application (A.Con (A.AmbQ cs')) es -> do- cs' <- liftTCM $ List1.rights <$> mapM getConForm cs'- unless (c `elem` cs') mismatch+ Application (A.Con cs') es -> do+ unlessM (liftTCM $ c `elemConForms` cs') mismatch return $ (map . fmap . fmap) (A.DotP r) es _ -> return $ map (unnamed (A.WildP empty) <$) qs' stripConP d us b c ConOCon qs' ps'@@ -556,18 +556,17 @@ let ps' = map (unnamed (A.WildP empty) <$) qs' stripConP d us b c ConOCon qs' ps' - A.ConP _ (A.AmbQ cs') ps' -> do+ A.ConP _ ambC ps' -> do -- Check whether the with-clause constructor can be (possibly trivially) -- disambiguated to be equal to the parent-clause constructor. -- Andreas, 2017-08-13, herein, ignore abstract constructors.- cs' <- liftTCM $ List1.rights <$> mapM getConForm cs'- unless (c `elem` cs') mismatch+ unlessM (liftTCM $ c `elemConForms` ambC) mismatch -- Strip the subpatterns ps' and then continue. stripConP d us b c ConOCon qs' ps' A.RecP _ _ fs -> caseMaybeM (liftTCM $ isRecord d) mismatch $ \ def -> do ps' <- liftTCM $ insertMissingFieldsFail d (const $ A.WildP empty) fs- (map argFromDom $ recordFieldNames def)+ (map argFromDom $ recordFieldNames def) stripConP d us b c ConORec qs' ps' p@(A.PatternSynP pi' c' ps') -> do@@ -599,8 +598,8 @@ (e, t') <- piOrPathApplyM t v strip (self `applyE` e) t' ps qs - mismatch :: forall m a. (MonadAddContext m, MonadTCError m) => m a- mismatch = addContext delta $ typeError $+ mismatch :: forall m a. MonadTCError m => m a+ mismatch = typeError $ WithClausePatternMismatch (namedArg p0) q -- Make a WildP, keeping arg. info.@@ -658,6 +657,14 @@ -- Keep going strip self' t' psi (qs' ++ qs)++-- | Is the first name equal to the 'constructorForm' of any disambiguation of the second name?+elemConForms :: ConHead -> AmbiguousQName -> TCM Bool+elemConForms c cs =+ existsM (getAmbiguous cs) \ c' ->+ getConForm c' <&> \case+ Left{} -> False+ Right c' -> c == c' -- | Construct the display form for a with function. It will display -- applications of the with function as applications to the original function.
src/full/Agda/Utils/AssocList.hs view
@@ -11,8 +11,8 @@ import Data.Function (on) import Data.List (lookup)-import qualified Data.List as List-import qualified Data.Map as Map+import Data.List qualified as List+import Data.Map qualified as Map import Agda.Utils.Tuple @@ -94,4 +94,4 @@ -- To preserve the invariant, it is sufficient that the key -- transformation is injective (rather than monotonic). mapKeysMonotonic :: (k -> k') -> AssocList k v -> AssocList k' v-mapKeysMonotonic f = map $ mapFst f+mapKeysMonotonic f = map $ first f
+ src/full/Agda/Utils/Atomic.hs view
@@ -0,0 +1,75 @@+-- | Wrappers around 'MVar's which provides an atomic modification operation.+module Agda.Utils.Atomic+ ( Atomic+ , newAtomic+ , readAtomic+ , modifyAtomic+ , withAtomic+ )+ where++import Control.Monad.IO.Class+import Control.Monad.Catch+import Control.DeepSeq++import Control.Concurrent+import Control.Exception (evaluate)++-- | A mutable variable which can be read from and *modified*.+-- This provides a 'modifyAtomic' combinator with atomic semantics for+-- modification, unlike 'modifyMVar'.+newtype Atomic a = Atomic { unAtomic :: MVar a }+ deriving (Eq, NFData)++-- Implementation note: the caveat to modifyMVar's atomicity is that it+-- is possible for another thread to have a *different* value of 'a',+-- which they can 'putMVar', while the continuation to 'modifyMVar' is+-- executing (since the variable is left in the empty state for its+-- duration). This would block the call to 'modifyMVar' after the end of+-- the continuation.+--+-- By contrast, we simply do not export a "put" variant of writing to an+-- atomic. This should, hopefully, be enough to ensure atomicity.++-- | Create a new atomic variable with the given initial value.+newAtomic :: MonadIO m => a -> m (Atomic a)+newAtomic = liftIO . fmap Atomic . newMVar++-- | Read the current state of the atomic variable, waiting if any other+-- thread is modifying it.+--+-- Like 'readMVar', 'readAtomic' is multiple-wakeup, which means that+-- all threads waiting on a modification will be woken up when it+-- finishes.+readAtomic :: MonadIO m => Atomic a -> m a+readAtomic = liftIO . readMVar . unAtomic+{-# INLINE readAtomic #-}++-- | Modify the contents of an atomic variable. If the continuation+-- fails, or receives an asynchronous exception, the variable is+-- returned to its old state.+--+-- No thread, *including the calling thread*, can access the contents of+-- the same 'Atomic' while this function is executing, for reading *or*+-- writing. This means that *any* nested use of the variable, as in+--+-- @+-- f var = modifyAtomic var \old ->+-- -- ...+-- modifyAtomic var \old' -> ... -- (!)+-- readAtomic var -- (!)+-- @+--+-- will result in a deadlock. The new state of the variable is evaluated+-- (to WHNF).+modifyAtomic :: (MonadIO m, MonadMask m) => Atomic a -> (a -> m (a, b)) -> m b+modifyAtomic (Atomic var) k = mask \restore -> do+ old <- liftIO $ takeMVar var+ (new, ret) <- restore (k old >>= liftIO . evaluate)+ `onException` liftIO (putMVar var old)+ ret <$ liftIO (putMVar var $! new)++{-# SPECIALISE modifyAtomic :: Atomic a -> (a -> IO (a, b)) -> IO b #-}++withAtomic :: (MonadIO m, MonadMask m) => Atomic a -> (a -> m ()) -> m ()+withAtomic var k = modifyAtomic var \val -> (val,) <$> k val
src/full/Agda/Utils/Bag.hs view
@@ -6,17 +6,17 @@ import Prelude hiding (null, map) -import Text.Show.Functions () -- instance only+import Text.Show.Functions () -- instance only -import qualified Data.List as List-import Data.List.NonEmpty ( NonEmpty, pattern (:|) )-import qualified Data.List.NonEmpty as List1- -- NB: Not importing Agda.Utils.List1 to avoid import cycles.-import Data.Map ( Map )-import qualified Data.Map as Map-import Data.Semigroup+-- NB: Not importing Agda.Utils.List1 to avoid import cycles.+import Data.List qualified as List+import Data.List.NonEmpty ( NonEmpty, pattern (:|) )+import Data.List.NonEmpty qualified as List1+import Data.Map ( Map )+import Data.Map qualified as Map+import Data.Semigroup ( Sum(..) ) -import Agda.Utils.Functor+import Agda.Utils.Functor -- | A set with duplicates. -- Faithfully stores elements which are equal with regard to (==).
src/full/Agda/Utils/Benchmark.hs view
@@ -7,7 +7,7 @@ import Prelude hiding (null) import Control.DeepSeq-import qualified Control.Exception as E (evaluate)+import Control.Exception qualified as E (evaluate) import Control.Monad.Except import Control.Monad.Reader import Control.Monad.Writer@@ -16,22 +16,23 @@ import Data.Function (on)-import qualified Data.List as List+import Data.List qualified as List import Data.Monoid import Data.Maybe import GHC.Generics (Generic) -import qualified Text.PrettyPrint.Boxes as Boxes+import Text.PrettyPrint.Boxes qualified as Boxes import Agda.Utils.ListT import Agda.Utils.Null import Agda.Utils.Monad hiding (finally)-import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.Maybe.Strict qualified as Strict import Agda.Syntax.Common.Pretty import Agda.Utils.Time import Agda.Utils.Trie (Trie)-import qualified Agda.Utils.Trie as Trie+import Agda.Utils.Trie qualified as Trie+import Agda.Utils.StrictReader qualified as Strict -- * Benchmark trie@@ -157,6 +158,14 @@ finally m f = ReaderT $ \ r -> finally (m `runReaderT` r) (f `runReaderT` r) +instance MonadBench m => MonadBench (Strict.ReaderT r m) where+ type BenchPhase (Strict.ReaderT r m) = BenchPhase m+ getBenchmark = lift $ getBenchmark+ putBenchmark = lift . putBenchmark+ modifyBenchmark = lift . modifyBenchmark+ finally m f = Strict.ReaderT $ \ r ->+ finally (m `Strict.runReaderT` r) (f `Strict.runReaderT` r)+ instance (MonadBench m, Monoid w) => MonadBench (WriterT w m) where type BenchPhase (WriterT w m) = BenchPhase m getBenchmark = lift $ getBenchmark@@ -244,5 +253,15 @@ -- NFData instances. -instance NFData a => NFData (BenchmarkOn a) instance NFData a => NFData (Benchmark a)++-- Andreas, 2025-07-31:+-- Generic derivation of NFData with embedded function spaces+-- throws deprecation warning in GHC 9.10.3 (deepseq-1.5.2.0),+-- see https://github.com/haskell/deepseq/issues/111 ,+-- so we spell it out.+instance NFData (BenchmarkOn a) where+ rnf = \case+ BenchmarkOff -> ()+ BenchmarkOn -> ()+ BenchmarkSome _fun -> () -- functions cannot be normalized
src/full/Agda/Utils/BiMap.hs view
@@ -15,9 +15,9 @@ import Control.Monad.State import Data.Function (on)-import qualified Data.List as List+import Data.List qualified as List import Data.Map (Map)-import qualified Data.Map as Map+import Data.Map qualified as Map import Data.Maybe import Data.Ord import Data.Tuple@@ -137,7 +137,7 @@ -- for which @k ≠ k'@ and @'tag' v = 'tag' v'@. insertPrecondition ::- (Eq k, Eq v, Eq (Tag v), HasTag v) =>+ (Eq k, Eq (Tag v), HasTag v) => k -> v -> BiMap k v -> Bool insertPrecondition k v m = case tag v of@@ -190,7 +190,7 @@ -- @k@ may map to a value @v'@ for which @'tag' v' = 'tag' v@. alterPrecondition ::- (Ord k, Eq v, Eq (Tag v), HasTag v) =>+ (Ord k, Eq (Tag v), HasTag v) => (Maybe v -> Maybe v) -> k -> BiMap k v -> Bool alterPrecondition f k m = case tag =<< f (lookup k m) of@@ -216,7 +216,7 @@ -- than @k@ may map to a value @v'@ for which @'tag' v' = 'tag' v@. updatePrecondition ::- (Ord k, Eq v, Eq (Tag v), HasTag v) =>+ (Ord k, Eq (Tag v), HasTag v) => (v -> Maybe v) -> k -> BiMap k v -> Bool updatePrecondition f = alterPrecondition (f =<<) @@ -234,7 +234,7 @@ -- than @k@ may map to a value @v'@ for which @'tag' v' = 'tag' v@. adjustPrecondition ::- (Ord k, Eq v, Eq (Tag v), HasTag v) =>+ (Ord k, Eq (Tag v), HasTag v) => (v -> v) -> k -> BiMap k v -> Bool adjustPrecondition f = updatePrecondition (Just . f) @@ -262,7 +262,7 @@ -- @'tag' v'' = 'tag' v'@. insertLookupWithKeyPrecondition ::- (Ord k, Eq v, Eq (Tag v), HasTag v) =>+ (Ord k, Eq (Tag v), HasTag v) => (k -> v -> v -> v) -> k -> v -> BiMap k v -> Bool insertLookupWithKeyPrecondition f k v = alterPrecondition (Just . maybe v (f k v)) k@@ -302,8 +302,7 @@ -- maps @k@ to @v@, then @'tag' (f k v) == 'tag' v@. mapWithKeyFixedTagsPrecondition ::- (Eq v, Eq (Tag v), HasTag v) =>- (k -> v -> v) -> BiMap k v -> Bool+ ( Eq (Tag v), HasTag v) =>(k -> v -> v) -> BiMap k v -> Bool mapWithKeyFixedTagsPrecondition f m = and [ tag (f k v) == tag v | (k, v) <- toList m
+ src/full/Agda/Utils/BinTree.hs view
@@ -0,0 +1,40 @@+-- | Binary trees, used for O(1) append.++module Agda.Utils.BinTree (BinTree, prependToList, toList) where++import Agda.Utils.BinTree1 (BinTree1)+import Agda.Utils.BinTree1 qualified as BinTree1+import Agda.Utils.Null+import Agda.Utils.Singleton++import Agda.Utils.Impossible++data BinTree a+ = BT0+ | BT1 !(BinTree1 a)+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++instance Null (BinTree a) where+ empty = BT0+ null = \case+ BT0 -> True+ BT1 _ -> False++instance Semigroup (BinTree a) where+ BT0 <> t = t+ t <> BT0 = t+ BT1 t1 <> BT1 t2 = BT1 (t1 <> t2)++instance Monoid (BinTree a) where+ mempty = empty++instance Singleton a (BinTree a) where+ singleton = BT1 . singleton++prependToList :: BinTree a -> [a] -> [a]+prependToList = \case+ BT0 -> id+ BT1 t -> BinTree1.prependToList t++toList :: BinTree a -> [a]+toList = (`prependToList` [])
+ src/full/Agda/Utils/BinTree1.hs view
@@ -0,0 +1,31 @@+-- | Binary trees, used for O(1) append.++module Agda.Utils.BinTree1 (BinTree1, prependToList, toList, toList1) where++import Agda.Utils.List1 (List1)+import Agda.Utils.List1 qualified as List1+import Agda.Utils.Singleton++import Agda.Utils.Impossible++data BinTree1 a+ = Lf1 a+ | !(BinTree1 a) :++: !(BinTree1 a)+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++instance Semigroup (BinTree1 a) where+ (<>) = (:++:)++instance Singleton a (BinTree1 a) where+ singleton = Lf1++prependToList :: BinTree1 a -> [a] -> [a]+prependToList = \case+ Lf1 a -> (a:)+ t1 :++: t2 -> prependToList t1 . prependToList t2++toList :: BinTree1 a -> [a]+toList = (`prependToList` [])++toList1 :: BinTree1 a -> List1 a+toList1 = List1.fromListSafe __IMPOSSIBLE__ . toList
src/full/Agda/Utils/BoolSet.hs view
@@ -8,8 +8,8 @@ -- -- Import as: -- @--- import qualified Agda.Utils.BoolSet as BoolSet -- import Agda.Utils.BoolSet (BoolSet)+-- import Agda.Utils.BoolSet qualified as BoolSet -- @ module Agda.Utils.BoolSet
src/full/Agda/Utils/Boolean.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-} {-# OPTIONS_GHC -Wunused-imports #-} -- | Boolean algebras and types isomorphic to 'Bool'.@@ -19,7 +20,7 @@ module Agda.Utils.Boolean where import Prelude ( Bool(True,False), Eq, ($), (.), const, id )-import qualified Prelude as P+import Prelude qualified as P infixr 3 && infixr 2 ||
+ src/full/Agda/Utils/ByteArray.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}++-- | Utilities for working with 'ByteArray' and 'ByteArray#'.+module Agda.Utils.ByteArray+ (+ -- * Constructing byte arrays+ byteArrayOnes#+ -- * Queries+ , byteArrayIsSubsetOf#+ , byteArrayDisjoint#+ -- * Folds+ --+ -- $byteArrayFolds+ , byteArrayFoldrBits#+ , byteArrayFoldlBits#+ -- ** Strict folds+ , byteArrayFoldrBitsStrict#+ , byteArrayFoldlBitsStrict#+ ) where++-- We need the machines word size for some bitwise operations.+#include "MachDeps.h"++import GHC.Base+import GHC.Num.WordArray++import Agda.Utils.Word++--------------------------------------------------------------------------------+-- Constructing byte arrays++-- | Construct a 'ByteArray#' consisting of @n@ 1 bits.+byteArrayOnes# :: Int# -> ByteArray#+byteArrayOnes# n =+ let !(# q, r #) = quotRemInt# n WORD_SIZE_IN_BITS# in+ if isTrue# (r ==# 0#) then+ withNewWordArray# q \mwa st ->+ byteArrayFillOnes# mwa 0# q st+ else+ withNewWordArray# (q +# 1#) \mwa st ->+ let st' = byteArrayFillOnes# mwa 0# q st+ in mwaWrite# mwa q (uncheckedWordOnes# r) st'+{-# NOINLINE byteArrayOnes# #-}++-- | @byteArrayFillOnes# mwa start end st@ will fill a 'MutableByteArray#' with+-- ones from @start@ to @end - 1@.+byteArrayFillOnes# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+byteArrayFillOnes# bs i len st =+ if isTrue# (i <# len) then+ let st' = mwaWrite# bs i (not# 0##) st+ in byteArrayFillOnes# bs (i +# 1#) len st'+ else+ st++--------------------------------------------------------------------------------+-- Queries++-- | Check that if the set bits of a 'ByteArray#' are a subset+-- of another 'ByteArray#'.+byteArrayIsSubsetOf# :: ByteArray# -> ByteArray# -> Int#+byteArrayIsSubsetOf# bs1 bs2 =+ if isTrue# (len1 <=# len2) then+ loop 0#+ else+ 0#+ where+ len1 = wordArraySize# bs1+ len2 = wordArraySize# bs2++ loop :: Int# -> Int#+ loop i =+ if isTrue# (i <# len1) then+ let w1 = indexWordArray# bs1 i+ w2 = indexWordArray# bs2 i+ in if isTrue# ((w1 `and#` w2) `eqWord#` w1) then+ loop (i +# 1#)+ else+ 0#+ else+ 1#+{-# NOINLINE byteArrayIsSubsetOf# #-}++-- | Check if two 'ByteArray#'s are bitwise disjoint.+byteArrayDisjoint# :: ByteArray# -> ByteArray# -> Int#+byteArrayDisjoint# bs1 bs2 =+ let len1 = wordArraySize# bs1+ len2 = wordArraySize# bs2+ in if isTrue# (len1 <=# len2) then+ loop 0# len1+ else+ loop 0# len2+ where+ loop :: Int# -> Int# -> Int#+ loop i len =+ if isTrue# (i <# len) then+ let w1 = indexWordArray# bs1 i+ w2 = indexWordArray# bs2 i+ in if (isTrue# (disjointWord# w1 w2)) then+ loop (i +# 1#) len+ else+ 0#+ else+ 1#+{-# NOINLINE byteArrayDisjoint# #-}++--------------------------------------------------------------------------------+-- Folds++-- $byteArrayFolds+-- As usual, there is an ambiguity in left/right folds for folding over the bits of a+-- 'ByteArray#'. We opt to use the convention where we treat the 0th bit as the "head" of+-- the 'ByteArray#', so a right fold like @byteArrayFoldrBits# f x 0b1011@ would give @f 0 (f 1 (f 3 x))@.+++{-# INLINE byteArrayFoldrBits# #-}+-- | Perform a lazy right fold over the bit indicies of a 'ByteArray#'.+byteArrayFoldrBits# :: (Int -> a -> a) -> a -> ByteArray# -> a+byteArrayFoldrBits# f = \a bs -> loop 0# a bs (wordArraySize# bs)+ where+ -- Not tail recursive.+ loop i a bs len =+ if isTrue# (i <# len) then+ wordFoldrBitsOffset# (WORD_SIZE_IN_BITS# *# i) f (loop (i +# 1#) a bs len) (indexWordArray# bs i)+ else+ a++{-# INLINE byteArrayFoldlBits# #-}+-- | Perform a lazy left fold over the bit indicies of a 'ByteArray#'.+byteArrayFoldlBits# :: (a -> Int -> a) -> a -> ByteArray# -> a+byteArrayFoldlBits# f = \a bs -> loop (wordArraySize# bs -# 1#) bs a+ where+ -- Not tail recursive.+ loop i bs a =+ if isTrue# (i >=# 0#) then+ wordFoldlBitsOffset# (WORD_SIZE_IN_BITS# *# i) f (loop (i -# 1#) bs a) (indexWordArray# bs i)+ else+ a++{-# INLINE byteArrayFoldrBitsStrict# #-}+-- | Perform a strict right fold over the bit indicies of a 'ByteArray#'.+byteArrayFoldrBitsStrict# :: (Int -> a -> a) -> a -> ByteArray# -> a+byteArrayFoldrBitsStrict# f = \a bs -> loop (wordArraySize# bs -# 1#) a bs+ where+ -- Tail recursive.+ loop i !acc bs =+ if isTrue# (i >=# 0#) then+ loop (i -# 1#) (wordFoldrBitsOffsetStrict# (WORD_SIZE_IN_BITS# *# i) f acc (indexWordArray# bs i))+ bs+ else+ acc++{-# INLINE byteArrayFoldlBitsStrict# #-}+-- | Perform a strict left fold over the bit indicies of a 'ByteArray#'.+byteArrayFoldlBitsStrict# :: (a -> Int -> a) -> a -> ByteArray# -> a+byteArrayFoldlBitsStrict# f = \a bs -> loop 0# a bs (wordArraySize# bs)+ where+ -- Tail recursive.+ loop i !acc bs len =+ if isTrue# (i <# len) then+ loop (i +# 1#) (wordFoldlBitsOffsetStrict# (WORD_SIZE_IN_BITS# *# i) f acc (indexWordArray# bs i))+ bs len+ else+ acc
src/full/Agda/Utils/CallStack/Pretty.hs view
@@ -9,7 +9,7 @@ , getCallStack ) import Agda.Syntax.Common.Pretty- ( (<+>), ($+$), (<>)+ ( (<+>), ($+$) , pshow, text , colon, comma , nest, parens@@ -18,7 +18,8 @@ ) instance Pretty SrcLoc where- pretty SrcLoc {..} = hsep [physicalLoc, "in", logicalLoc]+ pretty SrcLoc{ srcLocPackage, srcLocModule, srcLocFile, srcLocStartLine,+ srcLocStartCol } = hsep [physicalLoc, "in", logicalLoc] where physicalLoc = hcat [text srcLocFile, colon, pshow srcLocStartLine, colon, pshow srcLocStartCol] logicalLoc = hcat [text srcLocPackage, colon, text srcLocModule]
src/full/Agda/Utils/Cluster.hs view
@@ -18,7 +18,7 @@ import Data.List.NonEmpty ( NonEmpty(..), nonEmpty, toList ) import Data.Maybe ( fromMaybe ) -import qualified Data.Map.Strict as MapS+import Data.Map.Strict qualified as MapS import Agda.Utils.Functor import Agda.Utils.Singleton
+ src/full/Agda/Utils/CompactRegion.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE MagicHash, UnboxedTuples #-}++module Agda.Utils.CompactRegion where++import GHC.Exts+import GHC.Types+import GHC.Word+import Control.DeepSeq++data Compact = Compact Compact#++instance NFData Compact where+ rnf !x = ()++-- | Create a new compact region with given initial block size.+new :: Word -> IO Compact+new (W# size) = IO \s -> case compactNew# size s of+ (# s, com #) -> (# s, Compact com #)+{-# INLINE new #-}++-- | Add a value to a compact region.+add :: Compact -> a -> IO a+add (Compact com) a = IO (compactAdd# com a)+{-# INLINE add #-}++{-# INLINE compactWithSharing #-}+compactWithSharing :: a -> IO a+compactWithSharing a = do+ !(Compact c) <- new 31268+ IO (compactAddWithSharing# c a)
+ src/full/Agda/Utils/CompressedTrie.hs view
@@ -0,0 +1,186 @@+{-# OPTIONS_GHC -Wunused-imports #-}+{-# OPTIONS_GHC -Wunused-matches #-}+{-# OPTIONS_GHC -Wunused-binds #-}++-- | Strict compressed tries+-- (based on "Data.Map.Strict" and "Agda.Utils.Maybe.Strict").+--+-- In contrast to "Agda.Utils.Trie", branches from a node+-- can be labeled with non-empty lists of keys that do not+-- overlap, meaning they start with different first elements.+-- This way, non-branching unlabelled pathes can be stored+-- more efficiently.+--+-- As a side effect, the notion of height changes+-- which we utilize in the 'truncate' function.+--+-- An 'Agda.Utils.CompressedTrie.Trie' is usually constructed+-- from an 'Agda.Utils.Trie.Trie' via the 'compress' function.++module Agda.Utils.CompressedTrie where++import Prelude hiding (null, truncate)++import Control.DeepSeq++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Monoid (Sum(Sum,getSum))++import Agda.Utils.List1 (List1, pattern (:|))+import Agda.Utils.List1 qualified as List1+import Agda.Utils.Map (isSingleMap)+import Agda.Utils.Maybe.Strict qualified as Strict+import Agda.Utils.Null+import Agda.Utils.Singleton+import Agda.Utils.Trie qualified as Uncompressed++import Agda.Utils.Impossible (__IMPOSSIBLE__)++-- | Finite map from @[k]@ to @v@.+--+-- With the strict 'Maybe' type, 'Trie' is also strict in 'v'.+--+-- Invariant: only the root of the tree+-- may be of the form @Trie Nothing (Map.singleton ks t)@.+-- A node inside of the trie of that form must be fused+-- into its branch.+data Trie k v = Trie+ { trieValue :: !(Strict.Maybe v)+ , trieBranches :: !(Map (List1 k) (Trie k v))+ -- Invariant: The keys are prefix-free, meaning their first letters differ.+ }+ deriving+ ( Show+ , Eq+ -- Andreas, 2024-11-16: The derived Eq isn't extensional.+ -- It disguishes different representation of the empty Trie.+ -- (E.g. the empty map and the map that only contains Nothing values.)+ , Functor+ , Foldable+ )++instance (NFData k, NFData v) => NFData (Trie k v) where+ rnf (Trie a b) = rnf a `seq` rnf b++---------------------------------------------------------------------------+-- * Construction++-- | Empty trie.+instance Null (Trie k v) where+ empty = Trie Strict.Nothing Map.empty+ null (Trie v t) = null v && all null t+ -- Andreas, 2024-11-16: since we allow non-canoncial tries,+ -- we have to check that every subtrie is empty,+ -- not just that there are no subtries.++-- | Singleton tree with value at the root.+root :: v -> Trie k v+root v = Trie (Strict.Just v) Map.empty++instance Singleton ([k],v) (Trie k v) where+ singleton = uncurry Agda.Utils.CompressedTrie.singleton++-- | Singleton trie.+singleton :: [k] -> v -> Trie k v+singleton [] = root+singleton (k : ks) = singleton1 (k :| ks)++-- | Singleton tree with empty root.+singleton1 :: List1 k -> v -> Trie k v+singleton1 ks = Trie Strict.Nothing . Map.singleton ks . root++-- | A single branch with the given subtree.+-- Precondition: the given subtree has a value at the root.+singleBranch :: List1 k -> Trie k v -> (List1 k, Trie k v)+singleBranch ks t+ | Just (ks', t') <- isSingleBranch t = (ks <> ks', t')+ | otherwise = (ks, t)++-- | Is the trie starting with a single branch?+isSingleBranch :: Trie k v -> Maybe (List1 k, Trie k v)+isSingleBranch = \case+ Trie Strict.Nothing ts | Just (k, t) <- isSingleMap ts+ -> Just (k, t)+ _ -> Nothing++-- | Turn a trie into a compressed trie.+compress :: Ord k => Uncompressed.Trie k v -> Trie k v+compress (Uncompressed.Trie mv ts) =+ Trie mv $ Map.fromList $ map go $ Map.toList ts+ where+ go (k, t) = singleBranch (List1.singleton k) (compress t)++---------------------------------------------------------------------------+-- * Deconstruction++-- | Turn a compressed trie into an uncompressed trie.+uncompress :: forall k v. Ord k => Trie k v -> Uncompressed.Trie k v+uncompress (Trie mv ts) =+ Uncompressed.Trie mv $ Map.fromList $ map go $ Map.toList ts+ where+ go :: (List1 k, Trie k v) -> (k, Uncompressed.Trie k v)+ go (k :| ks, t) = (k, Uncompressed.prefixBy ks $ uncompress t)++-- | Convert to ascending list.+toList :: Ord k => Trie k v -> [([k],v)]+toList = toAscList++-- | Convert to ascending list.+toAscList :: Ord k => Trie k v -> [([k],v)]+toAscList (Trie mv ts) = Strict.maybeToList (([],) <$> mv) +++ [ (List1.toList ks1 ++ ks, v)+ | (ks1, t) <- Map.toAscList ts+ , (ks, v) <- toAscList t+ ]++-- | The number of labeled nodes.+size :: Trie k v -> Int+size (Trie mv ts) = Strict.maybe 0 (const 1) mv + getSum (foldMap (Sum . size) ts)++-- | The number of nodes that are labeled or leaves..+sizeWithLeaves :: Trie k v -> Int+sizeWithLeaves (Trie mv ts)+ | null ts = 1+ | otherwise = Strict.maybe 0 (const 1) mv + getSum (foldMap (Sum . sizeWithLeaves) ts)++---------------------------------------------------------------------------+-- * Modification++-- | Modify the leaves (input and output may be non-canonical).++substLeaves :: (Maybe v -> Trie k v) -> Trie k v -> Trie k v+substLeaves f (Trie mv ts)+ | null ts = f $ Strict.toLazy mv+ | otherwise = Trie mv (fmap (substLeaves f) ts)++-- | Truncate tree at given depth.+-- @truncate 0 t@ returns the root.++truncate :: Int -> Trie k v -> Trie k v+truncate n t@(Trie mv ts)+ | n <= 0 = if null ts then t else empty+ | otherwise = Trie mv $ fmap (truncate (n - 1)) ts++-- | Truncate the tree so that it has at most the given size+-- according to the given sizing function.+-- @truncateSize sizing 0 t@ returns the trie @truncate 0 t@.++truncateSize :: forall k v. (Trie k v -> Int) -> Int -> Trie k v -> Trie k v+truncateSize size n t =+ -- Drop while still increasing but staying below n.+ case+ dropWhile+ (\ ((n1,_),(n2,_)) -> n1 < n2 && n2 < n)+ (zip ts (drop 1 ts))+ of+ -- Return the last trie that was still increasing and stayed below n.+ ((_, t1), _) : _ -> t1+ [] -> __IMPOSSIBLE__+ where+ ts :: [(Int, Trie k v)]+ ts = [ (size t', t') | d <- [0..], let t' = truncate d t ]++-- | @truncateSize sizeWithLeaves@+truncateSizeWithLeaves :: Int -> Trie k v -> Trie k v+truncateSizeWithLeaves = truncateSize sizeWithLeaves
+ src/full/Agda/Utils/DocTree.hs view
@@ -0,0 +1,318 @@+{-# LANGUAGE CPP #-}++-- | A simple document tree to render @'Doc' ann@ but preserve annotations.+--+-- 'DocTree' and 'renderToTree'' originally taken from+-- <https://github.com/plt-amy/agda/blob/9fd50b883f14a05792ed79a0b693fbecb2165bf5/src/full/Agda/LSP/Output.hs>+-- but rewritten to encode more invariants.++module Agda.Utils.DocTree+ ( DocTree( Node, Text )+ , prettyDocTree+ , renderToTree+ , renderToTree'+ , renderTree'+ , treeToText+ , treeToTextNoAnn+ , treeToTextWithAnn+ )+where++import Prelude hiding (null)++import Control.DeepSeq (NFData(..))+import Data.Text (Text)+import Data.Text qualified as Text+#if MIN_VERSION_text(2,0,2)+import Data.Text.Encoding (strictBuilderToText, textToStrictBuilder)+import Data.Text.Encoding qualified+#else+-- GHC 9.2 ships text-1.2.5.0+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder qualified as Builder+#endif++import GHC.Generics (Generic)++import Text.PrettyPrint.Annotated.HughesPJ (Doc)+import Text.PrettyPrint.Annotated.HughesPJ qualified as Ppr++import Agda.Utils.Function (applyUnless)+import Agda.Utils.List1 (List1, pattern (:|), (<|))+import Agda.Utils.List1 qualified as List1+import Agda.Utils.Monoid (Fwd, pattern Fwd, appFwd)+import Agda.Utils.Null+import Agda.Utils.Range (Range(..))+import Agda.Utils.RangeMap (RangeMap)+import Agda.Utils.RangeMap qualified as RangeMap+import Agda.Utils.Singleton++import Agda.Utils.Impossible++-- | A rendered document with annotations from type @ann@.+data DocTree ann+ = Node ann [DocTree ann]+ -- ^ Stuff annotated by @ann@.+ | Text Text+ -- ^ Atom.+ deriving (Generic, Show)++instance Null (DocTree ann) where+ empty = Text mempty+ null = \case+ Node a ts -> all null ts+ Text t -> null t++instance NFData ann => NFData (DocTree ann) where++---------------------------------------------------------------------------+-- * Converting 'DocTree' to 'Doc'++prettyDocTree :: DocTree ann -> Doc ann+prettyDocTree = \case+ Text t -> Ppr.text $ Text.unpack t -- Bad, we should have a Doc that supports Text+ Node a ts -> Ppr.annotate a $ foldMap prettyDocTree ts++---------------------------------------------------------------------------+-- * Converting 'Doc' to 'DocTree'+--+-- Implemented as state machine where the state is a stack of unclosed+-- annotation with the annotated stuff inbetween.++-- | State of the right-to-left conversion to tree.+data St ann = St+ { front :: String+ -- ^ Accumulator for text.+ , stack :: List1 (Item ann)+ -- ^ A nonempty stack of annotated trees with their closing annotation bracket,+ -- waiting for the opening bracket.+ }++-- | Annotated stuff waiting for the opening bracket.+data Item ann = Item ann [DocTree ann]++-- Initial state.+instance Null ann => Null (St ann) where+ empty = St empty (List1.singleton empty)+ null (St s is) = null s && all null is++instance Null ann => Null (Item ann) where+ empty = Item empty empty+ null (Item a ts) = null a && null ts++type Width = Int+type Fill = Float++-- | Render a @'Doc' ann@ to a @'DocTree' ann@ with the given layout parameters.+-- E.g. @width=100@ @fill=1.5@.+--+renderToTree' :: forall ann. Null ann => Width -> Fill -> Doc ann -> DocTree ann+renderToTree' width fill =+ finalize . Ppr.fullRenderAnn Ppr.PageMode width fill go empty+ where+ -- State machine transition for the right-to-left automaton.+ go :: Ppr.AnnotDetails ann -> St ann -> St ann+ go = \case+ Ppr.AnnotStart -> annotStart+ Ppr.NoAnnot d _ -> noAnnot d+ Ppr.AnnotEnd a -> annotEnd a++ finalize :: St ann -> DocTree ann+ finalize (St s (Item a ts :| is))+ | null is = mkNode a s ts+ | otherwise = __IMPOSSIBLE__ -- not well-bracketed++ -- Create a node once the opening bracket has been reached.+ mkNode :: ann -> String -> [DocTree ann] -> DocTree ann+ mkNode a s ts = Node a $ applyUnless (null s) (Text (Text.pack s) :) ts++ -- Got the opening bracket on an annotation:+ -- Pop an item from the stack+ annotStart :: St ann -> St ann+ annotStart (St s (Item a ts :| is1)) =+ case is1 of+ i : is -> St "" (consTree (mkNode a s ts) i :| is)+ [] -> __IMPOSSIBLE__ -- not well-bracketed+ where+ consTree :: DocTree ann -> Item ann -> Item ann+ consTree t (Item a ts) = Item a (t : ts)++ -- Got text.+ noAnnot :: Ppr.TextDetails -> St ann -> St ann+ noAnnot (Ppr.Chr c) (St s0 is) = St (c : s0) is+ noAnnot (Ppr.Str s) (St s0 is) = St (s ++ s0) is+ noAnnot (Ppr.PStr s) (St s0 is) = St (s ++ s0) is++ -- Got the closing bracket of a new annotation:+ -- Push a new item on the stack.+ annotEnd :: ann -> St ann -> St ann+ annotEnd a (St s is1) = St "" (Item a [] <| pushStr s is1)+ where+ pushStr :: String -> List1 (Item ann) -> List1 (Item ann)+ pushStr "" is1 = is1+ pushStr s (Item a ts :| is) = Item a (Text (Text.pack s) : ts) :| is++-- | Render a @'Doc' ann@ to a @'DocTree' ann@ using standard layout parameters.+renderToTree :: forall ann. Null ann => Doc ann -> DocTree ann+renderToTree = renderToTree' 100 1.5++---------------------------------------------------------------------------+-- * Converting 'DocTree' to 'Text' et al.++-- | Generic 'DocTree' linearization.+renderTree' :: forall ann t. Monoid t => (Text -> t) -> (ann -> t -> t) -> DocTree ann -> t+renderTree' txt ann = go+ where+ go :: DocTree ann -> t+ go = \case+ Node a ts -> ann a $ foldMap go ts+ Text t -> txt t++-- Compatibility layer for different versions of package text.++#if MIN_VERSION_text(2,0,2)++#if MIN_VERSION_text(2,1,2)+type Builder = Data.Text.Encoding.StrictTextBuilder+#else+type Builder = Data.Text.Encoding.StrictBuilder+#endif++builderToText :: Builder -> Text+builderToText = strictBuilderToText++textToBuilder :: Text -> Builder+textToBuilder = textToStrictBuilder++#else++type Builder = Builder.Builder++builderToText :: Builder -> Text+builderToText = TL.toStrict . Builder.toLazyText++textToBuilder :: Text -> Builder+textToBuilder = Builder.fromText++#endif++-- | Linearize a 'DocTree' to 'Text' with the given 'Text'-rendering of the annotations.+treeToText :: (ann -> Text -> Text) -> DocTree ann -> Text+treeToText ann+ = builderToText+ . renderTree' textToBuilder \ a -> textToBuilder . ann a . builderToText+-- Naive implementation:+-- treeToText = renderTree' id++-- | Linearize a 'DocTree' to 'Text' dropping all annotations.+treeToTextNoAnn :: DocTree ann -> Text+treeToTextNoAnn = treeToText (const id)++-- ** Linearizing a 'DocTree' to a 'Text' plus a 'RangeMap'.+--+-- Outputs one annotation interval per 'Node',+-- leaving it to the 'RangeMap' to combine annotations correctly.++treeToTextWithAnn :: (Monoid ann, Null ann) => DocTree ann -> (Text, RangeMap ann)+treeToTextWithAnn = evalLin 0 . renderTree' linText linNode++-- | Linearizer state.+data LinSt ann = LinSt+ { linPosition :: Int+ -- ^ Current position.+ , linBuilder :: Builder+ -- ^ Accumulated text.+ , linRangeMap :: RangeMap ann+ -- ^ Accumulated annotation information.+ }++-- | Linearizer.+-- We need forward function composition because we process nodes left-to-right.+type Lin ann = Fwd (LinSt ann)++-- | Run linearizer with given initial offset.+evalLin :: Int -> Lin ann -> (Text, RangeMap ann)+evalLin start f =+ case f `appFwd` initLinSt start of+ LinSt _ b m -> (builderToText b, m)++-- | Initial linearizer state with configurable offset.+initLinSt :: Int -> LinSt ann+initLinSt start = LinSt start mempty empty++-- | Outputting some text under the currently active annotations.+linText :: Text -> Lin ann+linText t = Fwd \case+ LinSt start b m -> LinSt end b' m+ where+ end = start + Text.length t+ b' = b <> textToBuilder t++-- | Add an annotation to the 'RangeMap'.+linNode :: (Monoid ann, Null ann) => ann -> Lin ann -> Lin ann+linNode a f = Fwd \case+ st@LinSt{ linPosition = start } -> st'{ linRangeMap = m' }+ where+ -- Render content first to get the end position.+ st'@LinSt{ linPosition = end, linRangeMap = m } = f `appFwd` st+ r = Range{ from = start, to = end }+ -- Insert annotation, leaving it to the RangeMap to combine it with the+ -- existing annotations.+ m' = applyUnless (null a) (RangeMap.insert (<>) r a) m++-- ** Alternative linearizer (first implementation).+--+-- This alternative does not need a sophisticated 'RangeMap',+-- it takes care of the annotation composition itself+-- and outputs the final intervals in left-to-right order.+--+-- The drawback is that it produces an annotation interval for each 'Text'+-- leaf of the 'DocTree' rather than preserving continguous intervals+-- stretching over subtrees.+-- As 'RangeMap' does not join adjacent intervals,+-- this leads to a lot of tiny intervals,+-- which increases the communication load between Agda and Emacs.++treeToTextWithAnnA :: Monoid ann => DocTree ann -> (Text, RangeMap ann)+treeToTextWithAnnA = evalLinA 0 . renderTree' linAText linANode++-- | Linearizer state.+data LinASt ann = LinASt+ { bstPosition :: Int+ -- ^ Current position.+ , bstAnnotations :: List1 ann+ -- ^ The top of the stack is the currently active annotation(s).+ , bstBuilder :: Builder+ -- ^ Accumulated text.+ , bstRangeMap :: RangeMap ann+ -- ^ Accumulated annotation information.+ }++-- | Linearizer.+type LinA ann = Fwd (LinASt ann)++-- | Run linearizer with given initial offset.+evalLinA :: Monoid ann => Int -> LinA ann -> (Text, RangeMap ann)+evalLinA start f =+ case f `appFwd` initLinASt start of+ LinASt _ _ b m -> (builderToText b, m)++-- | Initial linearizer state with configurable offset.+initLinASt :: Monoid ann => Int -> LinASt ann+initLinASt start = LinASt start (singleton mempty) mempty empty++-- | Outputting some text under the currently active annotations.+linAText :: Monoid ann => Text -> LinA ann+linAText t = Fwd \case+ LinASt start as@(a :| _) b m -> LinASt end as b' m'+ where+ end = start + Text.length t+ b' = b <> textToBuilder t+ m' = RangeMap.insert (<>) r a m+ r = Range{ from = start, to = end }++-- | Adding an annotation to the currently active ones.+linANode :: Monoid ann => ann -> LinA ann -> LinA ann+linANode a f = Fwd \case+ st@LinASt{ bstAnnotations = as@(a' :| _) } ->+ f `appFwd` st{ bstAnnotations = (a <> a') <| as }
src/full/Agda/Utils/Either.hs view
@@ -29,7 +29,7 @@ import Agda.Utils.List ( spanJust ) import Agda.Utils.List1 ( List1, pattern (:|), (<|) )-import qualified Agda.Utils.List1 as List1+import Agda.Utils.List1 qualified as List1 -- | Loop while we have an exception.
+ src/full/Agda/Utils/ExpandCase.hs view
@@ -0,0 +1,95 @@++{- |+This module is intended for high-performance programming. Concretely, the 'ExpandCase' class can be+used to force GHC to avoid compiling 'Reader', 'Endo' or 'State'-based code to unnecessary closures.+You can observe its usage in 'Agda.TypeChecking.Free.Generic'. For a smaller example and some+explanation, consider the following.++@+f :: Bool -> Endo Int+f b = case b of+ True -> mempty+ False -> Endo (+ 10)+@++The desired @-O1@ output should be the following (ignoring newtype casts):++@+f = \b n -> case b of+ True -> n+ False -> n + 10+@++A typical undesired output would be++@+f = \b -> case b of+ True -> \n -> n+ False -> \n -> n + 10+@++Returning closures can be better or worse, depending on the program context. However, in+high-performance situations we almost never want to return closures, and GHC is not nearly reliable+enough at getting rid of the closures.++Using 'ExpandCase', we can write code as follows.++@+f :: Bool -> Endo Int+f b = expand \ret -> case b of+ True -> ret mempty+ False -> ret $ Endo (+10)+@++Here, 'expand' immediately introduces a lambda abstraction, and the @ret@ continuation applies the+"body" of the definition to the freshly abstracted variable. Hence, we get something like the+following as an intermediate piece of Core:++@+f :: Bool -> Endo Int+f b = Endo \n -> case b of+ True -> appEndo mempty n+ False -> appEndo (Endo (+10)) n+@++which is then reliably optimized to++@+f :: Bool -> Endo Int+f b = Endo \n -> case b of+ True -> n+ False -> n + 10+@++NOTE: if you want to use this module, it is very strongly recommended that you check the Core of+your code!+-}++module Agda.Utils.ExpandCase where++import Data.Monoid+import GHC.Exts (oneShot)+import Data.Strict.Tuple++class ExpandCase a where+ type Result a+ expand :: ((a -> Result a) -> Result a) -> a++ {-# INLINE expand #-}+ default expand :: (Result a ~ a) => ((a -> Result a) -> Result a) -> a+ expand k = k id++instance ExpandCase Any where type Result Any = Any+instance ExpandCase All where type Result All = All+instance ExpandCase () where type Result () = ()+instance ExpandCase (Pair a b) where type Result (Pair a b) = Pair a b+instance ExpandCase (IO a) where type Result (IO a) = IO a+instance ExpandCase [a] where type Result [a] = [a]+instance ExpandCase (Maybe a) where type Result (Maybe a) = Maybe a+instance ExpandCase Int where type Result Int = Int+instance ExpandCase Bool where type Result Bool = Bool++instance ExpandCase (Endo a) where+ type Result (Endo a) = a+ {-# INLINE expand #-}+ expand k = Endo (oneShot \a -> k (oneShot \act -> appEndo act a))
src/full/Agda/Utils/Favorites.hs view
@@ -6,15 +6,15 @@ -- To avoid name clashes, import this module qualified, as in -- @ -- import Agda.Utils.Favorites (Favorites)--- import qualified Agda.Utils.Favorites as Fav+-- import Agda.Utils.Favorites qualified as Fav -- @ module Agda.Utils.Favorites where import Prelude hiding ( null ) -import qualified Data.List as List-import qualified Data.Set as Set+import Data.List qualified as List+import Data.Set qualified as Set import Agda.Utils.Null import Agda.Utils.PartialOrd@@ -23,7 +23,7 @@ -- | A list of incomparable favorites. newtype Favorites a = Favorites { toList :: [a] }- deriving (Foldable, Show, Null, Singleton a)+ deriving (Foldable, Show, Null, Singleton a, Functor) -- | Equality checking is a bit expensive, since we need to sort! -- Maybe use a 'Set' of favorites in the first place?@@ -73,11 +73,11 @@ -- @compareFavorites new old = (new', old')@ compareFavorites :: PartialOrd a => Favorites a -> Favorites a -> (Favorites a, Favorites a)-compareFavorites new old = mapFst Favorites $ loop (toList new) old where+compareFavorites new old = first Favorites $ loop (toList new) old where loop [] old = ([], old) loop (a : new) old = case compareWithFavorites a old of -- Better: Discard all @old@ ones that @a@ dominates and keep @a@- Dominates _ old -> mapFst (a:) $ loop new (Favorites old)+ Dominates _ old -> first (a:) $ loop new (Favorites old) -- Not better: Discard @a@ IsDominated{} -> loop new old
src/full/Agda/Utils/FileId.hs view
@@ -5,30 +5,39 @@ module Agda.Utils.FileId where -import Prelude hiding (null)+import Prelude hiding (null) -import Control.DeepSeq (NFData)-import Control.Monad.Except (ExceptT)-import Control.Monad.Reader (ReaderT)-import Control.Monad.State (StateT)-import Control.Monad.Trans (MonadTrans, lift)+import Control.DeepSeq (NFData)+import Control.Monad.Except (ExceptT)+import Control.Monad.Identity (IdentityT)+import Control.Monad.Reader (ReaderT)+import Control.Monad.State (StateT)+import Control.Monad.Trans (MonadTrans, lift)+import Control.Monad.Trans.Maybe (MaybeT)+import Control.Monad.Writer (WriterT) -import Data.Bifunctor (second)-import Data.EnumMap (EnumMap)-import qualified Data.EnumMap as EnumMap-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe (fromMaybe)-import Data.Word (Word32)+import Data.Bifunctor (second)+import Data.EnumMap (EnumMap)+import Data.EnumMap qualified as EnumMap+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Maybe (fromMaybe)+import Data.Word (Word32) -import GHC.Generics (Generic)+import GHC.Generics (Generic) -import Agda.Utils.CallStack (HasCallStack)-import Agda.Utils.FileName (AbsolutePath)-import Agda.Utils.Null (Null(..))+import Agda.Utils.CallStack (HasCallStack)+import Agda.Utils.FileName (AbsolutePath)+import Agda.Utils.ListT (ListT)+import Agda.Utils.Null (Null(..))+import Agda.Utils.Update (ChangeT) -import Agda.Utils.Impossible (__IMPOSSIBLE__)+import Agda.Utils.StrictReader qualified as Strict+import Agda.Utils.StrictWriter qualified as Strict+import Agda.Utils.StrictState qualified as Strict +import Agda.Utils.Impossible+ type File = AbsolutePath -- | Unique identifier of a file.@@ -86,7 +95,7 @@ -- * Monadic interface class Monad m => MonadFileId m where- fileFromId :: FileId -> m File+ fileFromId :: HasCallStack => FileId -> m File idFromFile :: File -> m FileId default fileFromId :: (MonadTrans t, MonadFileId n, m ~ t n) => FileId -> m File@@ -96,8 +105,16 @@ idFromFile = lift . idFromFile instance MonadFileId m => MonadFileId (ExceptT e m)+instance MonadFileId m => MonadFileId (IdentityT m)+instance MonadFileId m => MonadFileId (ListT m)+instance MonadFileId m => MonadFileId (MaybeT m) instance MonadFileId m => MonadFileId (ReaderT r m) instance MonadFileId m => MonadFileId (StateT s m)+instance (MonadFileId m, Monoid w) => MonadFileId (WriterT w m)+instance MonadFileId m => MonadFileId (Strict.ReaderT r m)+instance MonadFileId m => MonadFileId (Strict.StateT s m)+instance (MonadFileId m, Monoid w) => MonadFileId (Strict.WriterT w m)+instance MonadFileId m => MonadFileId (ChangeT m) -- Instances for GetFileId
src/full/Agda/Utils/FileName.hs view
file too large to diff
src/full/Agda/Utils/Float.hs view
file too large to diff
src/full/Agda/Utils/Function.hs view
file too large to diff
src/full/Agda/Utils/Functor.hs view
file too large to diff
src/full/Agda/Utils/GetOpt.hs view
file too large to diff
src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs view
file too large to diff
src/full/Agda/Utils/Graph/TopSort.hs view
file too large to diff
src/full/Agda/Utils/Hash.hs view
file too large to diff
src/full/Agda/Utils/HashTable.hs view
file too large to diff
src/full/Agda/Utils/Haskell/Syntax.hs view
file too large to diff
src/full/Agda/Utils/IArray.hs view
file too large to diff
src/full/Agda/Utils/IO/Directory.hs view
file too large to diff
src/full/Agda/Utils/IO/TempFile.hs view
file too large to diff
+ src/full/Agda/Utils/IO/Terminal.hs view
file too large to diff
src/full/Agda/Utils/IO/UTF8.hs view
file too large to diff
+ src/full/Agda/Utils/IORef/Strict.hs view
file too large to diff
+ src/full/Agda/Utils/IndexMap.hs view
file too large to diff
+ src/full/Agda/Utils/IntMap.hs view
file too large to diff
src/full/Agda/Utils/IntSet/Infinite.hs view
file too large to diff
src/full/Agda/Utils/Lens.hs view
file too large to diff
src/full/Agda/Utils/List.hs view
file too large to diff
src/full/Agda/Utils/List1.hs view
file too large to diff
src/full/Agda/Utils/List2.hs view
file too large to diff
+ src/full/Agda/Utils/ListInf.hs view
file too large to diff
src/full/Agda/Utils/ListT.hs view
file too large to diff
src/full/Agda/Utils/Map.hs view
file too large to diff
src/full/Agda/Utils/Map1.hs view
file too large to diff
src/full/Agda/Utils/Maybe.hs view
file too large to diff
src/full/Agda/Utils/Maybe/Strict.hs view
file too large to diff
+ src/full/Agda/Utils/Maybe/Unboxable.hs view
file too large to diff
src/full/Agda/Utils/Memo.hs view
file too large to diff
+ src/full/Agda/Utils/MinimalArray/Lifted.hs view
file too large to diff
+ src/full/Agda/Utils/MinimalArray/MutableLifted.hs view
file too large to diff
+ src/full/Agda/Utils/MinimalArray/MutablePrim.hs view
file too large to diff
+ src/full/Agda/Utils/MinimalArray/Prim.hs view
file too large to diff
src/full/Agda/Utils/Monad.hs view
file too large to diff
src/full/Agda/Utils/Monoid.hs view
file too large to diff
src/full/Agda/Utils/Null.hs view
file too large to diff
src/full/Agda/Utils/Parser/MemoisedCPS.hs view
file too large to diff
src/full/Agda/Utils/PartialOrd.hs view
file too large to diff
src/full/Agda/Utils/Permutation.hs view
file too large to diff
− src/full/Agda/Utils/ProfileOptions.hs
file too large to diff
+ src/full/Agda/Utils/Range.hs view
file too large to diff
src/full/Agda/Utils/RangeMap.hs view
file too large to diff
src/full/Agda/Utils/Semigroup.hs view
file too large to diff
+ src/full/Agda/Utils/Serialize.hs view
file too large to diff
+ src/full/Agda/Utils/Set.hs view
file too large to diff
src/full/Agda/Utils/Set1.hs view
file too large to diff
src/full/Agda/Utils/Singleton.hs view
file too large to diff
src/full/Agda/Utils/Size.hs view
file too large to diff
src/full/Agda/Utils/SmallSet.hs view
file too large to diff
+ src/full/Agda/Utils/StrictEndo.hs view
file too large to diff
+ src/full/Agda/Utils/StrictFlipEndo.hs view
file too large to diff
+ src/full/Agda/Utils/StrictReader.hs view
file too large to diff
+ src/full/Agda/Utils/StrictState.hs view
file too large to diff
+ src/full/Agda/Utils/StrictState2.hs view
file too large to diff
+ src/full/Agda/Utils/StrictWriter.hs view
file too large to diff
src/full/Agda/Utils/String.hs view
file too large to diff
src/full/Agda/Utils/Suffix.hs view
file too large to diff
src/full/Agda/Utils/Three.hs view
file too large to diff
src/full/Agda/Utils/Time.hs view
file too large to diff
src/full/Agda/Utils/Trie.hs view
file too large to diff
src/full/Agda/Utils/Tuple.hs view
file too large to diff
+ src/full/Agda/Utils/Tuple/Strict.hs view
file too large to diff
src/full/Agda/Utils/TypeLevel.hs view
file too large to diff
src/full/Agda/Utils/Unsafe.hs view
file too large to diff
src/full/Agda/Utils/Update.hs view
file too large to diff
src/full/Agda/Utils/VarSet.hs view
file too large to diff
src/full/Agda/Utils/WithDefault.hs view
file too large to diff
+ src/full/Agda/Utils/Word.hs view
file too large to diff
+ src/full/Agda/Utils/Zip.hs view
file too large to diff
src/full/Agda/Utils/Zipper.hs view
file too large to diff
src/setup/Agda/Setup.hs view
file too large to diff
src/setup/Agda/Setup/DataFiles.hs view
file too large to diff
+ src/setup/Agda/Setup/LockFile.hs view
file too large to diff
src/setup/Agda/VersionCommit.hs view
file too large to diff
− stack-8.10.7.yaml
file too large to diff
− stack-8.8.4.yaml
file too large to diff
− stack-9.0.2.yaml
file too large to diff
stack-9.10.3.yaml view
file too large to diff
stack-9.12.4.yaml view
file too large to diff
stack-9.14.1.yaml view
file too large to diff
stack-9.2.8.yaml view
file too large to diff
stack-9.4.8.yaml view
file too large to diff